[r-cran-vgam] 25/63: Import Upstream version 0.8-4
Andreas Tille
tille at debian.org
Tue Jan 24 13:54:28 UTC 2017
This is an automated email from the git hooks/post-receive script.
tille pushed a commit to branch master
in repository r-cran-vgam.
commit 042ec924bb94ee4ea8f47f9429c8892cf9ee57fc
Author: Andreas Tille <tille at debian.org>
Date: Tue Jan 24 14:16:53 2017 +0100
Import Upstream version 0.8-4
---
DESCRIPTION | 20 +-
MD5 | 555 +++++++++++
NAMESPACE | 36 +-
NEWS | 46 +
R/aamethods.q | 14 +-
R/cao.fit.q | 16 +-
R/cqo.fit.q | 24 +-
R/family.aunivariate.R | 607 ++++++------
R/family.basics.R | 54 +-
R/family.binomial.R | 340 ++++---
R/family.bivariate.R | 516 +++++-----
R/family.categorical.R | 379 ++++----
R/family.censored.R | 12 +-
R/family.circular.R | 209 +++--
R/family.exp.R | 2 +-
R/family.extremes.R | 34 +-
R/family.genetic.R | 30 +-
R/family.glmgam.R | 421 +++++----
R/family.loglin.R | 20 +-
R/family.mixture.R | 298 +++---
R/family.nonlinear.R | 10 +-
R/family.normal.R | 94 +-
R/family.others.R | 14 +-
R/family.positive.R | 186 +++-
R/family.qreg.R | 1254 ++++++++++++++-----------
R/family.quantal.R | 373 ++++++++
R/family.rcam.R | 516 +++++++++-
R/family.robust.R | 133 ++-
R/family.rrr.R | 36 +-
R/family.survival.R | 32 +-
R/family.ts.R | 77 +-
R/family.univariate.R | 741 ++++++++-------
R/family.zeroinf.R | 481 ++++++++--
R/{fitted.vlm.R => fittedvlm.R} | 29 +-
R/links.q | 162 +++-
R/model.matrix.vglm.q | 25 +
R/nobs.R | 207 ++++
R/plot.vglm.q | 17 +
R/predict.vgam.q | 41 +-
R/predict.vglm.q | 14 +-
R/qtplot.q | 6 +-
R/rrvglm.R | 20 +-
R/rrvglm.fit.q | 16 +-
R/s.q | 51 +-
R/summary.vgam.q | 327 ++++---
R/summary.vglm.q | 280 +++---
R/summary.vlm.q | 32 +-
R/uqo.R | 8 +-
R/vgam.R | 26 +-
R/vgam.fit.q | 14 +-
R/vglm.R | 8 +-
R/vglm.fit.q | 16 +-
data/alclevels.rda | Bin 562 -> 561 bytes
data/alcoff.rda | Bin 557 -> 557 bytes
data/auuc.rda | Bin 243 -> 243 bytes
data/azprocedure.rda | Bin 18474 -> 18476 bytes
data/backPain.rda | Bin 603 -> 602 bytes
data/car.all.rda | Bin 8214 -> 8214 bytes
data/chestnz.txt.gz | Bin 559 -> 559 bytes
data/crashbc.rda | Bin 387 -> 387 bytes
data/crashf.rda | Bin 353 -> 353 bytes
data/crashi.rda | Bin 505 -> 503 bytes
data/crashmc.rda | Bin 397 -> 397 bytes
data/crashp.rda | Bin 392 -> 391 bytes
data/crashtr.rda | Bin 375 -> 375 bytes
data/fibre15.rda | Bin 245 -> 245 bytes
data/fibre1dot5.rda | Bin 296 -> 296 bytes
data/finney44.rda | Bin 0 -> 208 bytes
data/gala.rda | Bin 1045 -> 1045 bytes
data/gew.txt.gz | Bin 530 -> 531 bytes
data/hspider.rda | Bin 1310 -> 1311 bytes
data/hued.rda | Bin 410 -> 410 bytes
data/huie.rda | Bin 416 -> 417 bytes
data/hunua.txt.gz | Bin 1883 -> 1894 bytes
data/huse.rda | Bin 322 -> 322 bytes
data/leukemia.rda | Bin 326 -> 327 bytes
data/mmt.rda | Bin 5973 -> 5973 bytes
data/nzmarital.rda | Bin 24966 -> 25309 bytes
data/pneumo.rda | Bin 263 -> 263 bytes
data/rainfall.rda | Bin 17135 -> 17147 bytes
data/ruge.rda | Bin 255 -> 255 bytes
data/toxop.rda | Bin 465 -> 465 bytes
data/ugss.rda | Bin 15165 -> 15160 bytes
data/uscrime.rda | Bin 3967 -> 3967 bytes
data/usgrain.txt.gz | Bin 1078 -> 1077 bytes
data/venice.rda | Bin 1209 -> 1210 bytes
data/venice90.rda | Bin 13036 -> 13037 bytes
data/waitakere.txt.gz | Bin 3090 -> 3090 bytes
data/wffc.indiv.rda | Bin 2864 -> 2867 bytes
data/wffc.nc.rda | Bin 5671 -> 5671 bytes
data/wffc.rda | Bin 13544 -> 13564 bytes
data/wffc.teams.rda | Bin 540 -> 541 bytes
inst/doc/categoricalVGAM.pdf | Bin 2773966 -> 678455 bytes
man/BratUC.Rd | 58 +-
man/Coef.Rd | 80 +-
man/Coef.qrrvglm-class.Rd | 8 +-
man/Coef.rrvglm-class.Rd | 9 +-
man/Coef.rrvglm.Rd | 17 +-
man/Qvar.Rd | 233 +++++
man/VGAM-package.Rd | 75 +-
man/alaplaceUC.Rd | 18 +-
man/amlexponential.Rd | 42 +-
man/beta.ab.Rd | 2 +-
man/betaII.Rd | 2 +
man/{betabinUC.Rd => betabinomUC.Rd} | 89 +-
man/betabinomial.Rd | 22 +-
man/{betabin.ab.Rd => betabinomial.ab.Rd} | 36 +-
man/betaff.Rd | 2 +-
man/betageomUC.Rd | 12 +-
man/betageometric.Rd | 11 +-
man/binom2.rho.Rd | 2 +-
man/binomialff.Rd | 34 +-
man/borel.tanner.Rd | 14 +-
man/cqo.Rd | 4 +-
man/cumulative.Rd | 3 +-
man/dagum.Rd | 16 +-
man/depvar.Rd | 67 ++
man/dirmul.old.Rd | 2 +-
man/dirmultinomial.Rd | 2 +-
man/explink.Rd | 115 +++
man/finney44.Rd | 53 ++
man/{fitted.vlm.Rd => fittedvlm.Rd} | 19 +-
man/freund61.Rd | 20 +-
man/geometric.Rd | 7 +-
man/grc.Rd | 13 +-
man/huber.Rd | 35 +-
man/loge.Rd | 19 +-
man/logit.Rd | 88 +-
man/lvplot.qrrvglm.Rd | 4 +-
man/margeff.Rd | 18 +-
man/maxwell.Rd | 16 +-
man/mbinomial.Rd | 26 +-
man/mccullagh89.Rd | 47 +-
man/mix2exp.Rd | 65 +-
man/mix2normal1.Rd | 73 +-
man/mix2poisson.Rd | 58 +-
man/model.framevlm.Rd | 22 +-
man/model.matrixvlm.Rd | 33 +-
man/morgenstern.Rd | 39 +-
man/multinomial.Rd | 6 +-
man/nakagami.Rd | 45 +-
man/nakagamiUC.Rd | 49 +-
man/nbolf.Rd | 69 +-
man/normal1.Rd | 11 +-
man/notdocumentedyet.Rd | 18 +-
man/nzc.Rd | 24 +-
man/nzmarital.Rd | 5 +
man/olympic.Rd | 21 +-
man/ordpoisson.Rd | 52 +-
man/oxtemp.Rd | 6 +-
man/paralogistic.Rd | 21 +-
man/paretoIV.Rd | 27 +-
man/persp.qrrvglm.Rd | 38 +-
man/plackUC.Rd | 25 +-
man/plackett.Rd | 41 +-
man/plotdeplot.lmscreg.Rd | 4 +-
man/plotqrrvglm.Rd | 6 +-
man/plotqtplot.lmscreg.Rd | 4 +-
man/plotvgam.Rd | 22 +-
man/plotvgam.control.Rd | 14 +-
man/pneumo.Rd | 12 +-
man/poissonff.Rd | 44 +-
man/polf.Rd | 4 +-
man/polonoUC.Rd | 90 +-
man/{predict.qrrvglm.Rd => predictqrrvglm.Rd} | 18 +-
man/{predict.vglm.Rd => predictvglm.Rd} | 16 +-
man/qrrvglm.control.Rd | 2 +-
man/rcqo.Rd | 2 +-
man/tikuv.Rd | 37 +-
man/tikuvUC.Rd | 49 +-
man/toxop.Rd | 11 +-
man/triangle.Rd | 16 +-
man/triangleUC.Rd | 41 +-
man/trplot.Rd | 41 +-
man/trplot.qrrvglm.Rd | 37 +-
man/ugss.Rd | 2 +-
man/undocumented-methods.Rd | 18 +
man/vgam-class.Rd | 4 +-
man/vgam.Rd | 37 +-
man/vgam.control.Rd | 20 +-
man/vglm-class.Rd | 4 +-
man/vglm.Rd | 32 +-
man/vglm.control.Rd | 58 +-
man/vglmff-class.Rd | 13 +-
man/vonmises.Rd | 16 +-
man/vsmooth.spline.Rd | 29 +-
man/waitakere.Rd | 10 +-
man/wald.Rd | 13 +-
man/weibull.Rd | 8 +-
man/weightsvglm.Rd | 40 +-
man/wffc.P2star.Rd | 2 +-
man/wffc.Rd | 46 +-
man/wffc.nc.Rd | 3 +
man/wffc.teams.Rd | 1 +
man/yeo.johnson.Rd | 32 +-
man/yip88.Rd | 47 +-
man/yulesimon.Rd | 10 +-
man/yulesimonUC.Rd | 22 +-
man/zibinomial.Rd | 24 +-
man/zigeomUC.Rd | 81 ++
man/zigeometric.Rd | 121 +++
man/zipoisUC.Rd | 8 +-
man/zipoisson.Rd | 16 +-
src/lms.f | 4 +-
src/zeta3.c | 2 +-
205 files changed, 8074 insertions(+), 4086 deletions(-)
diff --git a/DESCRIPTION b/DESCRIPTION
index fc69dd2..daff049 100755
--- a/DESCRIPTION
+++ b/DESCRIPTION
@@ -1,20 +1,20 @@
Package: VGAM
-Version: 0.8-3
-Date: 2011-06-17
+Version: 0.8-4
+Date: 2011-11-04
Title: Vector Generalized Linear and Additive Models
Author: Thomas W. Yee <t.yee at auckland.ac.nz>
Maintainer: Thomas Yee <t.yee at auckland.ac.nz>
-Depends: R (>= 2.10.0), splines, methods, stats, stats4
+Depends: R (>= 2.11.1), splines, methods, stats, stats4
Description: Vector generalized linear and additive models, and
- associated models (Reduced-Rank VGLMs, Quadratic RR-VGLMs,
- Reduced-Rank VGAMs). This package fits many models and
- distribution by maximum likelihood estimation (MLE) or
- penalized MLE. Also fits constrained ordination models in
- ecology.
+ associated models (Reduced-Rank VGLMs, Quadratic RR-VGLMs,
+ Reduced-Rank VGAMs). This package fits many models and
+ distribution by maximum likelihood estimation (MLE) or
+ penalized MLE. Also fits constrained ordination models in
+ ecology.
License: GPL-2
URL: http://www.stat.auckland.ac.nz/~yee/VGAM
LazyLoad: yes
LazyData: yes
-Packaged: 2011-06-17 04:20:31 UTC; tyee001
+Packaged: 2011-11-04 02:00:36 UTC; tyee001
Repository: CRAN
-Date/Publication: 2011-06-17 08:34:03
+Date/Publication: 2011-11-04 07:32:26
diff --git a/MD5 b/MD5
new file mode 100644
index 0000000..6e799f1
--- /dev/null
+++ b/MD5
@@ -0,0 +1,555 @@
+a044e2c802f4451fee8abdf55163e99b *BUGS
+cef871dd6555952f7c56e4befa1b1fc1 *DESCRIPTION
+dd959d3a0cd680792122813a7d58d506 *DISCLAIMER
+ffc4775ec72cd9429aa3ba1e1c7b6a4b *NAMESPACE
+f0acc91eb36c7d77927c063d896e2177 *NEWS
+689d9e2adac8be393f6c99ceb231c574 *R/aamethods.q
+6e33af4dffcedfb8f5f8731c8af9a09b *R/add1.vglm.q
+295daee86a2890f2a6dc0c220cfd5ccb *R/attrassign.R
+a8ea0c12322404e93d896047d9fe2580 *R/bAIC.q
+5f4a87b13f0ced19c72d7f02555be6cd *R/build.terms.vlm.q
+4decb84c722995c2f054c85a0d592afb *R/calibrate.q
+72d86735dfa5eaf44d3c19b7864c42d0 *R/cao.R
+1c1602b6407924c7314546e57a46e1ce *R/cao.fit.q
+f0179cd7b5b0929e20d34f1f8c51f828 *R/coef.vlm.q
+2fcc5dae605f3cc680c93ba5a87aebca *R/cqo.R
+f2513612cbc71e6fc40d9ecc46578a13 *R/cqo.fit.q
+892125f19d7b3e1d00528e77c4e01af0 *R/deviance.vlm.q
+54a92d9b9988e5b21564f7ba463b816a *R/effects.vglm.q
+d48651321ada7f10a098a5ce6377f861 *R/family.aunivariate.R
+f0238dc328145e78234bd85e43a4607d *R/family.basics.R
+f1a4e8cb35daac0e85f34911ac23f3c9 *R/family.binomial.R
+bb4c61a751490a663a5bf3f05ab64c27 *R/family.bivariate.R
+95900e213c3d43abc198b198b24724bf *R/family.categorical.R
+a77a755af8f72cbea842c9ad6d4bb822 *R/family.censored.R
+8d6813cb126e055ecf6bc8ae00618fda *R/family.circular.R
+ee035a253c2adc60595d50d4b156db20 *R/family.exp.R
+4d65c6e54a4e027286b6a5e1299610b9 *R/family.extremes.R
+66a4fac49fd81a28f72296a22299854a *R/family.fishing.R
+b0a812cdfa23b7023ea6797f14da7f61 *R/family.functions.R
+3bc6f870614b8e4900cbbc60171d236d *R/family.genetic.R
+0f1b25d25fdd253a3515dd5b60640840 *R/family.glmgam.R
+4c195e9251e585a004feff69ba818e79 *R/family.loglin.R
+eb1eb7fd0ce4a3c30f9fda93eff1cbe9 *R/family.math.R
+695fa168795ad9d8ad268e8c70b7f23b *R/family.mixture.R
+d1566b7eefdf2318eb3cab8c69ea1b7d *R/family.nonlinear.R
+4318228aa87da125b19e77e70776b996 *R/family.normal.R
+e80de639e5bd5b5d40f30300e40f08b6 *R/family.others.R
+5268e2409e9e988f21d018ebaed05d4a *R/family.positive.R
+df6d8bec5d84002a275c426a9cb2ab3d *R/family.qreg.R
+8c4844e8b09774e6011961a6b035bc8a *R/family.quantal.R
+f2192aaeafe73959410d11f306ec550b *R/family.rcam.R
+6205244d6bca354e9099465175a0c41f *R/family.rcqo.R
+5bf1e3a44ae9b0f3be559fe671fbb5ba *R/family.robust.R
+99676cb382ad33c42d44d99ca6bcf115 *R/family.rrr.R
+e78e92666da7d5ebc729e95f5e27a70a *R/family.survival.R
+9d326d2196256efc4440a38ed9c08915 *R/family.ts.R
+644d480b204af8dab246e33cb3560d7c *R/family.univariate.R
+2a0447d4fffc801c49940f6844c29a8e *R/family.vglm.R
+409ffe41def91bed78e7729b3b42d4ba *R/family.zeroinf.R
+be801764c05394abeb6fa9ef72c004c3 *R/fittedvlm.R
+bf1effc73308ce990f35e166d1afa3e9 *R/formula.vlm.q
+e6753656b1a4eda8de5a01f673f017b8 *R/generic.q
+5aae507d37896f32b306cef3104f67df *R/links.q
+e3e4f2b6154a1e9e5809dd9170a3c08f *R/logLik.vlm.q
+8e771f28093207d25411322a6dfbcf60 *R/model.matrix.vglm.q
+af360ccea29695578291731572c25935 *R/mux.q
+1d68413c98a9b14048e915987e8b6f2b *R/nobs.R
+0cf5cf87340841babab0079f2d0be4f8 *R/plot.vglm.q
+f4f369f39b03bd02949026067385cb68 *R/predict.vgam.q
+9dcabeffa5e38725330428c42c365e3d *R/predict.vglm.q
+4524809f86ca0397363d5084d8c96803 *R/predict.vlm.q
+a98e9c0e9f8d862ef005208719c35ef4 *R/print.vglm.q
+880145f2d76445d0c6aeb324d7411714 *R/print.vlm.q
+e3f7546eae138b8cee983ea0d00a242d *R/qrrvglm.control.q
+4d09fca82a261a6a49a8d47044c33917 *R/qtplot.q
+59647a55c435bec7550c5ed6fda02e35 *R/residuals.vlm.q
+cf6429232a3a89373ec7c63a98f0fb75 *R/rrvglm.R
+7f7d3e3bad38646f5bf9a34c8fb6ab32 *R/rrvglm.control.q
+84e079597b6e18ad2740c6bee1e6f6a8 *R/rrvglm.fit.q
+c5c9f637a7ad26b9a4162a4c6eec99c2 *R/s.q
+169e3c35b99e51037aaa351d1bc1921d *R/s.vam.q
+caf8310bbeb408386ae17254e5bc84f1 *R/smart.R
+c5f98d003fe18794fa1ea199a0f3765d *R/step.vglm.q
+c663f2fa6d27dfe128f95e7f23d3dbec *R/summary.vgam.q
+ffc37c249d39e1553e80903434b0b425 *R/summary.vglm.q
+d3c08c40209f1793ea3f3506f4ecd59e *R/summary.vlm.q
+e75d30e13194b481eee08f6389fdc33a *R/uqo.R
+4ab5232d0b690a132c8c4d13ea5ce945 *R/vgam.R
+fe27c34e65f4ca6e90ad7103918c5830 *R/vgam.control.q
+64d9ca84c782058abb616078435f1bae *R/vgam.fit.q
+4ed0000ef2eb45e49a58eebff882efe6 *R/vgam.match.q
+09a7d574f71c2b432543457c877b8846 *R/vglm.R
+14649525df31aeb0ff40371a10f2af94 *R/vglm.control.q
+361a0ff8019c7f39de8b60e80e593ea0 *R/vglm.fit.q
+21e25b67033e2ff1ff137f3af345af15 *R/vlm.R
+4c6b53a8347f9920b1c83a5a1154f9fa *R/vlm.wfit.q
+324ecf9d8340de85927bf438c77c16d7 *R/vsmooth.spline.q
+464a864c23a9b7f9ea842f9afaad6a38 *R/zzz.R
+113aeab933301f755800d2e8cac8d32f *data/alclevels.rda
+9572e33b0e02dad63ade980ad9c15090 *data/alcoff.rda
+cebebfb94f82451e02607c06a4534c5e *data/auuc.rda
+2148c2429af14dc540b92e593a020edc *data/azprocedure.rda
+9c544fb74250dcdfb544001b04c6efc1 *data/backPain.rda
+57d3964752848e70454460e8eca354e8 *data/backPain.txt.gz
+a2d105f68098112918dd96d07cbcfa43 *data/bminz.txt.gz
+4c681b89033cf4586d992845b6f43217 *data/car.all.rda
+4f5ce642e2f8e717aca6b60a15d7fdbb *data/chestnz.txt.gz
+3cb8bc8e1fc615416f0c8838a50b3f51 *data/coalminers.txt.gz
+9d7140ab7647878741798d566ded66e1 *data/crashbc.rda
+74e92674a14dc48e14f1d92d7b12b930 *data/crashf.rda
+b276773c2ca97585cbd42fc618425d7a *data/crashi.rda
+57cefc814d96653c54ca38fffdb7f0da *data/crashmc.rda
+85be54ceaaea93a106648b0d12fa3d38 *data/crashp.rda
+b5eba07396e4a31c4c1e4f7383c76cd3 *data/crashtr.rda
+08e87bb80a2364697b17ccec6260387c *data/enzyme.txt.gz
+104c9a023954dfdd7ce65b71b81ee459 *data/fibre15.rda
+940778283f82556333c3a8cc61499b5f *data/fibre1dot5.rda
+11765a6627d3f05131c5cffdb0a987bc *data/finney44.rda
+4d4e1c1057c6e58258bf96c01cdc1afd *data/gala.rda
+586cc1b6764d55ecb3798b84218f698e *data/gew.txt.gz
+3a9f7d1fbbebca426a24442cd04107bc *data/hspider.rda
+6a6e83076d85684d065e62399cfa1e40 *data/hued.rda
+815f4936c0ecd60ba86a867338da863a *data/huie.rda
+8881c57a0dc513549828cf967e43e454 *data/hunua.txt.gz
+17d7fbd51b4711afc4752b14a6315d1e *data/huse.rda
+5dc05e8a2a5765055956e0abc58f5fff *data/leukemia.rda
+aba4885e0eeda8ee887a422fee01e02a *data/lirat.txt.gz
+78e35e9862a43ff31579fe7ed29e1be3 *data/mmt.rda
+0f45f6779a3c3583f4edf68da4045509 *data/nzc.txt.gz
+5b88c319b7cc110298ccccbd20f1f63a *data/nzmarital.rda
+1017612628ed904e97e5a426d307b16f *data/olympic.txt.gz
+3ed63397c4a34f3233326ade6cfd1279 *data/oxtemp.txt.gz
+7da3f7ba49a190a68539c3bb248dc7de *data/pneumo.rda
+a154338a23054326f3afac21214c5dce *data/rainfall.rda
+742019771657a52118284311b2bb8aa1 *data/ruge.rda
+a36796d60ad14f05024e2d84495004fa *data/toxop.rda
+26a13fd8ccb944b5c7ddff43115a4db5 *data/ugss.rda
+bdd6a67f4910e8de546093d063e3bceb *data/uscrime.rda
+e44a36175f75fcbf6a3e7c51a2b5f9ec *data/usgrain.txt.gz
+4c353f323c41f4a1b73be98d5bf52494 *data/venice.rda
+5469e732f315a221cb79fb0091ce6b52 *data/venice90.rda
+728a2da997645be1c6eb332be92e850a *data/waitakere.txt.gz
+7ae69687f10e102feeb9e04fb1d93d29 *data/wffc.indiv.rda
+51e5e4667d5ef260e254944faa9d6540 *data/wffc.nc.rda
+c5f27c15f26deaaa8234b2fa9137e4df *data/wffc.rda
+5bf80f6fd179f687948f6faafabbfb8d *data/wffc.teams.rda
+81f7f0844a196dc48e91870c4cfafc99 *demo/00Index
+532aba4ad4cac611141491a5bb886236 *demo/binom2.or.R
+a7db0d0c4cc964b01ddbe0cb74153304 *demo/cqo.R
+6376ee1862c11e847aab6f7f6fd74d24 *demo/distributions.R
+d2c02ccaf4d548cc83b3148e55ff0fa3 *demo/lmsqreg.R
+a3d2728927fc5a3090f8f4ae9af19e1a *demo/vgam.R
+00eee385e1a5c716a6f37797c3b4bec5 *demo/zipoisson.R
+45d6563f929e021db90f9c0289e6093e *inst/CITATION
+466027c0c99178bb6e695d9439fd6829 *inst/doc/categoricalVGAM.Rnw
+32351bc765fab29b9018c69d9dca22b8 *inst/doc/categoricalVGAM.pdf
+e4c5415e487f533b70695b17e40d97bc *inst/doc/categoricalVGAMbib.bib
+92e903f33d4067a7fbc89fa4e7571c92 *inst/doc/jss.bst
+c98d257f9bdb7cca3a1dc6306ede5d77 *inst/doc/jss.cls
+ae4c252ab1ff7ea5097b50925524c6c8 *man/AA.Aa.aa.Rd
+6e6488fe17bda74157417f38f7d63df1 *man/AB.Ab.aB.ab.Rd
+426224676fcf86a274ee40a1e897ff51 *man/AB.Ab.aB.ab2.Rd
+f39858c0426842ecf98e71fce7dae258 *man/ABO.Rd
+e205077baf82273656dade8e39dfd0f0 *man/AICvlm.Rd
+0c05d0d66ab909a5a7916f89004b8316 *man/BratUC.Rd
+4c634c4ac3a9673b49e00a21a5edcac0 *man/Coef.Rd
+42eae1271b8c7f35a723eec2221a21f2 *man/Coef.qrrvglm-class.Rd
+b00890f6b16bb85829fcea8e429045b9 *man/Coef.qrrvglm.Rd
+7750539b34da20b20c40be62371fbc68 *man/Coef.rrvglm-class.Rd
+5bff76cdc1894e593aa8d69a6426b0b3 *man/Coef.rrvglm.Rd
+02efc2828e76eac595695059463d1d47 *man/Coef.vlm.Rd
+75b836cf0732d7eb2ab70aab73958cf8 *man/CommonVGAMffArguments.Rd
+310947086394afe4710940e6b5f2a20f *man/DagumUC.Rd
+4c84f8608e7e5a2a69fbb22198aadf95 *man/DeLury.Rd
+ce9fbf6bdfba2dd4b29264c4b91a9ed2 *man/FiskUC.Rd
+2243f6f66449d96a9c370d9cb118bc85 *man/G1G2G3.Rd
+08653494776ff33b9055399d1cfd36c7 *man/Inv.gaussian.Rd
+d603c4299f106fdb46fbea981204fe29 *man/InvlomaxUC.Rd
+a009627453d19f5eaf6ae71f4f0b1050 *man/InvparalogisticUC.Rd
+40f8887a9e6322c1bea8ce385468c991 *man/Links.Rd
+61d800c277d36cbae33d37f44f3b6678 *man/LomaxUC.Rd
+0204cf1e24403cbd66194f76dc3f1040 *man/MNSs.Rd
+86a807027a2ed716e89276800c8714be *man/Max.Rd
+2e0f16626b262cb24ca839f7313e8fb9 *man/Opt.Rd
+33f08c2321eba55fbfe58b3020c2b28a *man/ParalogisticUC.Rd
+a0c448aa48678a37e4fc983bb532d141 *man/Pareto.Rd
+b89db00a67be3a3aaa3095f3174e831d *man/ParetoIVUC.Rd
+75fad694be2767a5375d9be5be022ad7 *man/Qvar.Rd
+eeb74d98864573758cfe36ba13ef6ef1 *man/RayleighUC.Rd
+0404984840078254ed64e04618bf56ca *man/Rcam.Rd
+f379038af8e484391f0f928a1857b3a1 *man/SinmadUC.Rd
+c81b93652782bea87a01f828300930f7 *man/SurvS4-class.Rd
+aa35103aecf13d0119e5a1a17f5ae57e *man/SurvS4.Rd
+56b6bf93ed5da4c3e8324758bfde36aa *man/Tol.Rd
+8647246f41c25c8de6e9812dbcdffe9a *man/VGAM-package.Rd
+a092ccdd940f1f911845d1e4e7ca8f2e *man/acat.Rd
+d48a96cc10227d71c1f911d4ab2e1f4e *man/alaplace3.Rd
+0faf4d7fdfb9526dec05f6ff87680b90 *man/alaplaceUC.Rd
+fc94162782c395640db18e1ff7c6ebb5 *man/amh.Rd
+df8c8413b03b440d0451f50d92321e0f *man/amhUC.Rd
+73bb3963d43fd465ff2dd6afdb5473d1 *man/amlbinomial.Rd
+bc2496ef5c112b9d663b1fc90a1c493b *man/amlexponential.Rd
+da42748b4b58104ffb2fe8cfad711dab *man/amlnormal.Rd
+2c2e41401482c0d156dd568480888925 *man/amlpoisson.Rd
+ba175111a99a5dd998a544b32e3390d4 *man/auuc.Rd
+37adc3f8e2804c880143a06e475bfd81 *man/backPain.Rd
+ae939e9f4844d1a74c34f1792f4d6624 *man/benfUC.Rd
+fb0dbdc1e60369a7a29fc5d379e8b629 *man/benini.Rd
+48d7a80011c803267396d4ad49424371 *man/beniniUC.Rd
+29172adb77fdc0148c50b6beed8a04dd *man/beta.ab.Rd
+b75d0112b0fd70acb58720daf5dc8e7e *man/betaII.Rd
+41820caae54231fdfe4f43c64c8b2aa6 *man/betabinomUC.Rd
+1600b3f2a75c6a60546d1d01523b1b98 *man/betabinomial.Rd
+8f5474206d55a6a2d6f770b6fd97d9d8 *man/betabinomial.ab.Rd
+4f1141b7ef59dcfb3c52d96cb41e44df *man/betaff.Rd
+da3fdbf88efd6225c08377a461e45c50 *man/betageomUC.Rd
+8c75be04378f771189e287d9ec77ee71 *man/betageometric.Rd
+f2729cad5024784c73e0d9fa6aaef394 *man/betanormUC.Rd
+9065dcf96fd6b05e60189a5d5a5ee551 *man/betaprime.Rd
+7adaeed3dae23da1a0cc5eb9358d4597 *man/bilogis4UC.Rd
+a4113bec799465dd87db6c2afacb855e *man/bilogistic4.Rd
+1b1505b19650baa2ce76fb08a24a628f *man/binom2.or.Rd
+e4d7d902c5c17c65f48b0eb17cd14cd9 *man/binom2.orUC.Rd
+bb62a8e00f036e4c1ffd7b6c24793d78 *man/binom2.rho.Rd
+0a679878123b41e3eb8f7ec074c83dd9 *man/binom2.rhoUC.Rd
+abd7367e55b62d594509ac626ba251ec *man/binomialff.Rd
+461ddeea757c9690113126296c2fac55 *man/binormal.Rd
+bdad9ecfb116c4f30f930bcaf7208735 *man/biplot-methods.Rd
+3de6128c31694785566e9212b2f63999 *man/bisa.Rd
+903c040af10a99cda997fc5a11402bfa *man/bisaUC.Rd
+4cb6cae438d1f9080373569ab44f3d4a *man/bivgamma.mckay.Rd
+65de692084ada2bcc2f8ad8665033a82 *man/bminz.Rd
+ca0505aeb6143228b5ce142954ed3ba7 *man/borel.tanner.Rd
+adc7dfd546ab8430e0806c3b965c4366 *man/bortUC.Rd
+ad622827843632a0af3c9da51effbe6d *man/brat.Rd
+0e4c602335596525d01e46d2613af724 *man/bratt.Rd
+f640961a0c1a206ce052a54bb7b4ca34 *man/calibrate-methods.Rd
+702754aad58a33aba1594bc7d2d45acf *man/calibrate.Rd
+a29c9de0df75b544fb778651fee7ca12 *man/calibrate.qrrvglm.Rd
+8c7794b8727f1a0b7220b1bf5001a1bb *man/calibrate.qrrvglm.control.Rd
+7308576228b41ce02ac3b9f61c8f9f6e *man/cao.Rd
+f15b81668cd82879e8f00897fb30eea9 *man/cao.control.Rd
+d42538f50f7b5ce49b81b59403485955 *man/cardUC.Rd
+8a2a5e9dfece6f88bc99a4c36cf59457 *man/cardioid.Rd
+56bacf0502ac46e8929d6a8afcef50cf *man/cauchit.Rd
+e7b9c33bacc1d02d937453ab6ef7234a *man/cauchy.Rd
+2ab80616c05e7aebdcf769c35316eab1 *man/ccoef-methods.Rd
+8805fcc3975bce184bc92154da60bc6e *man/ccoef.Rd
+d30a5b6b43969dd631c7a45fadc1047e *man/cdf.lmscreg.Rd
+736c151641c47418c5641e4b50f72326 *man/cennormal1.Rd
+b0c254854e201fd1185b233ff0645ff8 *man/cenpoisson.Rd
+f6c605b4eed73b77cd5a3d90098632be *man/cgo.Rd
+42cc5374d9f2d1fa077cabf5cb18cea2 *man/cgumbel.Rd
+594d372f4d9072817a9ea3ab4a0f14ad *man/chestnz.Rd
+92b1bbec2b9554215c23402cbd03ca04 *man/chisq.Rd
+8ecbb478efcf4b0184a994182b5b2b94 *man/clo.Rd
+1e216ef8b7c72364a0e8d5d28a190fd2 *man/cloglog.Rd
+1aa6ee888bb532eef1f232c9f6a02b5d *man/coalminers.Rd
+c34d8e18e49ac22df6e9e9e0d59ca2a1 *man/constraints.Rd
+8d7c0956439111786d43b7b161f9cf5f *man/cqo.Rd
+4b6e07b4fe4a71094c99e824f5b3cd91 *man/crashes.Rd
+5c964fdf03906470eaddbbf3d39076ef *man/cratio.Rd
+066cfa56e6c030510d3a67e260fab32f *man/cumulative.Rd
+8e9284c16776ee6767344f3e94c40339 *man/dagum.Rd
+1f1a2e048bcc0061b8aa5f0d7fcb600b *man/dcennormal1.Rd
+cc0da9d5746513c788561a7e0a9ce8ab *man/deplot.lmscreg.Rd
+7f57d255543bc7d13dadf322805c99c0 *man/depvar.Rd
+40a6d820457d0015ca60fe3a752ca80d *man/dexpbinomial.Rd
+1bfcb86a014b0b758f50d132bd885679 *man/dirichlet.Rd
+47abfbb23c120dd2611c990f1a82b72f *man/dirmul.old.Rd
+56435343450179e964797e28af0437e6 *man/dirmultinomial.Rd
+f2e9b9b0c0aeb41d83fa5e689076fa91 *man/eexpUC.Rd
+fe902b6457a11d51c758018d9dad7682 *man/enormUC.Rd
+2ad791294f4220bacdd9dc1e07fb2e94 *man/enzyme.Rd
+fb32261e27bdbbf3719163d4981742ba *man/erf.Rd
+7a52af5919ffbe4f6491df743fd54d28 *man/erlang.Rd
+d8d6acd92c165383419aab1005d77ea4 *man/eunifUC.Rd
+a755d061d59cc71b7aeb44e7b224976c *man/expexp.Rd
+8a3dffebc0871a56f7dc9f9f3bcfd60e *man/expexp1.Rd
+f8ea6ce8d6fd230e8dcb593d09b50140 *man/expgeometric.Rd
+bba52379a93d8f2e909b579215811554 *man/expgeometricUC.Rd
+33ac709e79e8cac15aa1e7eda4f74bd1 *man/explink.Rd
+0c5cc8525c38f3ffb7bc8f880fe04a7e *man/explogarithmic.Rd
+347d45279f0e72bc8c2dab25ace2f28c *man/explogarithmicUC.Rd
+5cda1f3c70b2f647037c1ee4302efd63 *man/exponential.Rd
+f73ce79537efaf892331a48daa47927c *man/exppoisson.Rd
+8e5ff25491af9631e681241ed305bf94 *man/exppoissonUC.Rd
+737c92f56c01d46e0219fcba779987fc *man/felix.Rd
+842a3ba37b78b88f1e726338dc883d85 *man/felixUC.Rd
+e89421f88d21f4867aec746c47b5e804 *man/fff.Rd
+73cf4977cf0b692b1de42c32a343d525 *man/fgm.Rd
+6b1e2a1c3b0ec43e6b396f4f22097e35 *man/fgmUC.Rd
+0f91dd411c054004631a677eda63db79 *man/fill.Rd
+b929e2ab670eb59700bc4a1db07bbbc0 *man/finney44.Rd
+2a71cba3122f180deefc7eac6fd9500f *man/fisherz.Rd
+5d993e74b612f3c22698bec281201cc0 *man/fisk.Rd
+88f722aee35485da126d801c71b8aee1 *man/fittedvlm.Rd
+f0dd850a571209fb251db51db2b3d9a7 *man/fnormUC.Rd
+619e4551f1f29af1cd2e80db5d5eb98c *man/fnormal1.Rd
+18c339da4093664d14febbcf02f3a2b6 *man/frank.Rd
+cdfcf8fb1eb1799a197dd90a5a245d9c *man/frankUC.Rd
+46f42985d5d6ba06ee337803eb8f6570 *man/frechet.Rd
+f3cca03b14f8a766483fb52c1624514c *man/frechetUC.Rd
+a064b35aec006934e5667bdbbedd1b97 *man/freund61.Rd
+bc47c6ee3e74df598d758b5e16abac90 *man/fsqrt.Rd
+13cc0e1a0a95d020031deddecb4af563 *man/gamma1.Rd
+152972ee5cd8c6d903ea1faba8d2b207 *man/gamma2.Rd
+bc93b6e6e71256cee791e31125b0b1e7 *man/gamma2.ab.Rd
+cf2ba12145a4e1626df9585d8fc72987 *man/gammahyp.Rd
+e7c54cc18a759b213837ecaa38f9fcda *man/garma.Rd
+dbdc01466b43ed8302f46b2a63da17bb *man/gaussianff.Rd
+cf30751ebb774891747aa4ece03f25d1 *man/genbetaII.Rd
+e0441f26e110e94aa55d835ea5c1019a *man/gengamma.Rd
+bd63e15c3ac9ad8a8213d4cdc8bb3440 *man/gengammaUC.Rd
+af2ae222bb2540c889277c64f3d331b8 *man/genpoisson.Rd
+f626c2b3188a5755dc93112aa3bcbcf5 *man/genrayleigh.Rd
+c31e093e7b6e5a4a7959ba6404b85a23 *man/genrayleighUC.Rd
+b4584d10b2359e4b087c54bc22cafad6 *man/geometric.Rd
+78b7d9455f1eaa4572ff54427d77935f *man/get.smart.Rd
+14a7e2eca6a27884e1673bd908df11e1 *man/get.smart.prediction.Rd
+48676987a2581858d5b2992385d29134 *man/gev.Rd
+564d66518a6ec5d2a303e16814266d8c *man/gevUC.Rd
+690b69d50e92a781720cc547dd22c3b4 *man/gew.Rd
+ce9bfef334079c13a62f95162513d6ec *man/golf.Rd
+823e37f882dbbe96d43edec25addd2ce *man/gpd.Rd
+05ffba31706bba09ffb7a1d7a18e1a4e *man/gpdUC.Rd
+406afb4b18ca9f3b239f5419f2e6a59c *man/grc.Rd
+63d054be8dbae4bf35a7b9b6992627e5 *man/gumbel.Rd
+d7c9a4c5322e34a0c0173c89bd1829fa *man/gumbelIbiv.Rd
+65c9eaecf95125e461b5fdf589d01497 *man/gumbelUC.Rd
+d60aa16831b87c86aaa5648b6c4afc76 *man/guplot.Rd
+00b132289191052ac14659de9ab936fc *man/hspider.Rd
+b5224b8a3e3ed7eae77129374e17c95c *man/huber.Rd
+bbd60b4a3ab257638df3ca1d0e99df63 *man/huberUC.Rd
+bb9248061e4bcf80a1f239192629dd44 *man/hued.Rd
+7233194700e1afd90475317e4a23c831 *man/huggins91.Rd
+247e7d8e05b06904ee14cdee0c897d42 *man/huggins91UC.Rd
+d44f3df87816b5cf0f1ef98315300456 *man/huie.Rd
+3cb4fc1b3a7f1a6bcf7822219ac25525 *man/hunua.Rd
+08383189cb05fe01a3c8a5fa2e2c78c5 *man/huse.Rd
+e52bc61525d8bb31785915c0e42cf2f6 *man/hyperg.Rd
+f134ace4dd0689809500d58933cff6dc *man/hypersecant.Rd
+8d18339270dbc32b70c105c3500eb412 *man/hzeta.Rd
+59b384e572f60dce3ea6b74d12455561 *man/hzetaUC.Rd
+d41f639aadc6abd8759824d1e7516083 *man/iam.Rd
+7266e5dba641098cd882cb62a8e33244 *man/identity.Rd
+070efd951fc6152397cb15634788059f *man/inv.gaussianff.Rd
+941470d5ff5e3a83089d1ec1af026f35 *man/invbinomial.Rd
+81940e20ea38f0ae4ab6277edcaf42e5 *man/invlomax.Rd
+da26800b94821aa6582a183ac62bf2f1 *man/invparalogistic.Rd
+a286dd7874899803d31aa0a72aad64f2 *man/is.smart.Rd
+2e3e9b010e6c48ebc38720fe7a1d88fc *man/koenker.Rd
+8fe841741b94002d204ba682bde54c8a *man/koenkerUC.Rd
+27b379846522a3e3229ff6aefa3c6791 *man/kumar.Rd
+df631f857d415cdf7ae3a39e05a230ab *man/kumarUC.Rd
+b103b755b50474935e8da3874d923792 *man/lambertW.Rd
+59c33ab57e8c8cfbd29de2af8a14c8d6 *man/laplace.Rd
+b8f463b8e776f6a1f604bc5da92aca37 *man/laplaceUC.Rd
+ed0afe39738f1712b3981c3618c4f913 *man/leipnik.Rd
+2fd907a10ab430f8a2e2172bbe8cdec2 *man/lerch.Rd
+208f4d3827953d3195c4cedd95b9c95c *man/leukemia.Rd
+5c8c39fee1abf69282ea305ef6140a30 *man/levy.Rd
+24240b2f56289e1a3240dafd78d6212a *man/lgammaUC.Rd
+2b04a3472ef0fdcdea239dd3b3efa293 *man/lgammaff.Rd
+7fec5c64cf46a14b918a919590025ac6 *man/lino.Rd
+2ef824a6f01bef38ed0076a1015fae79 *man/linoUC.Rd
+c347f3d3752c3dcf7d9b614b3f62be6f *man/lirat.Rd
+c3dbc9895942144e600b7f7b8537bd56 *man/lms.bcg.Rd
+52d7b11419756062c68465f23adab1ba *man/lms.bcn.Rd
+04c44739582d71d4d6b8ca526c36a104 *man/lms.yjn.Rd
+ee69ac28aaab7887c656b857af21ffd2 *man/logUC.Rd
+c362d03bf3e2c4c24f8e0f46af093a09 *man/logc.Rd
+2207f5080987b6271d61e9bffae6d427 *man/loge.Rd
+e5c36efa7e692fd32de85fd9c4a347db *man/logff.Rd
+c06a10d369d8e25373a53df73436c812 *man/logistic.Rd
+117884ae7e831a397caedf145a434c28 *man/logit.Rd
+1da3783f1662d799690fdd081f721ee0 *man/loglapUC.Rd
+9b7259abd4c44c955e9ebe9e9087f2e1 *man/loglaplace.Rd
+8232a213dfc8899703f6e57664efae69 *man/loglinb2.Rd
+dcbd827fd3586f46fc4ca1a1495a9ea1 *man/loglinb3.Rd
+aea6b2adf7ffd43d5659d238c9729713 *man/loglog.Rd
+c765fec35de8b6822c02d3b41a75a7dc *man/lognormal.Rd
+aad78245c7c13be5d22efbff8774adf8 *man/logoff.Rd
+5910ef0e4b1c84786a0a3fffe647aafd *man/lomax.Rd
+138808d36f9fb37444e28e0d2c426dd1 *man/lqnorm.Rd
+8b21946b3c21a74d758e4b18117c0000 *man/lv.Rd
+528f457d3ec33f6264ccf05670fac457 *man/lvplot.Rd
+af30767e3ab7bfb0bc809409d7f39e84 *man/lvplot.qrrvglm.Rd
+15d57ef2c0a922cef23f2d25cda5c3cc *man/lvplot.rrvglm.Rd
+8ddc307ce88b445463ca45bd66e1c967 *man/margeff.Rd
+15d5967068a26cbb6072ee9ded149076 *man/maxwell.Rd
+d57adc38eda1d2e55e38796d24aa38a9 *man/maxwellUC.Rd
+6605f4601c5ef2733771cba7a061556f *man/mbinomial.Rd
+cc1c4f080d0a30059d52ed93b9a3090c *man/mccullagh89.Rd
+4d8d0f37dc8249d00e52283764534e98 *man/meplot.Rd
+3660487df3e8da3023fa94195c717e06 *man/micmen.Rd
+aef1a3568d58fb50c01c0be1ebd44720 *man/mix2exp.Rd
+56639277cd56ffbb1840473640e5e95b *man/mix2normal1.Rd
+4aaae69710cd08f08bb7ce432cf2108d *man/mix2poisson.Rd
+1d7e090a54f5524e6fe0711bb942be47 *man/model.framevlm.Rd
+0db10fd10f2e69997d9fe9242aea3c7d *man/model.matrixvlm.Rd
+febba2e46a2084aff84e8c76a388e400 *man/moffset.Rd
+e4bf75856828a8a128c9a95a663f2b6a *man/morgenstern.Rd
+b820e9ada80b37d5ab7ec410da992489 *man/multinomial.Rd
+29ce3642cdb940b4bdbba7f6173a6a60 *man/nakagami.Rd
+d87f98ccf030b9925fa27475890cd27e *man/nakagamiUC.Rd
+b22f922cf137d6ea4280bffc9551c733 *man/nbolf.Rd
+01598cf15d4f6301379a48aab34f99bc *man/negbinomial.Rd
+23eab49179dff394f6f7ea0e84d3bfa2 *man/normal1.Rd
+b1f3913fd20911c2e808c76f0ec3debd *man/notdocumentedyet.Rd
+a300b58d732cd75ac5879a434d7ee8d8 *man/nzc.Rd
+f284459968787cf71ed152683e1acd7d *man/nzmarital.Rd
+129d6f1bea94c96636e58707916d28c7 *man/olympic.Rd
+fd8cdb48779a490071c91054c8b5ba33 *man/ordpoisson.Rd
+9ecbe9ab6cc7d40f41f10a71fdae5996 *man/oxtemp.Rd
+e1156bbc8f962d2849c56028e2430151 *man/paralogistic.Rd
+721fd4000631dec85c2f7164bfaf2e3e *man/pareto1.Rd
+f9511e9a7a3bb97e4ca6c6ed080d40ad *man/paretoIV.Rd
+66f9463188664956ca69d58bd11a0e51 *man/persp.qrrvglm.Rd
+53a43e65f00420564ad783888f356ff7 *man/plackUC.Rd
+c542d660e94860e165d2945a855eae24 *man/plackett.Rd
+147b571a4d86267b1e5a6c1ad84ee5b0 *man/plotdeplot.lmscreg.Rd
+768d300d2a478398c5a77549922caa97 *man/plotqrrvglm.Rd
+e5609405022b247366503d18f15c6df6 *man/plotqtplot.lmscreg.Rd
+9ae405fd77c85cab2a55f92664b1cc67 *man/plotrcam0.Rd
+96080febe9dd3644878ba14042913990 *man/plotvgam.Rd
+fb44d2ea3a4da3e63336746e7ae5affd *man/plotvgam.control.Rd
+aa55e676b3fd0fab0f1aee26ab9fa6de *man/pneumo.Rd
+de61bd1899e2bd101d3977d2e25f163f *man/poissonff.Rd
+aea0d6dabf75a88fc5bbf4cf77fef7ec *man/poissonp.Rd
+270ec562dcf4fd2a48221453d110c3eb *man/polf.Rd
+a2fb4efb4037aaa2362579d73e78defa *man/polonoUC.Rd
+0d1147afa73af7ae0860f36d2d7732f3 *man/posbinomUC.Rd
+67c1153ac99b572401e73d68f665b2ab *man/posbinomial.Rd
+76788187cad5a084cb5ad798b934bd07 *man/posnegbinUC.Rd
+83ad8c3435e907ecaa98615c6f1e18ad *man/posnegbinomial.Rd
+0e2ea2f46537b34ccc6603fe56303983 *man/posnormUC.Rd
+c4f9abd34a4cd9ea5b8a6fc3b88abd83 *man/posnormal1.Rd
+e7baad18a3f2c0df245687ff2e74413b *man/pospoisUC.Rd
+0f588e778a0c38a98841da257cecd4eb *man/pospoisson.Rd
+95386d432e396127192e5516a35059cd *man/powl.Rd
+f5ca83cbbe57ce6a7e98a0318ddc6aac *man/predictqrrvglm.Rd
+10003ea86273bd156fdbd6990c5f80d5 *man/predictvglm.Rd
+d2b5e03b84a6c8b6ba9553155445c694 *man/prentice74.Rd
+b0913ae27b2f0ab1e032bf3398a78d5a *man/probit.Rd
+1c6818a129a544e770b0dc1d9e6c0ee7 *man/propodds.Rd
+dc7a643eba4c2ac7bbd842ed27eb1023 *man/prplot.Rd
+de570e252375d7052edaa7fb175f67eb *man/put.smart.Rd
+b3d7003f58379c80407662707543ca80 *man/qrrvglm.control.Rd
+e5ac6fc23dfa77497bbfe05831e5ea33 *man/qtplot.gumbel.Rd
+7fba3114d68b669c490cb599000f4824 *man/qtplot.lmscreg.Rd
+64dceb3461595b09595b483f72ac8b42 *man/quasibinomialff.Rd
+85d05c50101b02eb35a1e31d75226c05 *man/quasipoissonff.Rd
+013fb5594d2df84c9fc9aad2dd822070 *man/rayleigh.Rd
+03fb6a7f9cfc570ad5fd1bc59accc905 *man/rcqo.Rd
+215e0a6f6611334b2b9ed8a35595227b *man/rdiric.Rd
+ac9770dd82570248526fcc6fc5736e9a *man/recexp1.Rd
+b482b0fef9752983d7f39154c006d7d2 *man/reciprocal.Rd
+5801e4142fa8b2f82ee50cbbf51d6955 *man/recnormal1.Rd
+38b36bb14ee58c0f6441f59700842cf8 *man/rhobit.Rd
+c4d52486cd29a6b05426ece0496dbf0c *man/riceUC.Rd
+a80124978dea921b2b0f8f5ac7187bf2 *man/riceff.Rd
+211f962003276a0a032c94b847bfc426 *man/rig.Rd
+28a7ee11dedcd60712d830cc36f8c208 *man/rlplot.egev.Rd
+577b7fa7b66f8afb57c0b0df0283eeef *man/rrar.Rd
+ed93c6e06d519ab3ddb92c73cf62bb67 *man/rrvglm-class.Rd
+2fa5b2b99f0383911d84ce0d6db9a7d1 *man/rrvglm.Rd
+a5a699bccdf3768b9bc425b410d4328a *man/rrvglm.control.Rd
+aacdffc764ae399ea515751128ff32fb *man/rrvglm.optim.control.Rd
+b5936590eb374807b15d3d6f10257496 *man/ruge.Rd
+1aa08eedd0a60614932bf6916e600e9d *man/s.Rd
+225c2d43e9c5143d0e6e0fab79a22439 *man/seq2binomial.Rd
+71367fe3b494a45c98f9a96e1fd791e0 *man/setup.smart.Rd
+fa349f195a44efe47ba19726c6d96725 *man/simplex.Rd
+0b224135695156ba53178b78ba64690d *man/simplexUC.Rd
+61a0378592df48624dcd63630d6eddeb *man/sinmad.Rd
+6e0c8526ef9dc5b8088eacec6d611448 *man/skellam.Rd
+3b158a36468b4e9cb6ac33c6ecb7e59a *man/skellamUC.Rd
+878eb152f75438a8c6d55ae6f56f938e *man/skewnormal1.Rd
+9aef1e982d65a1ae4b5a993a54b60f7e *man/slash.Rd
+0fbb31668407aa16241824e2c17339a7 *man/slashUC.Rd
+1ed10e28c013e2e08ac5f053b2454714 *man/smart.expression.Rd
+163cdb3e4a225aceee82e2d19488d56e *man/smart.mode.is.Rd
+2b68a9e20182e8892bb7be344e58e997 *man/smartpred.Rd
+bd869816cc0a7a1af02285c8ff7b6fbc *man/snormUC.Rd
+930706a4ce59b848dd733a0944ca41dc *man/sratio.Rd
+6842d2562b09bd347aeb9e7cdb55f11e *man/studentt.Rd
+5585a51bdfb69f8366df3eb46b950885 *man/tikuv.Rd
+da0473cfe60820a64e74d4e2d7492927 *man/tikuvUC.Rd
+f11402d98706790ede99940cb03aaccd *man/tobit.Rd
+dec960a58993b1941f7f0507673a951b *man/tobitUC.Rd
+deefc3b0d1473924687acdb454b77c01 *man/toxop.Rd
+72d33bd9b49016adbe4b08d070ed2c1b *man/tparetoUC.Rd
+d656850a7fba6056bfcaf07a00510110 *man/triangle.Rd
+8c327c816d9d56403d617a32fa704e9d *man/triangleUC.Rd
+8fb0fbd98a56b1afced6cdceabea5c34 *man/trplot.Rd
+7f445b5722387e9458fd3ae83d54c852 *man/trplot.qrrvglm.Rd
+e589c53551f1b4939087e30738b4a52d *man/ugss.Rd
+165ffd320bf19a0d01fb88fd08405f5c *man/undocumented-methods.Rd
+1d2b4be48c8c99493c17f02fc0de7d04 *man/uqo.Rd
+6ee6dce1a0ce56b637caba0e80cb668b *man/uqo.control.Rd
+7e75f1629f7611bba758f8aa0dfc0894 *man/uscrime.Rd
+795c20aae2ad322727b8054ec92c7962 *man/usgrain.Rd
+986f3ae218b563bae795b67131082609 *man/venice.Rd
+6e4d3e5ae033e23124555b0a90337a5d *man/vgam-class.Rd
+fa381a9ae340781ff17f568787e1a6c7 *man/vgam.Rd
+2b53772dc12e8c7eee53122cf264c76b *man/vgam.control.Rd
+b2bdeb9d2a6e9c2e7b8964d334b4378e *man/vglm-class.Rd
+82d8478a4295bbac3da6402c06101fc7 *man/vglm.Rd
+71ba57518236ae3d52e7a13c4539f808 *man/vglm.control.Rd
+d7e7f317461e888a57ee1082db178328 *man/vglmff-class.Rd
+f3904d70f23d42160da9afb7fc66b86e *man/vonmises.Rd
+060df7afe140d1ef3b498e1492a9c1bb *man/vsmooth.spline.Rd
+969885cabc2f70c78def5cef9621a648 *man/waitakere.Rd
+0a974f438d1c92859d87f28896768b29 *man/wald.Rd
+9370cf7a77f1112b1f0080ccdc9d1bf3 *man/weibull.Rd
+57ad5859e60dda64aaf0420cf457a8c6 *man/weightsvglm.Rd
+f8652276dedb724f7baf7234f37ad2cc *man/wffc.P2star.Rd
+f188fe990a99ec6a88e15e3ae69f1b01 *man/wffc.Rd
+ae1ea0d10cfc8cbdee70a460c590c823 *man/wffc.indiv.Rd
+ce03a749bcb5428662ac78b85bd6f08d *man/wffc.nc.Rd
+664d89e742974a4be71a459a68bbfc80 *man/wffc.teams.Rd
+655258cff21a67e1549b204ff3d451a5 *man/wrapup.smart.Rd
+18bd4b883004bccce4c1d1c5d80bff98 *man/yeo.johnson.Rd
+5db544b3c6404442bab4998b60fa6d64 *man/yip88.Rd
+8e94dc10a59629c0f9147f940a371a84 *man/yulesimon.Rd
+1475d89bd0a33754d7f91bafdd340299 *man/yulesimonUC.Rd
+f71996b89b9a762a5d206b8e44c8cf62 *man/zanegbinUC.Rd
+24e0f645feccbe9bbb98ffb409365ca7 *man/zanegbinomial.Rd
+be7b555df408a51019b24cff72871c4b *man/zapoisUC.Rd
+627fb3b2893f16fb52836f90f8712f93 *man/zapoisson.Rd
+7d566ab0865ba24b4b4b0c418c15890e *man/zero.Rd
+4e19a9181d3ce167b113abb5712489bb *man/zeta.Rd
+e0ef189ae8251b5e0d20b614c18cdd5a *man/zetaUC.Rd
+41b60aab45c01599e769a721da58ea86 *man/zetaff.Rd
+2afab46d583941a8be8f28ce90195d15 *man/zibinomUC.Rd
+fb0f01a8b40d4730ff0412f8fb198877 *man/zibinomial.Rd
+27dc243f70b76c931785951815025572 *man/zigeomUC.Rd
+0853776b9cfac2d08d028b483a3b3454 *man/zigeometric.Rd
+7161b2bf6ae08370e59dcb38157d1ae4 *man/zinegbinUC.Rd
+3b1d5fe4b2db4e320c726128c046d5ff *man/zinegbinomial.Rd
+8548bc081e80aa464b3a4ffbf0a043f7 *man/zipebcom.Rd
+b181bd431ec865366e2db643fbc8b8f4 *man/zipf.Rd
+84b96ae71fbc091562e27a5997446aa5 *man/zipfUC.Rd
+101696ce832be47b90fa13da220201d3 *man/zipoisUC.Rd
+9695a2ec8214a7196d2676cf48765859 *man/zipoisson.Rd
+ad08497921fd341e2853254f9528bff4 *src/caqo3.c
+69d2fd2a25229e368e8cf93ed005f14f *src/fgam.f
+ee68626f9fa7da088c9401345c937dd3 *src/gautr.c
+dc1ca5b4e9a67b6d48c25e7107112d9c *src/lerchphi.c
+f15cb40ff05ab0763a62af4756b711f7 *src/lms.f
+fd2be53f9058e9eaf6fe9271f9fcf440 *src/muxr.c
+6f2d68edb270dca177d290a0d62992fd *src/rgam.f
+97981ee3cd3bd77d69e3bacf9ecae231 *src/rgam3.c
+10939d9fb380d54da716a835d37fdf75 *src/tyeepolygamma3.c
+5d14c85e6eda8c2d1a3219a2aa3c708a *src/vcall2.f
+3e145d8721d17dbd0e642508c2de1472 *src/veigen.f
+91fd839e31da38b116c09ef24a3c25d0 *src/vgam.f
+32ba54d93eea2e514468d0c08431b185 *src/vgam3.c
+bccf9d58334e1fde641a6d59443cd915 *src/vlinpack1.f
+fe604895e0e9c3314f9d29378d1d0ed1 *src/vlinpack2.f
+a7625ebca9616112544d1e8155a5922a *src/vlinpack3.f
+93bbb9483bd82b692febd98c0cf10a6d *src/vmux.f
+b1a1e8d940090e51d25fa9c08fdc6a08 *src/vmux3.c
+d5c3783cc318a8e1c0b7aafcf5849dee *src/zeta3.c
diff --git a/NAMESPACE b/NAMESPACE
index 0bcb942..53d8b4a 100644
--- a/NAMESPACE
+++ b/NAMESPACE
@@ -15,6 +15,11 @@ useDynLib(VGAM)
+export(nvar, nvar.vlm, nvar.vgam, nvar.rrvglm, nvar.qrrvglm, nvar.cao, nvar.rcam)
+export( nobs.vlm)
+
+
+
export(confint_rrnb, confint_nb1)
export(vcovrrvglm)
@@ -52,7 +57,14 @@ explogarithmic, dexplog, pexplog, qexplog, rexplog)
export(Rcam, plotrcam0,
rcam, summaryrcam)
export(moffset)
+export(plotqvar,Qvar)
+export(depvar,depvar.vlm)
+
+
+
+
+export(put.caption)
@@ -87,6 +99,7 @@ export( bs, ns, scale.default, poly )
export(iam,
fill, fill1, fill2, fill3,
+abbott,
amh, damh, pamh, ramh,
bivgamma.mckay,
freund61,
@@ -124,9 +137,9 @@ anova.vgam,
anova.vglm,
beta4,
bisa, dbisa, pbisa, qbisa, rbisa,
-betabin.ab, betabinomial,
+betabinomial.ab, betabinomial,
dexpbinomial,
-dbetabin, pbetabin, rbetabin, dbetabin.ab, pbetabin.ab, rbetabin.ab,
+dbetabinom, pbetabinom, rbetabinom, dbetabinom.ab, pbetabinom.ab, rbetabinom.ab,
biplot.qrrvglm,
dbort, rbort, borel.tanner,
cauchy, cauchy1, ccoef.cao, ccoef.Coef.cao,
@@ -144,7 +157,8 @@ dirmultinomial, dirmul.old,
dnorm2,
dtheta.deta)
-export(cloglog,cauchit,elogit,fisherz,logc,loge,logit,logoff,nreciprocal,
+export(cloglog,cauchit,elogit,explink,fisherz,logc,loge,logit,
+ logoff,nreciprocal,
probit,reciprocal,rhobit,
golf,polf,nbolf,nbolf2,Cut)
export(ordpoisson, poissonp)
@@ -154,7 +168,7 @@ export(m2adefault,
erlang,
family.vglm,
dfelix, felix,
-fitted.values.uqo, fitted.vlm, fittedvsmooth.spline, fsqrt,
+fitted.values.uqo, fittedvlm, fittedvsmooth.spline, fsqrt,
formulavlm, formulaNA.VGAM,
garma, gaussianff,
hypersecant, hypersecant.1,
@@ -189,8 +203,8 @@ plotvglm, plotvlm,
plotvsmooth.spline, pnorm2, powl,
predict.cao, predictcao,
predictors, predictors.vglm,
-predict.qrrvglm, predict.rrvglm, predict.uqo, predict.vgam,
-predict.vglm, predict.vlm, predictvsmooth.spline,
+predictqrrvglm, predict.rrvglm, predict.uqo, predict.vgam,
+predictvglm, predict.vlm, predictvsmooth.spline,
predictvsmooth.spline.fit,
process.binomial2.data.vgam, process.categorical.data.vgam,
negzero.expression,
@@ -293,7 +307,7 @@ export(dinvparalogistic, pinvparalogistic, qinvparalogistic, rinvparalogistic,
invparalogistic)
export(dsinmad, psinmad, qsinmad, rsinmad, sinmad)
export(lognormal)
-export(dpolono, rpolono)
+export(dpolono, ppolono, rpolono)
export(dgpd, pgpd, qgpd, rgpd, gpd)
export(dgev, pgev, qgev, rgev, gev, egev)
export(dlaplace, plaplace, qlaplace, rlaplace, laplace)
@@ -327,7 +341,7 @@ bratt, Brat, calibrate.qrrvglm.control, calibrate.qrrvglm,
calibrate, cao.control,
cao, ccoef, cdf.lmscreg, cgo, chisq, clo,
Coef.qrrvglm, Coef, Coef.rrvglm, Coef.vlm,
-predict.qrrvglm,
+predictqrrvglm,
cratio, cumulative, propodds, prplot, prplot.control)
export(
deplot.lmscreg, dirichlet,
@@ -360,7 +374,7 @@ lvplot, lvplot.rrvglm, lv, Max, MNSs,
dmultinomial, multinomial, margeff)
export(
-huber, dhuber, edhuber, phuber, qhuber, rhuber)
+huber, huber1, dhuber, edhuber, phuber, qhuber, rhuber)
export(
@@ -380,7 +394,7 @@ guplot, guplot.default, guplot.vlm,
negbinomial, polya, normal1,
tobit, dtobit, ptobit, qtobit, rtobit,
Opt,
-persp.qrrvglm, plotdeplot.lmscreg, plotqrrvglm, plotqtplot.lmscreg,
+perspqrrvglm, plotdeplot.lmscreg, plotqrrvglm, plotqtplot.lmscreg,
plotvgam.control, plotvgam,
cenpoisson,
poissonff,
@@ -410,6 +424,7 @@ dzanegbin, pzanegbin, qzanegbin, rzanegbin, zanegbinomial,
dzapois, pzapois, qzapois, rzapois, zapoisson,
dzibinom, pzibinom, qzibinom, rzibinom, zibinomial,
dzinegbin, pzinegbin, qzinegbin, rzinegbin, zinegbinomial,
+dzigeom, pzigeom, qzigeom, rzigeom, zigeometric,
dzipois, pzipois, qzipois, rzipois,
zipoisson, zipoissonff,
mix2exp, mix2normal1, mix2poisson,
@@ -458,6 +473,7 @@ exportMethods(
"biplot", "deplot", "lvplot", "qtplot", "rlplot", "meplot",
"plot", "trplot", "vplot",
"formula", "case.names", "variable.names",
+"nobs", # "nvar",
"weights",
"persp")
diff --git a/NEWS b/NEWS
index b391866..7b095b0 100755
--- a/NEWS
+++ b/NEWS
@@ -6,6 +6,52 @@
+ CHANGES IN VGAM VERSION 0.8-4
+
+NEW FEATURES
+
+ o VGAM family functions renamed (Ouch!):
+ 1. 'betabinom.ab' renamed to 'betabinomial.ab'.
+ o Other functions renamed (Ouch!):
+ 1. '[dpr]betabin' renamed to '[dpr]betabinom' etc.;
+ 2. '[dpr]betabin.ab' renamed to '[dpr]betabinom.ab' etc.;
+ o Slot names changed (Ouch!):
+ 1. 'link' renamed to 'linkfun' for class "vglmff";
+ 2. 'inverse' renamed to 'linkinv' for class "vglmff".
+ o Extra arguments added to freund61().
+ o New VGAM family functions:
+ abbott(), zigeometric(dpqr), huber1().
+ o New functions: [p]polono(),
+ depvar() generic for the dependent (response) variable,
+ Qvar() and explink() for quasi-variances.
+ o Improved functions: [d]polono(), [dr]betabin() handles rho = 0
+ (suggested by Peng Yu).
+ o Improved family functions: normal1() handles matrix 'weights'.
+ o Defaults changed: [dr]betabin(rho = 0).
+ o New methods functions: nobs(), nvar(), depvar().
+ o Renaming: fitted.vlm() is now fittedvlm(),
+ persp.qrrvglm() is now perspqrrvglm(),
+ predict.qrrvglm() is now predictqrrvglm(),
+ predict.vglm() is now predictvglm().
+ o New data sets: finney44.
+ o VGAM now depends on R >= 2.11.1.
+ o Tested okay on R 2.14.0.
+
+
+BUG FIXES
+
+ o zibinomial() had 2 wrong elements in the EIM,
+ thanks to Alan Welsh for picking this up.
+ o margeff() for cumulative() was faulty.
+ o blurb slot of binormal() was faulty.
+ o betabinomial() did not return the estimated rho in @misc$rho as
+ did betabinomial.ab().
+ o kumar() did not initialize well with non-integer prior weights.
+ o rdagum() did not handle the 'scale' argument correctly.
+ o codes() in s() is defunct so it has been replaced.
+
+
+
CHANGES IN VGAM VERSION 0.8-3
NEW FEATURES
diff --git a/R/aamethods.q b/R/aamethods.q
index 45c07a8..cf0a713 100644
--- a/R/aamethods.q
+++ b/R/aamethods.q
@@ -55,9 +55,9 @@ setClass("vglmff", representation(
"first" = "expression",
"infos" = "function", # Added 20101203
"initialize" = "expression",
- "inverse" = "function",
"last" = "expression",
- "link" = "function",
+ "linkfun" = "function",
+ "linkinv" = "function",
"loglikelihood"= "function",
"middle" = "expression",
"middle2" = "expression",
@@ -69,14 +69,14 @@ prototype = .VGAM.prototype.list)
valid.vglmff = function(object) {
- compulsory = c("initialize", "weight", "deriv", "inverse")
+ compulsory = c("initialize", "weight", "deriv", "linkinv")
for(ii in compulsory) {
if (!length(slot(object, ii)))
stop("slot ", ii, " is empty")
}
- if (length(as.list(object at inverse)) != 3)
- stop("wrong number of arguments in object at inverse")
+ if (length(as.list(object at linkinv)) != 3)
+ stop("wrong number of arguments in object at linkinv")
}
if (FALSE)
@@ -478,6 +478,10 @@ if (!isGeneric("AIC"))
+setMethod("nobs", "vlm",
+ function(object, ...)
+ nobs.vlm(object, ...))
+
diff --git a/R/cao.fit.q b/R/cao.fit.q
index 1351c7d..17681ce 100644
--- a/R/cao.fit.q
+++ b/R/cao.fit.q
@@ -59,16 +59,16 @@ cao.fit <- function(x, y, w=rep(1, length(x[, 1])),
if (length(etastart)) {
eta <- etastart
mu <- if (length(mustart)) mustart else
- if (length(body(slot(family, "inverse"))))
- slot(family, "inverse")(eta, extra) else
+ if (length(body(slot(family, "linkinv"))))
+ slot(family, "linkinv")(eta, extra) else
warning("argument 'etastart' assigned a value ",
- "but there is no 'inverse' slot to use it")
+ "but there is no 'linkinv' slot to use it")
}
if (length(mustart)) {
mu <- mustart
- if (length(body(slot(family, "link")))) {
- eta <- slot(family, "link")(mu, extra)
+ if (length(body(slot(family, "linkfun")))) {
+ eta <- slot(family, "linkfun")(mu, extra)
} else {
warning("argument 'mustart' assigned a value ",
"but there is no 'link' slot to use it")
@@ -1139,7 +1139,7 @@ Coef.cao = function(object,
} # end of sppno
myetamat = rbind(maximum)
if (MSratio == 2) myetamat = kronecker(myetamat, matrix(1:0, 1, 2))
- maximum = object at family@inverse(eta=myetamat, extra=object at extra)
+ maximum = object at family@linkinv(eta=myetamat, extra=object at extra)
maximum = c(maximum) # Convert from matrix to vector
names(maximum) = ynames
@@ -1479,7 +1479,7 @@ predict.cao <- function (object, newdata=NULL,
object at misc$predictors.names else NULL)
return(etamat)
} else if (type == "response") {
- fv <- object at family@inverse(etamat, extra=object at extra)
+ fv <- object at family@linkinv(etamat, extra=object at extra)
dimnames(fv) = list(dimnames(fv)[[1]],
dimnames(object at fitted.values)[[2]])
return(fv)
@@ -1711,7 +1711,7 @@ persp.cao = function(x,
if (MSratio == 2) {
LP = kronecker(LP, matrix(1:0, 1, 2)) # n x M
}
- fitvals = object at family@inverse(LP, extra=object at extra) # n by NOS
+ fitvals = object at family@linkinv(LP, extra=object at extra) # n by NOS
dimnames(fitvals) = list(NULL, dimnames(fvmat)[[2]])
if (Rank == 1) {
diff --git a/R/cqo.fit.q b/R/cqo.fit.q
index 31d6d2d..f131735 100644
--- a/R/cqo.fit.q
+++ b/R/cqo.fit.q
@@ -29,7 +29,7 @@ callcqoc = function(cmatrix, etamat, xmat, ymat, wvec,
cmatrix = crow1C(cmatrix, control$Crow1positive)
numat = xmat[, control$colx2.index, drop = FALSE] %*% cmatrix
- sdnumat = sd(numat)
+ sdnumat = apply(numat, 2, sd)
for(lookat in 1:Rank)
if (sdnumat[lookat] >
control$MUXfactor[lookat] * control$isdlv[lookat]) {
@@ -150,7 +150,7 @@ calldcqo = function(cmatrix, etamat, xmat, ymat, wvec,
cmatrix = crow1C(cmatrix, control$Crow1positive)
numat = xmat[,control$colx2.index,drop=FALSE] %*% cmatrix
- sdnumat = sd(numat)
+ sdnumat = apply(numat, 2, sd)
for(lookat in 1:Rank)
if (sdnumat[lookat] > control$MUXfactor[lookat] *
control$isdlv[lookat]) {
@@ -314,16 +314,16 @@ cqo.fit <- function(x, y, w=rep(1, length(x[, 1])),
if (length(etastart)) {
eta <- etastart
mu <- if (length(mustart)) mustart else
- if (length(body(slot(family, "inverse"))))
- slot(family, "inverse")(eta, extra) else
+ if (length(body(slot(family, "linkinv"))))
+ slot(family, "linkinv")(eta, extra) else
warning("argument 'etastart' assigned a value ",
- "but there is no 'inverse' slot to use it")
+ "but there is no 'linkinv' slot to use it")
}
if (length(mustart)) {
mu <- mustart
- if (length(body(slot(family, "link")))) {
- eta <- slot(family, "link")(mu, extra)
+ if (length(body(slot(family, "linkfun")))) {
+ eta <- slot(family, "linkfun")(mu, extra)
} else {
warning("argument 'mustart' assigned a value ",
"but there is no 'link' slot to use it")
@@ -442,7 +442,7 @@ cqo.fit <- function(x, y, w=rep(1, length(x[, 1])),
eta <- if (ncol(X_vlm_save) > 1) X_vlm_save %*% coefstart +
offset else X_vlm_save * coefstart + offset
eta <- if (M > 1) matrix(eta, ncol=M, byrow=TRUE) else c(eta)
- mu <- family at inverse(eta, extra)
+ mu <- family at linkinv(eta, extra)
}
rmfromVGAMenv(c("etamat", "z", "U", "beta", "deviance",
@@ -654,7 +654,7 @@ cqo.fit <- function(x, y, w=rep(1, length(x[, 1])),
}
if (length(isdlv)) {
- actualSD = sd(ans)
+ actualSD = apply(cbind(ans), 2, sd)
for(ii in 1:Rank)
ans[,ii] = ans[,ii] * isdlv[ii] / actualSD[ii]
}
@@ -800,7 +800,7 @@ cqo.end.expression = expression({
fv <- tmp.fitted # Contains \bI \bnu
eta <- fv + offset
- mu <- family at inverse(eta, extra)
+ mu <- family at linkinv(eta, extra)
if (any(is.na(mu)))
warning("there are NAs in mu")
@@ -882,9 +882,9 @@ setMethod("deviance", "qrrvglm", function(object,...)
object at criterion$deviance)
setMethod("fitted", "qrrvglm", function(object, ...)
- fitted.vlm(object))
+ fittedvlm(object))
setMethod("fitted.values", "qrrvglm", function(object, ...)
- fitted.vlm(object))
+ fittedvlm(object))
diff --git a/R/family.aunivariate.R b/R/family.aunivariate.R
index 05fcdd3..4fc5695 100644
--- a/R/family.aunivariate.R
+++ b/R/family.aunivariate.R
@@ -105,16 +105,20 @@ pkumar = function(q, shape1, shape2) {
stop("the response must be in (0,1)")
predictors.names <- c(
- namesof("shape1", .lshape1, earg = .eshape1, tag = FALSE),
- namesof("shape2", .lshape2, earg = .eshape2, tag = FALSE))
+ namesof("shape1", .lshape1 , earg = .eshape1 , tag = FALSE),
+ namesof("shape2", .lshape2 , earg = .eshape2 , tag = FALSE))
if (!length(etastart)) {
kumar.Loglikfun <- function(shape1, y, x, w, extraargs) {
- if (any(round(w) != w))
- warning("assuming w is integer-valued")
- medy <- median(rep(y, w))
+
+
+
+
+ medy <- weighted.mean(y, w)
+
+
shape2 <- log(0.5) / log1p(-(medy^shape1))
sum(w * (log(shape1) + log(shape2) + (shape1-1)*log(y) +
(shape2-1)*log1p(-y^shape1)))
@@ -122,24 +126,27 @@ pkumar = function(q, shape1, shape2) {
shape1.grid <- seq( .grid.shape1[1], .grid.shape1[2], len = 19)
shape1.init <- if (length( .ishape1 )) .ishape1 else
- getMaxMin(shape1.grid, objfun=kumar.Loglikfun, y=y, x=x, w=w)
+ getMaxMin(shape1.grid, objfun = kumar.Loglikfun, y = y, x = x, w = w)
shape1.init <- rep(shape1.init, length = length(y))
- medy <- median(rep(y, w))
+ medy <- weighted.mean(y, w)
+
+
+
shape2.init <- if (length( .ishape2 )) .ishape2 else
- log(0.5) / log1p(-(medy^shape1.init))
+ log(0.5) / log1p(-(medy^shape1.init))
shape2.init <- rep(shape2.init, length = length(y))
etastart <- cbind(
- theta2eta(shape1.init, .lshape1, earg = .eshape1),
- theta2eta(shape2.init, .lshape2, earg = .eshape2))
+ theta2eta(shape1.init, .lshape1 , earg = .eshape1 ),
+ theta2eta(shape2.init, .lshape2 , earg = .eshape2 ))
}
}), list( .lshape1 = lshape1, .lshape2 = lshape2,
.ishape1 = ishape1, .ishape2 = ishape2,
.eshape1 = eshape1, .eshape2 = eshape2,
.grid.shape1 = grid.shape1 ))),
- inverse = eval(substitute(function(eta, extra = NULL){
- shape1 <- eta2theta(eta[,1], link = .lshape1, earg = .eshape1)
- shape2 <- eta2theta(eta[,2], link = .lshape2, earg = .eshape2)
+ linkinv = eval(substitute(function(eta, extra = NULL){
+ shape1 <- eta2theta(eta[,1], link = .lshape1 , earg = .eshape1 )
+ shape2 <- eta2theta(eta[,2], link = .lshape2 , earg = .eshape2 )
shape2 * (base::beta(1 + 1/shape1, shape2))
}, list( .lshape1 = lshape1, .lshape2 = lshape2,
.eshape1 = eshape1, .eshape2 = eshape2 ))),
@@ -167,8 +174,8 @@ pkumar = function(q, shape1, shape2) {
dshape1.deta <- dtheta.deta(shape1, link = .lshape1, earg = .eshape1)
dshape2.deta <- dtheta.deta(shape2, link = .lshape2, earg = .eshape2)
- dl.dshape1 <- 1 / shape1 + log(y) - (shape2-1) * log(y) *
- (y^shape1) / (1-y^shape1)
+ dl.dshape1 <- 1 / shape1 + log(y) - (shape2 - 1) * log(y) *
+ (y^shape1) / (1 - y^shape1)
dl.dshape2 <- 1 / shape2 + log1p(-y^shape1)
c(w) * cbind(dl.dshape1 * dshape1.deta,
@@ -239,8 +246,7 @@ rrice <- function(n, vee, sigma) {
-riceff.control <- function(save.weight = TRUE, ...)
-{
+riceff.control <- function(save.weight = TRUE, ...) {
list(save.weight = save.weight)
}
@@ -250,126 +256,127 @@ riceff.control <- function(save.weight = TRUE, ...)
ivee = NULL, isigma = NULL,
nsimEIM = 100, zero = NULL)
{
- if (mode(lvee) != "character" && mode(lvee) != "name")
- lvee = as.character(substitute(lvee))
- if (mode(lsigma) != "character" && mode(lsigma) != "name")
- lsigma = as.character(substitute(lsigma))
- if (length(ivee) && !is.Numeric(ivee, positive = TRUE))
- stop("bad input for argument 'ivee'")
- if (length(isigma) && !is.Numeric(isigma, positive = TRUE))
- stop("bad input for argument 'isigma'")
- if (!is.list(evee)) evee = list()
- if (!is.list(esigma)) esigma = list()
- if (!is.Numeric(nsimEIM, allow = 1, integ = TRUE) || nsimEIM <= 50)
- stop("'nsimEIM' should be an integer greater than 50")
-
- new("vglmff",
- blurb = c("Rice distribution\n\n",
- "Links: ",
- namesof("vee", lvee, earg = evee, tag = FALSE), ", ",
- namesof("sigma", lsigma, earg = esigma, tag = FALSE), "\n",
- "Mean: ",
- "sigma*sqrt(pi/2)*exp(z/2)*((1-z)*",
- "besselI(-z/2,nu=0)-z*besselI(-z/2,nu=1)) where z=-vee^2/(2*sigma^2)"),
- constraints = eval(substitute(expression({
- constraints = cm.zero.vgam(constraints, x, .zero, M)
- }), list( .zero = zero ))),
- initialize = eval(substitute(expression({
- if (ncol(y <- cbind(y)) != 1)
- stop("the response must be a vector or one-column matrix")
- if (any((y <= 0)))
- stop("the response must be in (0,Inf)")
- predictors.names = c(
- namesof("vee", .lvee, earg = .evee, tag = FALSE),
- namesof("sigma", .lsigma, earg = .esigma, tag = FALSE))
- if (!length(etastart)) {
- riceff.Loglikfun = function(vee, y, x, w, extraargs) {
- sigma.init = sd(rep(y, w))
- sum(w * (log(y) - 2*log(sigma.init) +
- log(besselI(y*vee/sigma.init^2, nu=0)) -
- (y^2 + vee^2)/(2*sigma.init^2)))
- }
- vee.grid = seq(quantile(rep(y,w), probs = seq(0, 1, 0.2))["20%"],
- quantile(rep(y,w), probs = seq(0, 1, 0.2))["80%"], len=11)
- vee.init = if (length( .ivee )) .ivee else
- getMaxMin(vee.grid, objfun=riceff.Loglikfun, y=y, x=x, w=w)
- vee.init = rep(vee.init, length = length(y))
- sigma.init = if (length( .isigma )) .isigma else
- sqrt(max((weighted.mean(y^2, w) - vee.init^2)/2, 0.001))
- sigma.init = rep(sigma.init, length = length(y))
- etastart = cbind(theta2eta(vee.init, .lvee, earg = .evee),
- theta2eta(sigma.init, .lsigma, earg = .esigma))
- }
- }), list( .lvee = lvee, .lsigma = lsigma,
- .ivee = ivee, .isigma=isigma,
- .evee = evee, .esigma = esigma ))),
- inverse = eval(substitute(function(eta, extra = NULL){
- vee = eta2theta(eta[,1], link = .lvee, earg = .evee)
- sigma = eta2theta(eta[,2], link = .lsigma, earg = .esigma)
- temp9 = -vee^2 / (2*sigma^2)
+ if (mode(lvee) != "character" && mode(lvee) != "name")
+ lvee = as.character(substitute(lvee))
+ if (mode(lsigma) != "character" && mode(lsigma) != "name")
+ lsigma = as.character(substitute(lsigma))
+ if (length(ivee) && !is.Numeric(ivee, positive = TRUE))
+ stop("bad input for argument 'ivee'")
+ if (length(isigma) && !is.Numeric(isigma, positive = TRUE))
+ stop("bad input for argument 'isigma'")
+ if (!is.list(evee)) evee = list()
+ if (!is.list(esigma)) esigma = list()
+ if (!is.Numeric(nsimEIM, allow = 1, integ = TRUE) || nsimEIM <= 50)
+ stop("'nsimEIM' should be an integer greater than 50")
-
- sigma * sqrt(pi/2) * ((1-temp9) * besselI(-temp9/2,nu=0,expon = TRUE) -
- temp9 * besselI(-temp9/2,nu=1,expon = TRUE))
- }, list( .lvee = lvee, .lsigma = lsigma,
- .evee = evee, .esigma = esigma ))),
- last = eval(substitute(expression({
- misc$link <- c("vee" = .lvee, "sigma" = .lsigma)
- misc$earg <- list("vee" = .evee, "sigma" = .esigma)
- misc$expected = TRUE
- misc$nsimEIM = .nsimEIM
- }), list( .lvee = lvee, .lsigma = lsigma,
- .evee = evee, .esigma = esigma, .nsimEIM = nsimEIM ))),
- loglikelihood = eval(substitute(
- function(mu,y,w,residuals = FALSE,eta,extra = NULL) {
- vee = eta2theta(eta[,1], link = .lvee, earg = .evee)
- sigma = eta2theta(eta[,2], link = .lsigma, earg = .esigma)
- if (residuals)
- stop("loglikelihood residuals not implemented yet") else {
- sum(w * drice(x=y, vee = vee, sigma=sigma, log = TRUE))
+ new("vglmff",
+ blurb = c("Rice distribution\n\n",
+ "Links: ",
+ namesof("vee", lvee, earg = evee, tag = FALSE), ", ",
+ namesof("sigma", lsigma, earg = esigma, tag = FALSE), "\n",
+ "Mean: ",
+ "sigma*sqrt(pi/2)*exp(z/2)*((1-z)*",
+ "besselI(-z/2,nu=0)-z*besselI(-z/2,nu=1)) where z=-vee^2/(2*sigma^2)"),
+ constraints = eval(substitute(expression({
+ constraints = cm.zero.vgam(constraints, x, .zero, M)
+ }), list( .zero = zero ))),
+ initialize = eval(substitute(expression({
+ if (ncol(y <- cbind(y)) != 1)
+ stop("the response must be a vector or one-column matrix")
+ if (any((y <= 0)))
+ stop("the response must be in (0,Inf)")
+ predictors.names = c(
+ namesof("vee", .lvee, earg = .evee, tag = FALSE),
+ namesof("sigma", .lsigma, earg = .esigma, tag = FALSE))
+ if (!length(etastart)) {
+ riceff.Loglikfun = function(vee, y, x, w, extraargs) {
+ sigma.init = sd(rep(y, w))
+ sum(w * (log(y) - 2*log(sigma.init) +
+ log(besselI(y*vee/sigma.init^2, nu=0)) -
+ (y^2 + vee^2)/(2*sigma.init^2)))
}
- }, list( .lvee = lvee, .lsigma = lsigma,
- .evee = evee, .esigma = esigma ))),
- vfamily = c("riceff"),
- deriv = eval(substitute(expression({
- vee = eta2theta(eta[,1], link = .lvee, earg = .evee)
- sigma = eta2theta(eta[,2], link = .lsigma, earg = .esigma)
- dvee.deta = dtheta.deta(vee, link = .lvee, earg = .evee)
- dsigma.deta = dtheta.deta(sigma, link = .lsigma, earg = .esigma)
- temp8 = y * vee / sigma^2
- dl.dvee = -vee/sigma^2 + (y/sigma^2) *
+ vee.grid = seq(quantile(rep(y, w), probs = seq(0, 1, 0.2))["20%"],
+ quantile(rep(y, w), probs = seq(0, 1, 0.2))["80%"], len=11)
+ vee.init = if (length( .ivee )) .ivee else
+ getMaxMin(vee.grid, objfun = riceff.Loglikfun, y = y, x = x, w = w)
+ vee.init = rep(vee.init, length = length(y))
+ sigma.init = if (length( .isigma )) .isigma else
+ sqrt(max((weighted.mean(y^2, w) - vee.init^2)/2, 0.001))
+ sigma.init = rep(sigma.init, length = length(y))
+ etastart = cbind(theta2eta(vee.init, .lvee, earg = .evee),
+ theta2eta(sigma.init, .lsigma, earg = .esigma))
+ }
+ }), list( .lvee = lvee, .lsigma = lsigma,
+ .ivee = ivee, .isigma = isigma,
+ .evee = evee, .esigma = esigma ))),
+ linkinv = eval(substitute(function(eta, extra = NULL){
+ vee = eta2theta(eta[, 1], link = .lvee, earg = .evee)
+ sigma = eta2theta(eta[, 2], link = .lsigma, earg = .esigma)
+ temp9 = -vee^2 / (2*sigma^2)
+
+
+ sigma * sqrt(pi/2) * ((1-temp9) * besselI(-temp9/2,nu=0,expon = TRUE) -
+ temp9 * besselI(-temp9/2,nu=1,expon = TRUE))
+ }, list( .lvee = lvee, .lsigma = lsigma,
+ .evee = evee, .esigma = esigma ))),
+ last = eval(substitute(expression({
+ misc$link <- c("vee" = .lvee, "sigma" = .lsigma)
+ misc$earg <- list("vee" = .evee, "sigma" = .esigma)
+ misc$expected = TRUE
+ misc$nsimEIM = .nsimEIM
+ }), list( .lvee = lvee, .lsigma = lsigma,
+ .evee = evee, .esigma = esigma, .nsimEIM = nsimEIM ))),
+ loglikelihood = eval(substitute(
+ function(mu,y, w,residuals = FALSE,eta,extra = NULL) {
+ vee = eta2theta(eta[,1], link = .lvee, earg = .evee)
+ sigma = eta2theta(eta[,2], link = .lsigma, earg = .esigma)
+ if (residuals)
+ stop("loglikelihood residuals not implemented yet") else {
+ sum(w * drice(x=y, vee = vee, sigma = sigma, log = TRUE))
+ }
+ }, list( .lvee = lvee, .lsigma = lsigma,
+ .evee = evee, .esigma = esigma ))),
+ vfamily = c("riceff"),
+ deriv = eval(substitute(expression({
+ vee = eta2theta(eta[,1], link = .lvee, earg = .evee)
+ sigma = eta2theta(eta[,2], link = .lsigma, earg = .esigma)
+ dvee.deta = dtheta.deta(vee, link = .lvee, earg = .evee)
+ dsigma.deta = dtheta.deta(sigma, link = .lsigma, earg = .esigma)
+ temp8 = y * vee / sigma^2
+ dl.dvee = -vee/sigma^2 + (y/sigma^2) *
+ besselI(temp8, nu=1) / besselI(temp8, nu=0)
+ dl.dsigma = -2/sigma + (y^2 + vee^2)/(sigma^3) - (2 * temp8 / sigma) *
+ besselI(temp8, nu=1) / besselI(temp8, nu=0)
+ c(w) * cbind(dl.dvee * dvee.deta,
+ dl.dsigma * dsigma.deta)
+ }), list( .lvee = lvee, .lsigma = lsigma,
+ .evee = evee, .esigma = esigma, .nsimEIM = nsimEIM ))),
+ weight = eval(substitute(expression({
+ run.var = run.cov = 0
+ for(ii in 1:( .nsimEIM )) {
+ ysim = rrice(n, vee = vee, sigma = sigma)
+ temp8 = ysim * vee / sigma^2
+ dl.dvee = -vee/sigma^2 + (ysim/sigma^2) *
+ besselI(temp8, nu=1) / besselI(temp8, nu=0)
+ dl.dsigma = -2/sigma + (ysim^2 + vee^2)/(sigma^3) -
+ (2 * temp8 / sigma) *
besselI(temp8, nu=1) / besselI(temp8, nu=0)
- dl.dsigma = -2/sigma + (y^2 + vee^2)/(sigma^3) - (2 * temp8 / sigma) *
- besselI(temp8, nu=1) / besselI(temp8, nu=0)
- c(w) * cbind(dl.dvee * dvee.deta,
- dl.dsigma * dsigma.deta)
- }), list( .lvee = lvee, .lsigma = lsigma,
- .evee = evee, .esigma = esigma, .nsimEIM = nsimEIM ))),
- weight = eval(substitute(expression({
- run.var = run.cov = 0
- for(ii in 1:( .nsimEIM )) {
- ysim = rrice(n, vee = vee, sigma=sigma)
- temp8 = ysim * vee / sigma^2
- dl.dvee = -vee/sigma^2 + (ysim/sigma^2) *
- besselI(temp8, nu=1) / besselI(temp8, nu=0)
- dl.dsigma = -2/sigma + (ysim^2 + vee^2)/(sigma^3) -
- (2 * temp8 / sigma) *
- besselI(temp8, nu=1) / besselI(temp8, nu=0)
- rm(ysim)
- temp3 = cbind(dl.dvee, dl.dsigma)
- run.var = ((ii-1) * run.var + temp3^2) / ii
- run.cov = ((ii-1) * run.cov + temp3[,1] * temp3[,2]) / ii
- }
- wz = if (intercept.only)
- matrix(colMeans(cbind(run.var, run.cov)),
- n, dimm(M), byrow = TRUE) else cbind(run.var, run.cov)
- dtheta.detas = cbind(dvee.deta, dsigma.deta)
- index0 = iam(NA, NA, M = M, both = TRUE, diag = TRUE)
- wz = wz * dtheta.detas[,index0$row] * dtheta.detas[,index0$col]
- c(w) * wz
- }), list( .lvee = lvee, .lsigma = lsigma,
- .evee = evee, .esigma = esigma, .nsimEIM = nsimEIM ))))
+ rm(ysim)
+ temp3 = cbind(dl.dvee, dl.dsigma)
+ run.var = ((ii-1) * run.var + temp3^2) / ii
+ run.cov = ((ii-1) * run.cov + temp3[,1] * temp3[,2]) / ii
+ }
+ wz = if (intercept.only)
+ matrix(colMeans(cbind(run.var, run.cov)),
+ n, dimm(M), byrow = TRUE) else cbind(run.var, run.cov)
+
+ dtheta.detas = cbind(dvee.deta, dsigma.deta)
+ index0 = iam(NA, NA, M = M, both = TRUE, diag = TRUE)
+ wz = wz * dtheta.detas[,index0$row] * dtheta.detas[,index0$col]
+ c(w) * wz
+ }), list( .lvee = lvee, .lsigma = lsigma,
+ .evee = evee, .esigma = esigma, .nsimEIM = nsimEIM ))))
}
@@ -381,7 +388,7 @@ dskellam = function(x, mu1, mu2, log = FALSE) {
stop("bad input for 'log.arg'")
L = max(length(x), length(mu1), length(mu2))
- x = rep(x, len=L); mu1 = rep(mu1, len=L); mu2 = rep(mu2, len=L);
+ x = rep(x, len = L); mu1 = rep(mu1, len = L); mu2 = rep(mu2, len = L);
ok2 <- is.finite(mu1) && is.finite(mu2) & (mu1 >= 0) & (mu2 >= 0)
ok3 <- (mu1 == 0) & (mu2 > 0)
ok4 <- (mu1 > 0) & (mu2 == 0)
@@ -389,17 +396,17 @@ dskellam = function(x, mu1, mu2, log = FALSE) {
if (log.arg) {
ans = -mu1 - mu2 + 2 * sqrt(mu1*mu2) +
0.5 * x * log(mu1) - 0.5 * x * log(mu2) +
- log(besselI(2 * sqrt(mu1*mu2), nu=x, expon = TRUE))
+ log(besselI(2 * sqrt(mu1*mu2), nu = x, expon = TRUE))
ans[ok3] = dpois(x = -x[ok3], lambda = mu2[ok3], log = TRUE)
ans[ok4] = dpois(x = -x[ok4], lambda = mu1[ok4], log = TRUE)
ans[ok5] = dpois(x = x[ok5], lambda = 0.0, log = TRUE)
ans[x != round(x)] = log(0.0)
} else {
ans = (mu1/mu2)^(x/2) * exp(-mu1-mu2 + 2 * sqrt(mu1*mu2)) *
- besselI(2 * sqrt(mu1*mu2), nu=x, expon = TRUE)
- ans[ok3] = dpois(x=-x[ok3], lambda=mu2[ok3])
- ans[ok4] = dpois(x=-x[ok4], lambda=mu1[ok4])
- ans[ok5] = dpois(x= x[ok5], lambda=0.0)
+ besselI(2 * sqrt(mu1*mu2), nu = x, expon = TRUE)
+ ans[ok3] = dpois(x = -x[ok3], lambda = mu2[ok3])
+ ans[ok4] = dpois(x = -x[ok4], lambda = mu1[ok4])
+ ans[ok5] = dpois(x = x[ok5], lambda = 0.0)
ans[x != round(x)] = 0.0
}
ans[!ok2] = NaN
@@ -417,9 +424,8 @@ rskellam = function(n, mu1, mu2) {
-skellam.control <- function(save.weight = TRUE, ...)
-{
- list(save.weight = save.weight)
+skellam.control <- function(save.weight = TRUE, ...) {
+ list(save.weight = save.weight)
}
@@ -463,7 +469,7 @@ skellam.control <- function(save.weight = TRUE, ...)
namesof("mu1", .lmu1, earg = .emu1, tag = FALSE),
namesof("mu2", .lmu2, earg = .emu2, tag = FALSE))
if (!length(etastart)) {
- junk = lm.wfit(x=x, y=y, w=w)
+ junk = lm.wfit(x = x, y = y, w = w)
var.y.est = sum(w * junk$resid^2) / junk$df.residual
mean.init = weighted.mean(y, w)
mu1.init = max((var.y.est + mean.init)/2, 0.01)
@@ -476,7 +482,7 @@ skellam.control <- function(save.weight = TRUE, ...)
}), list( .lmu1 = lmu1, .lmu2 = lmu2,
.imu1=imu1, .imu2=imu2,
.emu1 = emu1, .emu2 = emu2 ))),
- inverse = eval(substitute(function(eta, extra = NULL){
+ linkinv = eval(substitute(function(eta, extra = NULL){
mu1 = eta2theta(eta[,1], link = .lmu1, earg = .emu1)
mu2 = eta2theta(eta[,2], link = .lmu2, earg = .emu2)
mu1 - mu2
@@ -490,7 +496,7 @@ skellam.control <- function(save.weight = TRUE, ...)
}), list( .lmu1 = lmu1, .lmu2 = lmu2,
.emu1 = emu1, .emu2 = emu2, .nsimEIM = nsimEIM ))),
loglikelihood = eval(substitute(
- function(mu,y,w,residuals = FALSE,eta,extra = NULL) {
+ function(mu,y, w,residuals = FALSE,eta,extra = NULL) {
mu1 = eta2theta(eta[,1], link = .lmu1, earg = .emu1)
mu2 = eta2theta(eta[,2], link = .lmu2, earg = .emu2)
if (residuals)
@@ -559,43 +565,42 @@ skellam.control <- function(save.weight = TRUE, ...)
dyules = function(x, rho, log = FALSE) {
- log.arg = log
- rm(log)
- if ( !is.logical( log.arg ) || length( log.arg )!=1 )
- stop("bad input for 'log.arg'")
- if ( log.arg ) {
- ans = log(rho) + lbeta(abs(x), rho+1)
- ans[(x != round(x)) | (x < 1)] = log(0)
- } else {
- ans = rho * beta(x, rho+1)
- ans[(x != round(x)) | (x < 1)] = 0
- }
- ans[!is.finite(rho) | (rho <= 0) | (rho <= 0)] = NA
- ans
+ log.arg = log
+ rm(log)
+ if ( !is.logical( log.arg ) || length( log.arg )!=1 )
+ stop("bad input for 'log.arg'")
+ if ( log.arg ) {
+ ans = log(rho) + lbeta(abs(x), rho+1)
+ ans[(x != round(x)) | (x < 1)] = log(0)
+ } else {
+ ans = rho * beta(x, rho+1)
+ ans[(x != round(x)) | (x < 1)] = 0
+ }
+ ans[!is.finite(rho) | (rho <= 0) | (rho <= 0)] = NA
+ ans
}
ryules = function(n, rho) {
- if (!is.Numeric(n, integ = TRUE, allow = 1))
- stop("bad input for argument 'n'")
- rgeom(n, prob=exp(-rexp(n, rate=rho))) + 1
+ if (!is.Numeric(n, integ = TRUE, allow = 1))
+ stop("bad input for argument 'n'")
+ rgeom(n, prob = exp(-rexp(n, rate=rho))) + 1
}
pyules = function(q, rho) {
- tq = trunc(q)
- ans = 1 - tq * beta(abs(tq), rho+1)
- ans[q<1] = 0
- ans[(rho <= 0) | (rho <= 0)] = NA
- ans
+ tq = trunc(q)
+ ans = 1 - tq * beta(abs(tq), rho+1)
+ ans[q<1] = 0
+ ans[(rho <= 0) | (rho <= 0)] = NA
+ ans
}
-yulesimon.control <- function(save.weight = TRUE, ...)
-{
- list(save.weight = save.weight)
+yulesimon.control <- function(save.weight = TRUE, ...) {
+ list(save.weight = save.weight)
}
@@ -627,13 +632,13 @@ yulesimon.control <- function(save.weight = TRUE, ...)
predictors.names = namesof("rho", .link, earg =.earg, tag = FALSE)
if (!length(etastart)) {
- wmeany = weighted.mean(y,w) + 1/8
+ wmeany = weighted.mean(y, w) + 1/8
rho.init = wmeany / (wmeany - 1)
rho.init = rep( if (length( .irho )) .irho else rho.init, len = n)
etastart = theta2eta(rho.init, .link, earg =.earg)
}
}), list( .link=link, .earg =earg, .irho=irho ))),
- inverse = eval(substitute(function(eta, extra = NULL) {
+ linkinv = eval(substitute(function(eta, extra = NULL) {
ans = rho = eta2theta(eta, .link, earg =.earg)
ans[rho>1] = rho / (rho - 1)
ans[rho<=1] = NA
@@ -646,7 +651,7 @@ yulesimon.control <- function(save.weight = TRUE, ...)
misc$nsimEIM = .nsimEIM
}), list( .link=link, .earg =earg, .nsimEIM = nsimEIM ))),
loglikelihood = eval(substitute(
- function(mu,y,w,residuals= FALSE,eta, extra = NULL) {
+ function(mu,y, w,residuals= FALSE,eta, extra = NULL) {
rho = eta2theta(eta, .link, earg =.earg)
if (residuals)
stop("loglikelihood residuals not implemented yet") else {
@@ -684,23 +689,23 @@ yulesimon.control <- function(save.weight = TRUE, ...)
-dslash <- function(x, mu=0, sigma=1, log = FALSE,
- smallno=.Machine$double.eps*1000){
- log.arg = log
- rm(log)
- if (!is.Numeric(sigma) || any(sigma <= 0))
- stop("'sigma' must be positive")
- L = max(length(x), length(mu), length(sigma))
- x = rep(x, len = L); mu = rep(mu, len = L); sigma = rep(sigma, len = L)
- zedd = (x-mu)/sigma
- if (log.arg)
- ifelse(abs(zedd)<smallno, -log(2*sigma*sqrt(2*pi)),
- log1p(-exp(-zedd^2/2)) - log(sqrt(2*pi)*sigma*zedd^2)) else
- ifelse(abs(zedd)<smallno, 1/(2*sigma*sqrt(2*pi)),
- -expm1(-zedd^2/2)/(sqrt(2*pi)*sigma*zedd^2))
+dslash <- function(x, mu = 0, sigma = 1, log = FALSE,
+ smallno =.Machine$double.eps*1000){
+ log.arg = log
+ rm(log)
+ if (!is.Numeric(sigma) || any(sigma <= 0))
+ stop("'sigma' must be positive")
+ L = max(length(x), length(mu), length(sigma))
+ x = rep(x, len = L); mu = rep(mu, len = L); sigma = rep(sigma, len = L)
+ zedd = (x-mu)/sigma
+ if (log.arg)
+ ifelse(abs(zedd)<smallno, -log(2*sigma*sqrt(2*pi)),
+ log1p(-exp(-zedd^2/2)) - log(sqrt(2*pi)*sigma*zedd^2)) else
+ ifelse(abs(zedd)<smallno, 1/(2*sigma*sqrt(2*pi)),
+ -expm1(-zedd^2/2)/(sqrt(2*pi)*sigma*zedd^2))
}
-pslash <- function(q, mu=0, sigma=1){
+pslash <- function(q, mu = 0, sigma = 1){
if (!is.Numeric(sigma) || any(sigma <= 0))
stop("'sigma' must be positive")
L = max(length(q), length(mu), length(sigma))
@@ -716,7 +721,7 @@ pslash <- function(q, mu=0, sigma=1){
ans
}
-rslash <- function (n, mu=0, sigma=1){
+rslash <- function (n, mu = 0, sigma = 1){
if (!is.Numeric(n, posit = TRUE, integ = TRUE, allow = 1))
stop("bad input for argument 'n'")
if (any(sigma <= 0))
@@ -757,7 +762,7 @@ slash.control <- function(save.weight = TRUE, ...)
new("vglmff",
blurb = c("Slash distribution\n\n",
"Links: ",
- namesof("mu", lmu, earg = emu), ", ",
+ namesof("mu", lmu, earg = emu, tag = FALSE), ", ",
namesof("sigma", lsigma, earg = esigma, tag = FALSE), "\n",
paste(
"1-exp(-(((y-mu)/sigma)^2)/2))/(sqrt(2*pi)*sigma*((y-mu)/sigma)^2)",
@@ -771,14 +776,14 @@ slash.control <- function(save.weight = TRUE, ...)
if (ncol(y <- cbind(y)) != 1)
stop("the response must be a vector or one-column matrix")
predictors.names = c(
- namesof("mu", .lmu, earg = .emu, tag = FALSE),
+ namesof("mu", .lmu, earg = .emu, tag = FALSE),
namesof("sigma", .lsigma, earg = .esigma, tag = FALSE))
if (!length(etastart)) {
slash.Loglikfun = function(mu, y, x, w, extraargs) {
sigma = if (is.Numeric(.isigma)) .isigma else
max(0.01,
- ((quantile(rep(y,w), prob=0.75)/2)-mu)/qnorm(0.75))
+ ((quantile(rep(y, w), prob = 0.75)/2)-mu)/qnorm(0.75))
zedd = (y-mu)/sigma
sum(w * ifelse(abs(zedd)<.smallno,
-log(2*sigma*sqrt(2*pi)),
@@ -786,13 +791,13 @@ slash.control <- function(save.weight = TRUE, ...)
log(sqrt(2*pi) * sigma * zedd^2)))
}
iprobs = .iprobs
- mu.grid = quantile(rep(y,w), probs=iprobs)
+ mu.grid = quantile(rep(y, w), probs=iprobs)
mu.grid = seq(mu.grid[1], mu.grid[2], length=100)
mu.init = if (length( .imu )) .imu else
- getMaxMin(mu.grid, objfun=slash.Loglikfun,
- y=y, x=x, w=w)
+ getMaxMin(mu.grid, objfun = slash.Loglikfun,
+ y = y, x = x, w = w)
sigma.init = if (is.Numeric(.isigma)) .isigma else
- max(0.01, ((quantile(rep(y,w), prob=0.75)/2)-mu.init)/qnorm(0.75))
+ max(0.01, ((quantile(rep(y, w), prob = 0.75)/2)-mu.init)/qnorm(0.75))
mu.init = rep(mu.init, length = length(y))
etastart = matrix(0, n, 2)
etastart[,1] = theta2eta(mu.init, .lmu, earg =.emu)
@@ -802,7 +807,7 @@ slash.control <- function(save.weight = TRUE, ...)
.imu = imu, .isigma = isigma,
.emu = emu, .esigma = esigma,
.iprobs=iprobs, .smallno = smallno))),
- inverse = eval(substitute(function(eta, extra = NULL){
+ linkinv = eval(substitute(function(eta, extra = NULL){
NA * eta2theta(eta[,1], link = .lmu, earg = .emu)
}, list( .lmu = lmu, .emu = emu ))),
last = eval(substitute(expression({
@@ -813,14 +818,14 @@ slash.control <- function(save.weight = TRUE, ...)
}), list( .lmu = lmu, .lsigma = lsigma,
.emu = emu, .esigma = esigma, .nsimEIM = nsimEIM ))),
loglikelihood = eval(substitute(
- function(mu,y,w,residuals = FALSE,eta,extra = NULL) {
+ function(mu,y, w,residuals = FALSE,eta,extra = NULL) {
mu = eta2theta(eta[,1], link = .lmu, earg = .emu)
sigma = eta2theta(eta[,2], link = .lsigma, earg = .esigma)
zedd = (y - mu) / sigma
if (residuals)
stop("loglikelihood residuals not implemented yet") else {
- sum(w * dslash(x=y, mu=mu, sigma=sigma, log = TRUE,
- smallno= .smallno))
+ sum(w * dslash(x=y, mu = mu, sigma = sigma, log = TRUE,
+ smallno = .smallno))
}
}, list( .lmu = lmu, .lsigma = lsigma,
.emu = emu, .esigma = esigma, .smallno = smallno ))),
@@ -853,7 +858,7 @@ slash.control <- function(save.weight = TRUE, ...)
log(sqrt(2*pi)*sigma*((ysim-mu)/sigma)^2),
c("mu", "sigma"))
for(ii in 1:( .nsimEIM )) {
- ysim = rslash(n, mu=mu, sigma=sigma)
+ ysim = rslash(n, mu = mu, sigma = sigma)
seval.d3 = eval(sd3)
dl.dthetas = attr(seval.d3, "gradient")
@@ -906,7 +911,7 @@ dnefghs = function(x, tau, log = FALSE) {
if (!is.list(earg)) earg = list()
if (!is.Numeric(imethod, allow = 1, integ = TRUE, posit = TRUE) ||
imethod > 2)
- stop("'imethod' must be 1 or 2")
+ stop("argument 'imethod' must be 1 or 2")
new("vglmff",
blurb = c("Natural exponential family generalized hyperbolic ",
@@ -921,8 +926,8 @@ dnefghs = function(x, tau, log = FALSE) {
predictors.names = namesof("tau", .link, earg =.earg, tag = FALSE)
if (!length(etastart)) {
- wmeany = if ( .imethod == 1) weighted.mean(y,w) else
- median(rep(y,w))
+ wmeany = if ( .imethod == 1) weighted.mean(y, w) else
+ median(rep(y, w))
if (abs(wmeany) < 0.01) wmeany = 0.01
tau.init = atan(pi / wmeany) / pi + 0.5
tau.init[tau.init < 0.03] = 0.03
@@ -932,7 +937,7 @@ dnefghs = function(x, tau, log = FALSE) {
}
}), list( .link = link, .earg = earg, .itau = itau,
.imethod = imethod ))),
- inverse = eval(substitute(function(eta, extra = NULL) {
+ linkinv = eval(substitute(function(eta, extra = NULL) {
tau = eta2theta(eta, .link, earg =.earg)
pi / tan(pi * tau)
}, list( .link=link, .earg =earg ))),
@@ -943,7 +948,7 @@ dnefghs = function(x, tau, log = FALSE) {
misc$imethod= .imethod
}), list( .link=link, .earg =earg, .imethod = imethod ))),
loglikelihood = eval(substitute(
- function(mu,y,w,residuals= FALSE,eta, extra = NULL) {
+ function(mu,y, w,residuals= FALSE,eta, extra = NULL) {
tau = eta2theta(eta, .link, earg =.earg)
if (residuals)
stop("loglikelihood residuals not implemented yet") else {
@@ -985,110 +990,110 @@ dlogF = function(x, shape1, shape2, log = FALSE) {
ishape1 = NULL, ishape2 = 1,
imethod = 1)
{
- if (length(ishape1) && !is.Numeric(ishape1, positi = TRUE))
- stop("argument 'ishape1' must be positive")
- if ( # length(ishape2) &&
- !is.Numeric(ishape2, positi = TRUE))
- stop("argument 'ishape2' must be positive")
- if (mode(lshape1) != "character" && mode(lshape1) != "name")
- lshape1 = as.character(substitute(lshape1))
- if (mode(lshape2) != "character" && mode(lshape2) != "name")
- lshape2 = as.character(substitute(lshape2))
- if (!is.list(eshape1)) eshape1 = list()
- if (!is.list(eshape2)) eshape2 = list()
- if (!is.Numeric(imethod, allow = 1, integ = TRUE, posit = TRUE) ||
- imethod > 2)
- stop("'imethod' must be 1 or 2")
+ if (length(ishape1) && !is.Numeric(ishape1, positi = TRUE))
+ stop("argument 'ishape1' must be positive")
+ if ( # length(ishape2) &&
+ !is.Numeric(ishape2, positi = TRUE))
+ stop("argument 'ishape2' must be positive")
+ if (mode(lshape1) != "character" && mode(lshape1) != "name")
+ lshape1 = as.character(substitute(lshape1))
+ if (mode(lshape2) != "character" && mode(lshape2) != "name")
+ lshape2 = as.character(substitute(lshape2))
+ if (!is.list(eshape1)) eshape1 = list()
+ if (!is.list(eshape2)) eshape2 = list()
+ if (!is.Numeric(imethod, allow = 1, integ = TRUE, posit = TRUE) ||
+ imethod > 2)
+ stop("argument 'imethod' must be 1 or 2")
- new("vglmff",
- blurb = c("log F distribution\n",
- "f(y) = exp(-shape2*y)/(beta(shape1,shape2)*",
- "(1+exp(-y))^(shape1+shape2))\n\n",
- "Link: ",
- namesof("shape1", lshape1, earg =eshape1),
- ", ",
- namesof("shape2", lshape2, earg =eshape2),
- "\n\n",
- "Mean: digamma(shape1) - digamma(shape2)"),
- initialize = eval(substitute(expression({
- if (ncol(cbind(y)) != 1)
- stop("response must be a vector or a one-column matrix")
- predictors.names = c(
- namesof("shape1", .lshape1, earg = .eshape1, tag = FALSE),
- namesof("shape2", .lshape2, earg = .eshape2, tag = FALSE))
+ new("vglmff",
+ blurb = c("log F distribution\n",
+ "f(y) = exp(-shape2*y)/(beta(shape1,shape2)*",
+ "(1+exp(-y))^(shape1+shape2))\n\n",
+ "Link: ",
+ namesof("shape1", lshape1, earg =eshape1),
+ ", ",
+ namesof("shape2", lshape2, earg =eshape2),
+ "\n\n",
+ "Mean: digamma(shape1) - digamma(shape2)"),
+ initialize = eval(substitute(expression({
+ if (ncol(cbind(y)) != 1)
+ stop("response must be a vector or a one-column matrix")
+ predictors.names = c(
+ namesof("shape1", .lshape1, earg = .eshape1, tag = FALSE),
+ namesof("shape2", .lshape2, earg = .eshape2, tag = FALSE))
- if (!length(etastart)) {
- wmeany = if ( .imethod == 1) weighted.mean(y,w) else
- median(rep(y,w))
+ if (!length(etastart)) {
+ wmeany = if ( .imethod == 1) weighted.mean(y, w) else
+ median(rep(y, w))
- shape1.init = shape2.init = rep( .ishape2, len = n)
- shape1.init = if (length( .ishape1))
+ shape1.init = shape2.init = rep( .ishape2, len = n)
+ shape1.init = if (length( .ishape1))
rep( .ishape1, len = n) else {
index1 = (y > wmeany)
shape1.init[index1] = shape2.init[index1] + 1/1
shape1.init[!index1] = shape2.init[!index1] - 1/1
shape1.init = pmax(shape1.init, 1/8)
shape1.init
- }
- etastart =
- cbind(theta2eta(shape1.init, .lshape1, earg = .eshape1),
- theta2eta(shape2.init, .lshape2, earg = .eshape2))
- }
- }), list( .lshape1 = lshape1, .lshape2 = lshape2,
- .eshape1 = eshape1, .eshape2 = eshape2,
- .ishape1=ishape1, .ishape2=ishape2,
- .imethod = imethod ))),
- inverse = eval(substitute(function(eta, extra = NULL) {
- shape1 = eta2theta(eta[,1], .lshape1, earg = .eshape1)
- shape2 = eta2theta(eta[,2], .lshape2, earg = .eshape2)
- digamma(shape1) - digamma(shape2)
- }, list( .lshape1 = lshape1, .lshape2 = lshape2,
- .eshape1 = eshape1, .eshape2 = eshape2 ))),
- last = eval(substitute(expression({
- misc$link <- c(shape1 = .lshape1, shape2 = .lshape2)
- misc$earg <- list(shape1 = .eshape1, shape2 = .eshape2)
- misc$expected = TRUE
- misc$imethod= .imethod
- }), list( .lshape1 = lshape1, .lshape2 = lshape2,
- .eshape1 = eshape1, .eshape2 = eshape2,
- .imethod = imethod ))),
- loglikelihood = eval(substitute(
- function(mu,y,w,residuals= FALSE,eta, extra = NULL) {
- shape1 = eta2theta(eta[,1], .lshape1, earg = .eshape1)
- shape2 = eta2theta(eta[,2], .lshape2, earg = .eshape2)
- if (residuals)
- stop("loglikelihood residuals not implemented yet") else {
- sum(w * dlogF(x=y, shape1 = shape1, shape2 = shape2, log = TRUE))
- }
- }, list( .lshape1 = lshape1, .lshape2 = lshape2,
- .eshape1 = eshape1, .eshape2 = eshape2 ))),
- vfamily = c("logF"),
- deriv = eval(substitute(expression({
- shape1 = eta2theta(eta[,1], .lshape1, earg = .eshape1)
- shape2 = eta2theta(eta[,2], .lshape2, earg = .eshape2)
- tmp888 = digamma(shape1 + shape2) - log1p(exp(-y))
- dl.dshape1 = tmp888 - digamma(shape1)
- dl.dshape2 = tmp888 - digamma(shape2) - y
- dshape1.deta = dtheta.deta(shape1, .lshape1, earg = .eshape1)
- dshape2.deta = dtheta.deta(shape2, .lshape2, earg = .eshape2)
- c(w) * cbind(dl.dshape1 * dshape1.deta,
- dl.dshape2 * dshape2.deta)
- }), list( .lshape1 = lshape1, .lshape2 = lshape2,
- .eshape1 = eshape1, .eshape2 = eshape2 ))),
- weight = eval(substitute(expression({
- tmp888 = trigamma(shape1 + shape2)
- d2l.dshape12 = trigamma(shape1) - tmp888
- d2l.dshape22 = trigamma(shape2) - tmp888
- d2l.dshape1shape2 = -tmp888
- wz = matrix(0, n, dimm(M))
- wz[,iam(1,1,M = M)] = d2l.dshape12 * dshape1.deta^2
- wz[,iam(2,2,M = M)] = d2l.dshape22 * dshape2.deta^2
- wz[,iam(1,2,M = M)] = d2l.dshape1shape2 * dshape1.deta *
+ }
+ etastart =
+ cbind(theta2eta(shape1.init, .lshape1, earg = .eshape1),
+ theta2eta(shape2.init, .lshape2, earg = .eshape2))
+ }
+ }), list( .lshape1 = lshape1, .lshape2 = lshape2,
+ .eshape1 = eshape1, .eshape2 = eshape2,
+ .ishape1 = ishape1, .ishape2 = ishape2,
+ .imethod = imethod ))),
+ linkinv = eval(substitute(function(eta, extra = NULL) {
+ shape1 = eta2theta(eta[,1], .lshape1, earg = .eshape1)
+ shape2 = eta2theta(eta[,2], .lshape2, earg = .eshape2)
+ digamma(shape1) - digamma(shape2)
+ }, list( .lshape1 = lshape1, .lshape2 = lshape2,
+ .eshape1 = eshape1, .eshape2 = eshape2 ))),
+ last = eval(substitute(expression({
+ misc$link <- c(shape1 = .lshape1, shape2 = .lshape2)
+ misc$earg <- list(shape1 = .eshape1, shape2 = .eshape2)
+ misc$expected = TRUE
+ misc$imethod= .imethod
+ }), list( .lshape1 = lshape1, .lshape2 = lshape2,
+ .eshape1 = eshape1, .eshape2 = eshape2,
+ .imethod = imethod ))),
+ loglikelihood = eval(substitute(
+ function(mu,y, w,residuals= FALSE,eta, extra = NULL) {
+ shape1 = eta2theta(eta[,1], .lshape1, earg = .eshape1)
+ shape2 = eta2theta(eta[,2], .lshape2, earg = .eshape2)
+ if (residuals)
+ stop("loglikelihood residuals not implemented yet") else {
+ sum(w * dlogF(x=y, shape1 = shape1, shape2 = shape2, log = TRUE))
+ }
+ }, list( .lshape1 = lshape1, .lshape2 = lshape2,
+ .eshape1 = eshape1, .eshape2 = eshape2 ))),
+ vfamily = c("logF"),
+ deriv = eval(substitute(expression({
+ shape1 = eta2theta(eta[,1], .lshape1, earg = .eshape1)
+ shape2 = eta2theta(eta[,2], .lshape2, earg = .eshape2)
+ tmp888 = digamma(shape1 + shape2) - log1p(exp(-y))
+ dl.dshape1 = tmp888 - digamma(shape1)
+ dl.dshape2 = tmp888 - digamma(shape2) - y
+ dshape1.deta = dtheta.deta(shape1, .lshape1, earg = .eshape1)
+ dshape2.deta = dtheta.deta(shape2, .lshape2, earg = .eshape2)
+ c(w) * cbind(dl.dshape1 * dshape1.deta,
+ dl.dshape2 * dshape2.deta)
+ }), list( .lshape1 = lshape1, .lshape2 = lshape2,
+ .eshape1 = eshape1, .eshape2 = eshape2 ))),
+ weight = eval(substitute(expression({
+ tmp888 = trigamma(shape1 + shape2)
+ d2l.dshape12 = trigamma(shape1) - tmp888
+ d2l.dshape22 = trigamma(shape2) - tmp888
+ d2l.dshape1shape2 = -tmp888
+ wz = matrix(0, n, dimm(M))
+ wz[,iam(1,1,M = M)] = d2l.dshape12 * dshape1.deta^2
+ wz[,iam(2,2,M = M)] = d2l.dshape22 * dshape2.deta^2
+ wz[,iam(1,2,M = M)] = d2l.dshape1shape2 * dshape1.deta *
dshape2.deta
- c(w) * wz
- }), list( .lshape1 = lshape1, .lshape2 = lshape2,
- .eshape1 = eshape1, .eshape2 = eshape2 ))))
+ c(w) * wz
+ }), list( .lshape1 = lshape1, .lshape2 = lshape2,
+ .eshape1 = eshape1, .eshape2 = eshape2 ))))
}
@@ -1128,7 +1133,7 @@ rbenf <- function(n, ndigits = 1) {
ans <- rep(lowerlimit, length = use.n)
for(ii in (lowerlimit+1):upperlimit) {
indexTF <- (pbenf(ii-1, ndigits = ndigits) < myrunif) &
- (myrunif <= pbenf(ii, ndigits=ndigits))
+ (myrunif <= pbenf(ii, ndigits = ndigits))
ans[indexTF] <- ii
}
ans
@@ -1167,8 +1172,8 @@ qbenf <- function(p, ndigits = 1) {
ans <- rep(lowerlimit, length = length(p))
for(ii in (lowerlimit+1):upperlimit) {
indexTF <- is.finite(p) &
- (pbenf(ii-1, ndigits=ndigits) < p) &
- (p <= pbenf(ii, ndigits=ndigits))
+ (pbenf(ii-1, ndigits = ndigits) < p) &
+ (p <= pbenf(ii, ndigits = ndigits))
ans[indexTF] <- ii
}
diff --git a/R/family.basics.R b/R/family.basics.R
index 9a61c5e..a3ce7a4 100644
--- a/R/family.basics.R
+++ b/R/family.basics.R
@@ -33,7 +33,7 @@ getind <- function(constraints, M, ncolx) {
}
}
ans[[kk]] <- list(xindex = ansx,
- X_vlmindex = (1:ncol(temp2))[temp2[kk,] != 0])
+ X_vlmindex = (1:ncol(temp2))[temp2[kk,] != 0])
}
ans[[M+1]] <- ncol(temp2)
@@ -147,7 +147,7 @@ cm.nointercept.vgam <- function(constraints, x, nointercept, M)
warning("Constraint matrix of (Intercept) not diagonal")
temp <- constraints[["(Intercept)"]]
- temp <- temp[,-nointercept,drop = FALSE] # Will have M rows & at least 1 coln
+ temp <- temp[, -nointercept, drop = FALSE]
constraints[["(Intercept)"]] <- temp
constraints
}
@@ -499,7 +499,9 @@ vindex <- function(M, row.arg = FALSE, col.arg = FALSE,
if(!exists("is.R")) is.R <- function()
- exists("version") && !is.null(version$language) && version$language == "R"
+ exists("version") &&
+ !is.null(version$language) &&
+ version$language == "R"
wweights <- function(object, matrix.arg = TRUE, deriv.arg = FALSE,
@@ -556,14 +558,13 @@ wweights <- function(object, matrix.arg = TRUE, deriv.arg = FALSE,
if (any(slotNames(object) == "family")) {
expr <- object at family@deriv
deriv.mu <- eval(expr)
- # Need to compute wz only if it couldn't be extracted from the object
if (!length(wz)) {
expr <- object at family@weight
wz <- eval(expr)
if (M > 1)
- dimnames(wz) = list(dimnames(wz)[[1]], NULL) # Remove colnames
+ dimnames(wz) = list(dimnames(wz)[[1]], NULL) # Remove colnames
wz = if (matrix.arg) as.matrix(wz) else c(wz)
}
if (deriv.arg) list(deriv=deriv.mu, weights=wz) else wz
@@ -601,7 +602,7 @@ procVec <- function(vec, yn, Default) {
default = vec
}
- answer = rep(default, len=length(yn)) # Recycling may be premature if named
+ answer = rep(default, len = length(yn))
names(answer) = yn
if (named) {
nvec2 = nvec[nvec != ""]
@@ -652,7 +653,8 @@ weightsvlm <- function(object, type = c("prior", "working"),
matrix.arg=matrix.arg, deriv.arg=deriv.arg,
ignore.slot=ignore.slot, ...)
} else {
- if (deriv.arg) stop("cannot set 'deriv = TRUE' when 'type=\"prior\"'")
+ if (deriv.arg)
+ stop("cannot set 'deriv = TRUE' when 'type=\"prior\"'")
ans = pweights(object)
if (matrix.arg) as.matrix(ans) else c(ans)
}
@@ -704,17 +706,19 @@ qnupdate <- function(w, wzold, dderiv, deta, M, keeppd = TRUE,
index$col.index = rep(index$col.index, len=ncol(wzold))
updateThese = if (keeppd) (sy > effpos) else rep(TRUE, len=length(sy))
if (!keeppd || any(updateThese)) {
- wznew[updateThese,] = wznew[updateThese,] - Bs[updateThese,index$row] *
+ wznew[updateThese,] = wznew[updateThese,] -
+ Bs[updateThese,index$row] *
Bs[updateThese,index$col] / sBs[updateThese] +
- dderiv[updateThese,index$row] * dderiv[updateThese,index$col] /
- sy[updateThese]
+ dderiv[updateThese,index$row] *
+ dderiv[updateThese,index$col] / sy[updateThese]
notupdated = sum(!updateThese)
if (notupdated && trace)
- cat(notupdated,"weight matrices not updated out of",length(sy),"\n")
+ cat(notupdated,
+ "weight matrices not updated out of", length(sy), "\n")
} else {
- warning("no BFGS quasi-Newton update made at all")
- cat("no BFGS quasi-Newton update made at all\n")
- flush.console()
+ warning("no BFGS quasi-Newton update made at all")
+ cat("no BFGS quasi-Newton update made at all\n")
+ flush.console()
}
wznew
}
@@ -725,15 +729,16 @@ qnupdate <- function(w, wzold, dderiv, deta, M, keeppd = TRUE,
mbesselI0 <- function(x, deriv.arg = 0) {
- if (!is.Numeric(deriv.arg, allow = 1, integer = TRUE, posit = TRUE) &&
- deriv.arg != 0)
- stop("argument 'deriv.arg' must be a single non-negative integer")
- if (!(deriv.arg == 0 || deriv.arg == 1 || deriv.arg == 2))
- stop("argument 'deriv' must be 0, 1, or 2")
- if (!is.Numeric(x))
- stop("bad input for argument 'x'")
- nn = length(x)
- if (FALSE) {
+ if (!is.Numeric(deriv.arg, allow = 1, integer = TRUE, posit = TRUE) &&
+ deriv.arg != 0)
+ stop("argument 'deriv.arg' must be a single non-negative integer")
+ if (!(deriv.arg == 0 || deriv.arg == 1 || deriv.arg == 2))
+ stop("argument 'deriv' must be 0, 1, or 2")
+ if (!is.Numeric(x))
+ stop("bad input for argument 'x'")
+ nn = length(x)
+
+ if (FALSE) {
}
# Use finite differences
@@ -843,7 +848,8 @@ lerch <- function(x, s, v, tolerance=1.0e-10, iter=100) {
x[!xok] = 0 # Fix this later
ans = dotC(name="lerchphi123", err=integer(L), as.integer(L),
as.double(x), as.double(s), as.double(v),
- acc=as.double(tolerance), result=double(L), as.integer(iter))
+ acc=as.double(tolerance), result=double(L),
+ as.integer(iter))
ifelse(ans$err == 0 & xok , ans$result, NA)
}
diff --git a/R/family.binomial.R b/R/family.binomial.R
index cb5d155..0f9c90e 100644
--- a/R/family.binomial.R
+++ b/R/family.binomial.R
@@ -86,13 +86,15 @@ betabinomial.control <- function(save.weight = TRUE, ...)
if (!is.list(emu )) emu <- list()
if (!is.list(erho)) erho <- list()
- if (!is.Numeric(imethod, allow=1, integ = TRUE, posit = TRUE) ||
- imethod > 4) stop("argument 'imethod' must be 1, 2, 3 or 4")
+ if (!is.Numeric(imethod, allow = 1, integ = TRUE, positive = TRUE) ||
+ imethod > 4)
+ stop("argument 'imethod' must be 1, 2, 3 or 4")
- if (!is.Numeric(shrinkage.init, allow=1) || shrinkage.init < 0 ||
- shrinkage.init > 1) stop("bad input for argument 'shrinkage.init'")
+ if (!is.Numeric(shrinkage.init, allow = 1) || shrinkage.init < 0 ||
+ shrinkage.init > 1)
+ stop("bad input for argument 'shrinkage.init'")
if (!is.null(nsimEIM)) {
- if (!is.Numeric(nsimEIM, allow=1, integ = TRUE))
+ if (!is.Numeric(nsimEIM, allow = 1, integ = TRUE))
stop("bad input for argument 'nsimEIM'")
if (nsimEIM <= 10)
warning("'nsimEIM' should be an integer greater than 10, say")
@@ -136,7 +138,7 @@ betabinomial.control <- function(save.weight = TRUE, ...)
shape2 <- (1-extraargs$mustart) * (1-rhoval) / rhoval
ycounts <- extraargs$ycounts # Ought to be integer-valued
nvec <- extraargs$nvec
- sum(dbetabin.ab(x = ycounts, size=nvec, shape1 = shape1,
+ sum(dbetabinom.ab(x = ycounts, size = nvec, shape1 = shape1,
shape2 = shape2, log = TRUE))
}
rho.grid <- seq(0.05, 0.95, len=21) # rvar =
@@ -171,15 +173,16 @@ betabinomial.control <- function(save.weight = TRUE, ...)
.emu = emu, .erho = erho,
.imethod = imethod, .sinit = shrinkage.init,
.nsimEIM = nsimEIM, .irho = irho ))),
- inverse = eval(substitute(function(eta, extra = NULL)
+ linkinv = eval(substitute(function(eta, extra = NULL)
eta2theta(eta[,1], .lmu, earg = .emu),
list( .lmu = lmu, .emu = emu ))),
last = eval(substitute(expression({
- misc$link <- c(mu = .lmu, rho = .lrho)
+ misc$link <- c(mu = .lmu, rho = .lrho)
misc$earg <- list(mu = .emu, rho = .erho)
misc$zero <- .zero
misc$expected <- TRUE
misc$nsimEIM = .nsimEIM
+ misc$rho = 1 / (shape1 + shape2 + 1)
}), list( .lmu = lmu, .lrho = lrho,
.emu = emu, .erho = erho,
.nsimEIM = nsimEIM, .zero = zero ))),
@@ -208,7 +211,7 @@ betabinomial.control <- function(save.weight = TRUE, ...)
stop("loglikelihood residuals not implemented yet")
} else {
sum((if (is.numeric(extra$orig.w)) extra$orig.w else 1) *
- dbetabin.ab(x = ycounts, size = nvec, shape1 = shape1,
+ dbetabinom.ab(x = ycounts, size = nvec, shape1 = shape1,
shape2 = shape2, log = TRUE ))
}
}, list( .lmu = lmu, .lrho = lrho,
@@ -278,7 +281,7 @@ betabinomial.control <- function(save.weight = TRUE, ...)
dthetas.detas <- cbind(dmu.deta, drho.deta)
for (ii in 1:( .nsimEIM )) {
- ysim <- rbetabin.ab(n = n, size=nvec, shape1 = shape1,
+ ysim <- rbetabinom.ab(n = n, size = nvec, shape1 = shape1,
shape2 = shape2)
dl.dmu <- dshape1.dmu * (digamma(shape1+ysim) -
digamma(shape2+nvec-ysim) -
@@ -315,46 +318,48 @@ betabinomial.control <- function(save.weight = TRUE, ...)
dbinom2.or = function(mu1,
- mu2 = if (exchangeable) mu1 else stop("'mu2' not specified"),
+ mu2 = if (exchangeable) mu1 else
+ stop("'mu2' not specified"),
oratio = 1,
exchangeable = FALSE,
tol = 0.001,
colnames = c("00", "01", "10", "11"),
ErrorCheck = TRUE)
{
- if (ErrorCheck) {
- if (!is.Numeric(mu1, positive = TRUE) || max(mu1) >= 1)
- stop("bad input for argument 'mu1'")
- if (!is.Numeric(mu2, positive = TRUE) || max(mu2) >= 1)
- stop("bad input for argument 'mu2'")
- if (!is.Numeric(oratio, positive = TRUE))
- stop("bad input for argument 'oratio'")
- if (!is.Numeric(tol, positive = TRUE, allow=1) || tol > 0.1)
- stop("bad input for argument 'tol'")
- if (exchangeable && max(abs(mu1 - mu2)) > 0.00001)
- stop("argument 'exchangeable' is TRUE but 'mu1' and 'mu2' differ")
- }
-
- n = max(length(mu1), length(mu2), length(oratio))
- oratio = rep(oratio, len = n)
- mu1 = rep(mu1, len = n)
- mu2 = rep(mu2, len = n)
+ if (ErrorCheck) {
+ if (!is.Numeric(mu1, positive = TRUE) || max(mu1) >= 1)
+ stop("bad input for argument 'mu1'")
+ if (!is.Numeric(mu2, positive = TRUE) || max(mu2) >= 1)
+ stop("bad input for argument 'mu2'")
+ if (!is.Numeric(oratio, positive = TRUE))
+ stop("bad input for argument 'oratio'")
+ if (!is.Numeric(tol, positive = TRUE, allow = 1) || tol > 0.1)
+ stop("bad input for argument 'tol'")
+ if (exchangeable && max(abs(mu1 - mu2)) > 0.00001)
+ stop("argument 'exchangeable' is TRUE but 'mu1' and 'mu2' differ")
+ }
- a.temp = 1 + (mu1+mu2)*(oratio-1)
- b.temp = -4 * oratio * (oratio-1) * mu1 * mu2
- temp = sqrt(a.temp^2 + b.temp)
- p11 = ifelse(abs(oratio-1) < tol, mu1*mu2, (a.temp-temp)/(2*(oratio-1)))
- p01 = mu2 - p11
- p10 = mu1 - p11
- p00 = 1 - p11 - p01 - p10
- matrix(c(p00, p01, p10, p11), n, 4, dimnames = list(NULL, colnames))
+ n = max(length(mu1), length(mu2), length(oratio))
+ oratio = rep(oratio, len = n)
+ mu1 = rep(mu1, len = n)
+ mu2 = rep(mu2, len = n)
+
+ a.temp = 1 + (mu1+mu2)*(oratio-1)
+ b.temp = -4 * oratio * (oratio-1) * mu1 * mu2
+ temp = sqrt(a.temp^2 + b.temp)
+ p11 = ifelse(abs(oratio-1) < tol, mu1*mu2, (a.temp-temp)/(2*(oratio-1)))
+ p01 = mu2 - p11
+ p10 = mu1 - p11
+ p00 = 1 - p11 - p01 - p10
+ matrix(c(p00, p01, p10, p11), n, 4, dimnames = list(NULL, colnames))
}
rbinom2.or = function(n, mu1,
- mu2 = if (exchangeable) mu1 else stop("'mu2' not specified"),
+ mu2 = if (exchangeable) mu1 else
+ stop("'mu2' not specified"),
oratio = 1,
exchangeable = FALSE,
tol = 0.001,
@@ -363,7 +368,7 @@ rbinom2.or = function(n, mu1,
ErrorCheck = TRUE)
{
if (ErrorCheck) {
- if (!is.Numeric(n, integer = TRUE, posit = TRUE, allow=1))
+ if (!is.Numeric(n, integer = TRUE, posit = TRUE, allow = 1))
stop("bad input for argument 'n'")
if (!is.Numeric(mu1, positive = TRUE) || max(mu1) >= 1)
stop("bad input for argument 'mu1'")
@@ -371,7 +376,7 @@ rbinom2.or = function(n, mu1,
stop("bad input for argument 'mu2'")
if (!is.Numeric(oratio, positive = TRUE))
stop("bad input for argument 'oratio'")
- if (!is.Numeric(tol, positive = TRUE, allow=1) || tol > 0.1)
+ if (!is.Numeric(tol, positive = TRUE, allow = 1) || tol > 0.1)
stop("bad input for argument 'tol'")
if (exchangeable && max(abs(mu1 - mu2)) > 0.00001)
stop("argument 'exchangeable' is TRUE but 'mu1' and 'mu2' differ")
@@ -419,7 +424,7 @@ rbinom2.or = function(n, mu1,
if (is.logical(exchangeable) && exchangeable && ((lmu1 != lmu2) ||
!all.equal(emu1, emu2)))
stop("exchangeable = TRUE but marginal links are not equal")
- if (!is.Numeric(tol, positive = TRUE, allow=1) || tol > 0.1)
+ if (!is.Numeric(tol, positive = TRUE, allow = 1) || tol > 0.1)
stop("bad input for argument 'tol'")
if (!is.list(emu1)) emu1 = list()
if (!is.list(emu2)) emu2 = list()
@@ -464,7 +469,7 @@ rbinom2.or = function(n, mu1,
}), list( .lmu1 = lmu1, .lmu2 = lmu2, .loratio = loratio,
.emu1 = emu1, .emu2 = emu2, .eoratio = eoratio,
.imu1 = imu1, .imu2 = imu2, .ioratio = ioratio ))),
- inverse = eval(substitute(function(eta, extra = NULL) {
+ linkinv = eval(substitute(function(eta, extra = NULL) {
pmargin = cbind(eta2theta(eta[,1], .lmu1, earg = .emu1),
eta2theta(eta[,2], .lmu2, earg = .emu2))
oratio = eta2theta(eta[,3], .loratio, earg = .eoratio)
@@ -490,7 +495,7 @@ rbinom2.or = function(n, mu1,
}), list( .lmu1 = lmu1, .lmu2 = lmu2, .loratio = loratio,
.emu1 = emu1, .emu2 = emu2, .eoratio = eoratio,
.tol = tol ))),
- link = eval(substitute(function(mu, extra = NULL) {
+ linkfun = eval(substitute(function(mu, extra = NULL) {
pmargin = cbind(mu[,3]+mu[,4], mu[,2]+mu[,4])
oratio = mu[,4]*mu[,1] / (mu[,2]*mu[,3])
cbind(theta2eta(pmargin[,1], .lmu1, earg = .emu1),
@@ -626,7 +631,7 @@ rbinom2.rho = function(n, mu1,
ErrorCheck = TRUE)
{
if (ErrorCheck) {
- if (!is.Numeric(n, integer = TRUE, posit = TRUE, allow=1))
+ if (!is.Numeric(n, integer = TRUE, positive = TRUE, allow = 1))
stop("bad input for argument 'n'")
if (!is.Numeric(mu1, positive = TRUE) || max(mu1) >= 1)
stop("bad input for argument 'mu1'")
@@ -703,10 +708,10 @@ binom2.rho.control <- function(save.weight = TRUE, ...)
.exchangeable, constraints, intercept.apply = TRUE)
constraints = cm.zero.vgam(constraints, x, .zero, M)
}), list( .exchangeable = exchangeable, .zero = zero ))),
- deviance = Deviance.categorical.data.vgam,
initialize = eval(substitute(expression({
mustart.orig = mustart
eval(process.binomial2.data.vgam)
+
if (length(mustart.orig))
mustart = mustart.orig # Retain it if inputted
@@ -720,8 +725,8 @@ binom2.rho.control <- function(save.weight = TRUE, ...)
}
- ycounts = if (is.numeric(extra$orig.w)) y * w / extra$orig.w else
- y * w # Convert proportions to counts
+ ycounts = if (is.numeric(extra$orig.w)) y * c(w) / extra$orig.w else
+ y * c(w) # Convert proportions to counts
if (max(abs(ycounts - round(ycounts))) > 1.0e-6)
warning("the response (as counts) does not appear to ",
"be integer-valued. Am rounding to integer values.")
@@ -749,7 +754,7 @@ binom2.rho.control <- function(save.weight = TRUE, ...)
mu2.init = if (is.Numeric( .imu2 )) rep( .imu2, len = n) else
mu[,2] + mu[,4]
} else {
- stop("bad value for 'imethod'")
+ stop("bad value for argument 'imethod'")
}
@@ -788,6 +793,7 @@ binom2.rho.control <- function(save.weight = TRUE, ...)
rep( .irho, len = n) else {
try.this
}
+
etastart = cbind(theta2eta(mu1.init, .lmu12, earg = .emu12),
theta2eta(mu2.init, .lmu12, earg = .emu12),
theta2eta(rho.init, .lrho, earg = .erho))
@@ -797,7 +803,7 @@ binom2.rho.control <- function(save.weight = TRUE, ...)
.lrho = lrho, .erho = erho,
.imethod = imethod,
.imu1 = imu1, .imu2 = imu2, .irho = irho ))),
- inverse = eval(substitute(function(eta, extra = NULL) {
+ linkinv = eval(substitute(function(eta, extra = NULL) {
pmargin = cbind(eta2theta(eta[,1], .lmu12, earg = .emu12),
eta2theta(eta[,2], .lmu12, earg = .emu12))
rho = eta2theta(eta[,3], .lrho, earg = .erho)
@@ -821,8 +827,8 @@ binom2.rho.control <- function(save.weight = TRUE, ...)
if (residuals)
stop("loglikelihood residuals not implemented yet") else {
- ycounts = if (is.numeric(extra$orig.w)) y * w / extra$orig.w else
- y * w # Convert proportions to counts
+ ycounts = if (is.numeric(extra$orig.w)) y * c(w) / extra$orig.w else
+ y * c(w) # Convert proportions to counts
smallno = 1.0e4 * .Machine$double.eps
if (max(abs(ycounts - round(ycounts))) > smallno)
@@ -958,8 +964,8 @@ pnorm2 <- function(ah, ak, r) {
my.dbinom <- function(x,
- size = stop("no size arg"),
- prob = stop("no prob arg"))
+ size = stop("no 'size' argument"),
+ prob = stop("no 'prob' argument"))
{
exp( lgamma(size+1) - lgamma(size-x+1) - lgamma(x+1) +
@@ -990,7 +996,7 @@ my.dbinom <- function(x,
etastart <- theta2eta(nvec, .link)
}
}), list( .prob = prob, .link = link ))),
- inverse = eval(substitute(function(eta, extra = NULL) {
+ linkinv = eval(substitute(function(eta, extra = NULL) {
nvec <- eta2theta(eta, .link)
nvec * extra$temp2
}, list( .link = link ))),
@@ -998,7 +1004,7 @@ my.dbinom <- function(x,
misc$link <- c(size = .link)
misc$prob <- extra$temp2
}), list( .link = link ))),
- link = eval(substitute(function(mu, extra = NULL) {
+ linkfun = eval(substitute(function(mu, extra = NULL) {
nvec <- mu / extra$temp2
theta2eta(nvec, .link)
}, list( .link = link ))),
@@ -1031,17 +1037,22 @@ my.dbinom <- function(x,
- dbetabin.ab = function(x, size, shape1, shape2, log = FALSE) {
+ dbetabinom.ab = function(x, size, shape1, shape2, log = FALSE,
+ .dontuse.prob = NULL) {
+
+
log.arg = log
rm(log)
+
if (!is.Numeric(x))
stop("bad input for argument 'x'")
if (!is.Numeric(size, integer = TRUE))
stop("bad input for argument 'size'")
- if (!is.Numeric(shape1, pos = TRUE))
- stop("bad input for argument 'shape1'")
- if (!is.Numeric(shape2, pos = TRUE))
- stop("bad input for argument 'shape2'")
+ if (any(shape1 < 0, na.rm = TRUE))
+ stop("negative values for argument 'shape1' not allowed")
+ if (any(shape2 < 0, na.rm = TRUE))
+ stop("negative values for argument 'shape2' not allowed")
+
LLL = max(length(x), length(size), length(shape1), length(shape2))
if (length(x) != LLL) x = rep(x, len = LLL)
@@ -1049,29 +1060,56 @@ my.dbinom <- function(x,
if (length(shape1) != LLL) shape1 = rep(shape1, len = LLL)
if (length(shape2) != LLL) shape2 = rep(shape2, len = LLL)
- answer = 0 * x
- ok = (round(x) == x) & (x >= 0) & (x <= size)
- answer[ok] = lchoose(size[ok], x[ok]) +
- lbeta(shape1[ok] + x[ok], shape2[ok] + size[ok] - x[ok]) -
- lbeta(shape1[ok], shape2[ok])
- if (log.arg) {
- answer[!ok] = log(0.0)
- } else {
- answer[ok] = exp(answer[ok])
+ ans = 0 * x
+ ok = (round(x) == x) & (x >= 0) & (x <= size) &
+ is.finite(shape1) & is.finite(shape2)
+ if (any(ok)) {
+ ans[ok] = lchoose(size[ok], x[ok]) +
+ lbeta(shape1[ok] + x[ok], shape2[ok] + size[ok] - x[ok]) -
+ lbeta(shape1[ok], shape2[ok])
+ if (log.arg) {
+ } else {
+ ans[ok] = exp(ans[ok])
+ }
+ }
+
+ okay1 = is.na(shape1) & is.infinite(shape2) # rho = 0 and prob == 0
+ okay2 = is.infinite(shape1) & is.na(shape2) # rho = 0 and prob == 1
+ okay3 = is.infinite(shape1) & is.infinite(shape2) # rho = 0 and 0 < prob < 1
+
+ if (sum.okay1 <- sum(okay1))
+ ans[okay1] = dbinom(x = x[okay1], size = size[okay1],
+ prob = 0,
+ log = log.arg)
+ if (sum.okay2 <- sum(okay2))
+ ans[okay2] = dbinom(x = x[okay2], size = size[okay2],
+ prob = 1,
+ log = log.arg)
+ if (sum.okay3 <- sum(okay3)) {
+ if (length(.dontuse.prob) != LLL)
+ .dontuse.prob = rep(.dontuse.prob, len = LLL)
+ ans[okay3] = dbinom(x = x[okay3], size = size[okay3],
+ prob = .dontuse.prob[okay3],
+ log = log.arg)
}
- answer
+
+ ans
}
- pbetabin.ab = function(q, size, shape1, shape2, log.p = FALSE) {
+
+
+
+
+ pbetabinom.ab = function(q, size, shape1, shape2, log.p = FALSE) {
if (!is.Numeric(q))
stop("bad input for argument 'q'")
if (!is.Numeric(size, integer = TRUE))
stop("bad input for argument 'size'")
- if (!is.Numeric(shape1, pos = TRUE))
+ if (!is.Numeric(shape1, positive = TRUE))
stop("bad input for argument 'shape1'")
- if (!is.Numeric(shape2, pos = TRUE))
+ if (!is.Numeric(shape2, positive = TRUE))
stop("bad input for argument 'shape2'")
LLL = max(length(q), length(size), length(shape1), length(shape2))
@@ -1081,12 +1119,13 @@ my.dbinom <- function(x,
if (length(size) != LLL) size = rep(size, len = LLL);
ans = q * 0 # Retains names(q)
+
if (max(abs(size - size[1])) < 1.0e-08 &&
max(abs(shape1 - shape1[1])) < 1.0e-08 &&
max(abs(shape2 - shape2[1])) < 1.0e-08) {
qstar = floor(q)
temp = if (max(qstar) >= 0) {
- dbetabin.ab(0:max(qstar), size = size[1], shape1 = shape1[1],
+ dbetabinom.ab(0:max(qstar), size = size[1], shape1 = shape1[1],
shape2 = shape2[1])
} else {
0 * qstar
@@ -1100,7 +1139,7 @@ my.dbinom <- function(x,
for (ii in 1:LLL) {
qstar = floor(q[ii])
ans[ii] = if (qstar >= 0) {
- sum(dbetabin.ab(x = 0:qstar, size = size[ii],
+ sum(dbetabinom.ab(x = 0:qstar, size = size[ii],
shape1 = shape1[ii], shape2 = shape2[ii]))
} else 0
}
@@ -1110,42 +1149,76 @@ my.dbinom <- function(x,
- rbetabin.ab = function(n, size, shape1, shape2) {
+ rbetabinom.ab = function(n, size, shape1, shape2, .dontuse.prob = NULL) {
+
if (!is.Numeric(size, integer = TRUE))
stop("bad input for argument 'size'")
- if (!is.Numeric(shape1, pos = TRUE))
- stop("bad input for argument 'shape1'")
- if (!is.Numeric(shape2, pos = TRUE))
- stop("bad input for argument 'shape2'")
+ if (any(shape1 < 0, na.rm = TRUE))
+ stop("negative values for argument 'shape1' not allowed")
+ if (any(shape2 < 0, na.rm = TRUE))
+ stop("negative values for argument 'shape2' not allowed")
use.n = if ((length.n <- length(n)) > 1) length.n else
- if (!is.Numeric(n, integ = TRUE, allow = 1, posit = TRUE))
+ if (!is.Numeric(n, integ = TRUE, allow = 1, positive = TRUE))
stop("bad input for argument 'n'") else n
if (length(size) != use.n) size = rep(size, len = use.n)
if (length(shape1) != use.n) shape1 = rep(shape1, len = use.n)
if (length(shape2) != use.n) shape2 = rep(shape2, len = use.n)
- rbinom(n = use.n, size = size,
- prob = rbeta(n = use.n, shape1 = shape1, shape2 = shape2))
+
+ ans = rep(as.numeric(NA), len = use.n)
+ okay0 = is.finite(shape1) & is.finite(shape2)
+ if (smalln <- sum(okay0))
+ ans[okay0] = rbinom(n = smalln, size = size[okay0],
+ prob = rbeta(n = smalln, shape1 = shape1[okay0],
+ shape2 = shape2[okay0]))
+
+ okay1 = is.na(shape1) & is.infinite(shape2) # rho = 0 and prob == 0
+ okay2 = is.infinite(shape1) & is.na(shape2) # rho = 0 and prob == 1
+ okay3 = is.infinite(shape1) & is.infinite(shape2) # rho = 0 and 0 < prob < 1
+
+ if (sum.okay1 <- sum(okay1))
+ ans[okay1] = rbinom(n = sum.okay1, size = size[okay1],
+ prob = 0)
+ if (sum.okay2 <- sum(okay2))
+ ans[okay2] = rbinom(n = sum.okay2, size = size[okay2],
+ prob = 1)
+ if (sum.okay3 <- sum(okay3)) {
+ if (length(.dontuse.prob) != use.n)
+ .dontuse.prob = rep(.dontuse.prob, len = use.n)
+ ans[okay3] = rbinom(n = sum.okay3, size = size[okay3],
+ prob = .dontuse.prob[okay3])
+ }
+
+ ans
}
- dbetabin = function(x, size, prob, rho, log = FALSE) {
- dbetabin.ab(x=x, size = size, shape1 = prob*(1-rho)/rho,
- shape2 = (1-prob)*(1-rho)/rho, log = log)
+
+
+
+
+ dbetabinom = function(x, size, prob, rho = 0, log = FALSE) {
+ dbetabinom.ab(x = x, size = size, shape1 = prob*(1-rho)/rho,
+ shape2 = (1-prob)*(1-rho)/rho, log = log,
+ .dontuse.prob = prob)
}
- pbetabin = function(q, size, prob, rho, log.p = FALSE) {
- pbetabin.ab(q = q, size = size, shape1 = prob*(1-rho)/rho,
+
+ pbetabinom = function(q, size, prob, rho, log.p = FALSE) {
+ pbetabinom.ab(q = q, size = size, shape1 = prob*(1-rho)/rho,
shape2 = (1-prob)*(1-rho)/rho, log.p = log.p)
}
- rbetabin = function(n, size, prob, rho) {
- rbetabin.ab(n = n, size = size, shape1 = prob*(1-rho)/rho,
- shape2 = (1-prob)*(1-rho)/rho)
+
+ rbetabinom = function(n, size, prob, rho = 0) {
+ rbetabinom.ab(n = n, size = size, shape1 = prob*(1-rho)/rho,
+ shape2 = (1-prob)*(1-rho)/rho,
+ .dontuse.prob = prob)
}
+
expected.betabin.ab = function(nvec, shape1, shape2, first) {
NN = length(nvec)
@@ -1154,17 +1227,19 @@ my.dbinom <- function(x,
for (ii in 1:NN) {
temp639 = lbeta(shape1[ii], shape2[ii])
yy = 0:nvec[ii]
- ans[ii] = ans[ii] + sum(trigamma(shape1[ii]+yy) *
+ ans[ii] = ans[ii] + sum(trigamma(shape1[ii] + yy) *
exp(lchoose(nvec[ii], yy) +
- lbeta(shape1[ii]+yy, shape2[ii]+nvec[ii]-yy) - temp639))
+ lbeta(shape1[ii]+yy, shape2[ii]+nvec[ii]-yy) -
+ temp639))
}
} else {
for (ii in 1:NN) {
temp639 = lbeta(shape1[ii], shape2[ii])
yy = 0:nvec[ii]
- ans[ii] = ans[ii] + sum(trigamma(nvec[ii]+shape2[ii]-yy) *
+ ans[ii] = ans[ii] + sum(trigamma(nvec[ii]+shape2[ii] - yy) *
exp(lchoose(nvec[ii], yy) +
- lbeta(shape1[ii]+yy, shape2[ii]+nvec[ii]-yy) - temp639))
+ lbeta(shape1[ii]+yy, shape2[ii]+nvec[ii]-yy) -
+ temp639))
}
}
ans
@@ -1172,32 +1247,34 @@ my.dbinom <- function(x,
-betabin.ab.control <- function(save.weight = TRUE, ...)
-{
+betabinomial.ab.control <- function(save.weight = TRUE, ...) {
list(save.weight = save.weight)
}
- betabin.ab = function(lshape12 = "loge", earg = list(),
+ betabinomial.ab = function(lshape12 = "loge", earg = list(),
i1 = 1, i2 = NULL, imethod = 1,
shrinkage.init = 0.95, nsimEIM = NULL, zero = NULL) {
if (mode(lshape12) != "character" && mode(lshape12) != "name")
lshape12 = as.character(substitute(lshape12))
- if (!is.Numeric(i1, positive = TRUE)) stop("bad input for argument 'i1'")
- if (length(i2) && !is.Numeric(i2, pos = TRUE))
- stop("bad input for argument 'i2'")
+ if (!is.Numeric(i1, positive = TRUE))
+ stop("bad input for argument 'i1'")
+ if (!is.Numeric(imethod, allow = 1, integ = TRUE, positive = TRUE) ||
+ imethod > 3)
+ stop("argument 'imethod' must be 1, 2 or 3")
+
+ if (length(i2) && !is.Numeric(i2, positive = TRUE))
+ stop("bad input for argument 'i2'")
if (!is.list(earg)) earg = list()
+
if (!is.null(nsimEIM)) {
- if (!is.Numeric(nsimEIM, allow=1, integ = TRUE))
- stop("bad input for argument 'nsimEIM'")
- if (nsimEIM <= 10)
- warning("'nsimEIM' should be an integer greater than 10, say")
+ if (!is.Numeric(nsimEIM, allow = 1, integ = TRUE))
+ stop("bad input for argument 'nsimEIM'")
+ if (nsimEIM <= 10)
+ warning("'nsimEIM' should be an integer greater than 10, say")
}
- if (!is.Numeric(imethod, allow=1, integ = TRUE, posit = TRUE) ||
- imethod > 3)
- stop("argument 'imethod' must be 1, 2 or 3")
new("vglmff",
blurb = c("Beta-binomial model\n",
@@ -1258,7 +1335,7 @@ betabin.ab.control <- function(save.weight = TRUE, ...)
}), list( .lshape12 = lshape12, .earg = earg, .i1 = i1, .i2 = i2,
.nsimEIM = nsimEIM,
.imethod = imethod, .sinit = shrinkage.init ))),
- inverse = eval(substitute(function(eta, extra = NULL) {
+ linkinv = eval(substitute(function(eta, extra = NULL) {
shape1 = eta2theta(eta[,1], .lshape12, earg = .earg)
shape2 = eta2theta(eta[,2], .lshape12, earg = .earg)
shape1 / (shape1 + shape2)
@@ -1271,7 +1348,9 @@ betabin.ab.control <- function(save.weight = TRUE, ...)
misc$rho = 1 / (shape1 + shape2 + 1)
misc$expected = TRUE
misc$nsimEIM = .nsimEIM
- }), list( .lshape12 = lshape12, .earg = earg, .nsimEIM = nsimEIM ))),
+ misc$zero <- .zero
+ }), list( .lshape12 = lshape12, .earg = earg, .nsimEIM = nsimEIM,
+ .zero = zero ))),
loglikelihood = eval(substitute(
function(mu,y,w,residuals = FALSE,eta, extra = NULL) {
ycounts = if (is.numeric(extra$orig.w)) y * w / extra$orig.w else
@@ -1289,11 +1368,11 @@ betabin.ab.control <- function(save.weight = TRUE, ...)
if (residuals)
stop("loglikelihood residuals not implemented yet") else {
sum((if (is.numeric(extra$orig.w)) extra$orig.w else 1) *
- dbetabin.ab(x = ycounts, size = nvec, shape1 = shape1,
+ dbetabinom.ab(x = ycounts, size = nvec, shape1 = shape1,
shape2 = shape2, log = TRUE ))
}
}, list( .lshape12 = lshape12, .earg = earg ))),
- vfamily = c("betabin.ab"),
+ vfamily = c("betabinomial.ab"),
deriv = eval(substitute(expression({
nvec = if (is.numeric(extra$orig.w)) round(w / extra$orig.w) else
round(w)
@@ -1334,7 +1413,7 @@ betabin.ab.control <- function(save.weight = TRUE, ...)
dthetas.detas = cbind(dshape1.deta, dshape2.deta)
for (ii in 1:( .nsimEIM )) {
- ysim = rbetabin.ab(n = n, size=nvec, shape1 = shape1,
+ ysim = rbetabinom.ab(n = n, size = nvec, shape1 = shape1,
shape2 = shape2)
dl.dshape1 = digamma(shape1+ysim) -
digamma(shape1+shape2+nvec) -
@@ -1372,7 +1451,7 @@ betabin.ab.control <- function(save.weight = TRUE, ...)
stop("bad input for argument 'ishape'")
if (!is.Numeric(moreSummation, positive = TRUE, allow=2, integ = TRUE))
stop("bad input for argument 'moreSummation'")
- if (!is.Numeric(tolerance, positive = TRUE, allow=1) ||
+ if (!is.Numeric(tolerance, positive = TRUE, allow = 1) ||
1.0-tolerance >= 1.0)
stop("bad input for argument 'tolerance'")
if (!is.list(eprob)) eprob = list()
@@ -1400,7 +1479,7 @@ betabin.ab.control <- function(save.weight = TRUE, ...)
}), list( .iprob=iprob, .ishape=ishape, .lprob = lprob,
.eprob = eprob, .eshape = eshape,
.lshape = lshape ))),
- inverse = eval(substitute(function(eta, extra = NULL) {
+ linkinv = eval(substitute(function(eta, extra = NULL) {
prob = eta2theta(eta[,1], .lprob, earg = .eprob)
shape = eta2theta(eta[,2], .lshape, earg = .eshape)
mymu = (1-prob) / (prob - shape)
@@ -1557,7 +1636,7 @@ seq2binomial = function(lprob1 = "logit", lprob2 = "logit",
}), list( .iprob1 = iprob1, .iprob2 = iprob2,
.lprob1 = lprob1, .lprob2 = lprob2,
.eprob1 = eprob1, .eprob2 = eprob2 ))),
- inverse = eval(substitute(function(eta, extra = NULL) {
+ linkinv = eval(substitute(function(eta, extra = NULL) {
prob1 = eta2theta(eta[,1], .lprob1, earg = .eprob1)
prob2 = eta2theta(eta[,2], .lprob2, earg = .eprob2)
cbind(prob1, prob2)
@@ -1630,9 +1709,9 @@ zipebcom = function(lmu12 = "cloglog", lphi12 = "logit", loratio = "loge",
lphi12 = as.character(substitute(lphi12))
if (mode(loratio) != "character" && mode(loratio) != "name")
loratio = as.character(substitute(loratio))
- if (!is.Numeric(tol, positive = TRUE, allow=1) || tol > 0.1)
+ if (!is.Numeric(tol, positive = TRUE, allow = 1) || tol > 0.1)
stop("bad input for argument 'tol'")
- if (!is.Numeric(addRidge, allow=1, posit = TRUE) || addRidge > 0.5)
+ if (!is.Numeric(addRidge, allow = 1, positive = TRUE) || addRidge > 0.5)
stop("bad input for argument 'addRidge'")
if (!is.list(emu12)) emu12 = list()
if (!is.list(ephi12)) ephi12 = list()
@@ -1681,7 +1760,7 @@ zipebcom = function(lmu12 = "cloglog", lphi12 = "logit", loratio = "loge",
}), list( .lmu12 = lmu12, .lphi12 = lphi12, .loratio = loratio,
.emu12 = emu12, .ephi12 = ephi12, .eoratio = eoratio,
.imu12 = imu12, .iphi12 = iphi12, .ioratio = ioratio ))),
- inverse = eval(substitute(function(eta, extra = NULL) {
+ linkinv = eval(substitute(function(eta, extra = NULL) {
A1vec = eta2theta(eta[,1], .lmu12, earg = .emu12)
phivec = eta2theta(eta[,2], .lphi12, earg = .ephi12)
pmargin = matrix((1 - phivec) * A1vec, nrow(eta), 2)
@@ -1853,7 +1932,7 @@ if (FALSE)
.erhopos = erhopos, .erhoneg = erhoneg,
.iprob1 = iprob1, .iprob2 = iprob2,
.irhopos = irhopos, .irhoneg = irhoneg ))),
- inverse = eval(substitute(function(eta, extra = NULL) {
+ linkinv = eval(substitute(function(eta, extra = NULL) {
rhopos = eta2theta(eta[,1], .lrhopos, earg = .erhopos)
rhoneg = eta2theta(eta[,2], .lrhoneg, earg = .erhoneg)
pee2 = (1 - rhoneg) / (rhopos - rhoneg)
@@ -1970,11 +2049,6 @@ if (FALSE)
wz[, iam(2, 2, M)] = wz[, iam(2, 2, M)] * drhoneg.deta^2
wz[, iam(1, 2, M)] = wz[, iam(1, 2, M)] * drhopos.deta * drhoneg.deta
- print("summary(wz)")
- print( summary(wz) )
- print("head(wz)")
- print( head(wz) )
-
wz
}), list( .lrhopos = lrhopos, .lrhoneg = lrhoneg,
.erhopos = erhopos, .erhoneg = erhoneg,
@@ -1989,14 +2063,14 @@ if (FALSE)
binom2.Rho = function(rho = 0, imu1 = NULL, imu2 = NULL,
exchangeable = FALSE, nsimEIM = NULL)
{
- lmu12 = "probit"
- emu12 = list()
- if (is.Numeric(nsimEIM)) {
- if (!is.Numeric(nsimEIM, allow=1, integ = TRUE))
- stop("bad input for argument 'nsimEIM'")
- if (nsimEIM <= 100)
- warning("'nsimEIM' should be an integer greater than 100")
- }
+ lmu12 = "probit"
+ emu12 = list()
+ if (is.Numeric(nsimEIM)) {
+ if (!is.Numeric(nsimEIM, allow = 1, integ = TRUE))
+ stop("bad input for argument 'nsimEIM'")
+ if (nsimEIM <= 100)
+ warning("'nsimEIM' should be an integer greater than 100")
+ }
new("vglmff",
blurb = c("Bivariate probit model with rho = ", format(rho), "\n",
@@ -2027,7 +2101,7 @@ if (FALSE)
}
}), list( .lmu12 = lmu12, .emu12 = emu12, .nsimEIM = nsimEIM,
.imu1 = imu1, .imu2 = imu2 ))),
- inverse = eval(substitute(function(eta, extra = NULL) {
+ linkinv = eval(substitute(function(eta, extra = NULL) {
pmargin = cbind(eta2theta(eta[,1], .lmu12, earg = .emu12),
eta2theta(eta[,2], .lmu12, earg = .emu12))
rhovec = rep( .rho, len = nrow(eta))
diff --git a/R/family.bivariate.R b/R/family.bivariate.R
index 428caef..909b972 100644
--- a/R/family.bivariate.R
+++ b/R/family.bivariate.R
@@ -33,9 +33,9 @@ bilogistic4.control <- function(save.weight = TRUE, ...)
blurb = c("Bivariate logistic distribution\n\n",
"Link: ",
namesof("location1", llocation), ", ",
- namesof("scale1", lscale), ", ",
+ namesof("scale1", lscale), ", ",
namesof("location2", llocation), ", ",
- namesof("scale2", lscale),
+ namesof("scale2", lscale),
"\n", "\n",
"Means: location1, location2"),
constraints = eval(substitute(expression({
@@ -54,13 +54,13 @@ bilogistic4.control <- function(save.weight = TRUE, ...)
if ( .imethod == 1) {
location.init1 = y[, 1]
scale.init1 = sqrt(3) * sd(y[, 1]) / pi
- location.init2 = y[,2]
- scale.init2 = sqrt(3) * sd(y[,2]) / pi
+ location.init2 = y[, 2]
+ scale.init2 = sqrt(3) * sd(y[, 2]) / pi
} else {
location.init1 = median(rep(y[, 1], w))
- location.init2 = median(rep(y[,2], w))
+ location.init2 = median(rep(y[, 2], w))
scale.init1=sqrt(3)*sum(w*(y[, 1]-location.init1)^2)/(sum(w)*pi)
- scale.init2=sqrt(3)*sum(w*(y[,2]-location.init2)^2)/(sum(w)*pi)
+ scale.init2=sqrt(3)*sum(w*(y[, 2]-location.init2)^2)/(sum(w)*pi)
}
loc1.init = if (length(.iloc1)) rep(.iloc1, len = n) else
rep(location.init1, len = n)
@@ -80,8 +80,8 @@ bilogistic4.control <- function(save.weight = TRUE, ...)
}), list(.imethod = imethod, .iloc1=iloc1, .iloc2=iloc2,
.llocation=llocation,
.iscale1=iscale1, .iscale2=iscale2, .lscale=lscale))),
- inverse=function(eta, extra = NULL) {
- cbind(eta[, 1], eta[,2])
+ linkinv = function(eta, extra = NULL) {
+ cbind(eta[, 1], eta[, 2])
},
last = eval(substitute(expression({
misc$link = c(location1= .llocation, scale1= .lscale,
@@ -92,11 +92,11 @@ bilogistic4.control <- function(save.weight = TRUE, ...)
loglikelihood = eval(substitute(
function(mu,y,w,residuals= FALSE,eta, extra = NULL) {
loc1 = eta2theta(eta[, 1], .llocation)
- Scale1 = eta2theta(eta[,2], .lscale)
- loc2 = eta2theta(eta[,3], .llocation)
- Scale2 = eta2theta(eta[,4], .lscale)
+ Scale1 = eta2theta(eta[, 2], .lscale)
+ loc2 = eta2theta(eta[, 3], .llocation)
+ Scale2 = eta2theta(eta[, 4], .lscale)
zedd1 = (y[, 1]-loc1) / Scale1
- zedd2 = (y[,2]-loc2) / Scale2
+ zedd2 = (y[, 2]-loc2) / Scale2
if (residuals) stop("loglikelihood residuals not ",
"implemented yet") else
sum(w * (-zedd1 - zedd2 - 3 * log1p(exp(-zedd1)+exp(-zedd2)) -
@@ -105,11 +105,11 @@ bilogistic4.control <- function(save.weight = TRUE, ...)
vfamily = c("bilogistic4"),
deriv = eval(substitute(expression({
loc1 = eta2theta(eta[, 1], .llocation)
- Scale1 = eta2theta(eta[,2], .lscale)
- loc2 = eta2theta(eta[,3], .llocation)
- Scale2 = eta2theta(eta[,4], .lscale)
+ Scale1 = eta2theta(eta[, 2], .lscale)
+ loc2 = eta2theta(eta[, 3], .llocation)
+ Scale2 = eta2theta(eta[, 4], .lscale)
zedd1 = (y[, 1]-loc1) / Scale1
- zedd2 = (y[,2]-loc2) / Scale2
+ zedd2 = (y[, 2]-loc2) / Scale2
ezedd1 = exp(-zedd1)
ezedd2 = exp(-zedd2)
denom = 1 + ezedd1 + ezedd2
@@ -149,27 +149,11 @@ bilogistic4.control <- function(save.weight = TRUE, ...)
-rbilogis4 = function(n, loc1=0, scale1 = 1, loc2=0, scale2 = 1) {
- if (!is.Numeric(n, posit = TRUE,allow = 1,integ = TRUE)) stop("bad input for 'n'")
- if (!is.Numeric(scale1, posit = TRUE)) stop("bad input for 'scale1'")
- if (!is.Numeric(scale2, posit = TRUE)) stop("bad input for 'scale2'")
- y1 = rlogis(n, loc=loc1, scale=scale1)
- ezedd1 = exp(-(y1-loc1)/scale1)
- y2 = loc2 - scale2 * log(1/sqrt(runif(n) / (1 + ezedd1)^2) - 1 - ezedd1)
- cbind(y1, y2)
-}
-
-pbilogis4 = function(q1, q2, loc1=0, scale1 = 1, loc2=0, scale2 = 1) {
- if (!is.Numeric(q1)) stop("bad input for 'q1'")
- if (!is.Numeric(q2)) stop("bad input for 'q2'")
- if (!is.Numeric(scale1, posit = TRUE)) stop("bad input for 'scale1'")
- if (!is.Numeric(scale2, posit = TRUE)) stop("bad input for 'scale2'")
- 1 / (1 + exp(-(q1-loc1)/scale1) + exp(-(q2-loc2)/scale2))
-}
-dbilogis4 = function(x1, x2, loc1=0, scale1 = 1, loc2=0, scale2 = 1, log = FALSE) {
+dbilogis4 = function(x1, x2, loc1 = 0, scale1 = 1,
+ loc2 = 0, scale2 = 1, log = FALSE) {
if (!is.logical(log.arg <- log))
stop("bad input for argument 'log'")
rm(log)
@@ -189,125 +173,180 @@ dbilogis4 = function(x1, x2, loc1=0, scale1 = 1, loc2=0, scale2 = 1, log = FALSE
+pbilogis4 = function(q1, q2, loc1 = 0, scale1 = 1, loc2 = 0, scale2 = 1) {
+ if (!is.Numeric(q1)) stop("bad input for 'q1'")
+ if (!is.Numeric(q2)) stop("bad input for 'q2'")
+ if (!is.Numeric(scale1, posit = TRUE)) stop("bad input for 'scale1'")
+ if (!is.Numeric(scale2, posit = TRUE)) stop("bad input for 'scale2'")
+
+
+ 1 / (1 + exp(-(q1-loc1)/scale1) + exp(-(q2-loc2)/scale2))
+}
+
+
+
+rbilogis4 = function(n, loc1 = 0, scale1 = 1, loc2 = 0, scale2 = 1) {
+ if (!is.Numeric(n, posit = TRUE,allow = 1,integ = TRUE)) stop("bad input for 'n'")
+ if (!is.Numeric(scale1, posit = TRUE)) stop("bad input for 'scale1'")
+ if (!is.Numeric(scale2, posit = TRUE)) stop("bad input for 'scale2'")
+ y1 = rlogis(n, loc=loc1, scale=scale1)
+ ezedd1 = exp(-(y1-loc1)/scale1)
+ y2 = loc2 - scale2 * log(1/sqrt(runif(n) / (1 + ezedd1)^2) - 1 - ezedd1)
+ cbind(y1, y2)
+}
+
+
- freund61 = function(la = "loge",
+ freund61 = function(la = "loge",
lap = "loge",
- lb = "loge",
+ lb = "loge",
lbp = "loge",
+ ea = list(),
+ eap = list(),
+ eb = list(),
+ ebp = list(),
ia = NULL, iap = NULL, ib = NULL, ibp = NULL,
independent = FALSE,
zero = NULL) {
- if (mode(la) != "character" && mode(la) != "name")
- la = as.character(substitute(la))
- if (mode(lap) != "character" && mode(lap) != "name")
- lap = as.character(substitute(lap))
- if (mode(lb) != "character" && mode(lb) != "name")
- lb = as.character(substitute(lb))
- if (mode(lbp) != "character" && mode(lbp) != "name")
- lbp = as.character(substitute(lbp))
+ if (mode(la) != "character" && mode(la) != "name")
+ la = as.character(substitute(la))
+ if (mode(lap) != "character" && mode(lap) != "name")
+ lap = as.character(substitute(lap))
+ if (mode(lb) != "character" && mode(lb) != "name")
+ lb = as.character(substitute(lb))
+ if (mode(lbp) != "character" && mode(lbp) != "name")
+ lbp = as.character(substitute(lbp))
+
+ if (!is.list(ea )) ea = list()
+ if (!is.list(eap)) eap = list()
+ if (!is.list(eb )) eb = list()
+ if (!is.list(ebp)) ebp = list()
- new("vglmff",
- blurb = c("Freund (1961) bivariate exponential distribution\n",
- "Links: ",
- namesof("a", la), ", ",
- namesof("ap", lap), ", ",
- namesof("b", lb), ", ",
- namesof("bp", lbp)),
- constraints = eval(substitute(expression({
- constraints <- cm.vgam(matrix(c(1,1,0,0, 0,0,1,1),M,2), x,
- .independent, constraints, intercept.apply = TRUE)
- constraints = cm.zero.vgam(constraints, x, .zero, M)
- }), list(.independent=independent, .zero = zero))),
- initialize = eval(substitute(expression({
- if (!is.matrix(y) || ncol(y) != 2)
- stop("the response must be a 2 column matrix")
- predictors.names = c(namesof("a", .la, short = TRUE),
- namesof("ap", .lap, short = TRUE),
- namesof("b", .lb, short = TRUE),
- namesof("bp", .lbp, short = TRUE))
- extra$y1.lt.y2 = y[, 1] < y[,2]
- if (!(arr <- sum(extra$y1.lt.y2)) || arr==n)
- stop("identifiability problem: either all y1<y2 or y2<y1")
- if (!length(etastart)) {
- sumx = sum(y[extra$y1.lt.y2, 1]); sumxp = sum(y[!extra$y1.lt.y2, 1])
- sumy = sum(y[extra$y1.lt.y2,2]); sumyp = sum(y[!extra$y1.lt.y2,2])
- if (FALSE) { # Noise:
- arr = min(arr + n/10, n*0.95)
- sumx = sumx * 1.1; sumxp = sumxp * 1.2;
- sumy = sumy * 1.2; sumyp = sumyp * 1.3;
- }
- ainit = if (length(.ia)) rep(.ia, len = n) else arr / (sumx + sumyp)
- apinit = if (length(.iap)) rep(.iap,len = n) else (n-arr)/(sumxp-sumyp)
- binit = if (length(.ib)) rep(.ib, len = n) else (n-arr)/(sumx +sumyp)
- bpinit = if (length(.ib)) rep(.ibp,len = n) else arr / (sumy - sumx)
- etastart = cbind(theta2eta(rep(ainit, len = n), .la),
- theta2eta(rep(apinit, len = n), .lap),
- theta2eta(rep(binit, len = n), .lb),
- theta2eta(rep(bpinit, len = n), .lbp))
+ new("vglmff",
+ blurb = c("Freund (1961) bivariate exponential distribution\n",
+ "Links: ",
+ namesof("a", la, earg = ea ), ", ",
+ namesof("ap", lap, earg = eap), ", ",
+ namesof("b", lb, earg = eb ), ", ",
+ namesof("bp", lbp, earg = ebp)),
+ constraints = eval(substitute(expression({
+ constraints <- cm.vgam(matrix(c(1, 1,0,0, 0,0, 1, 1), M, 2), x,
+ .independent, constraints,
+ intercept.apply = TRUE)
+ constraints = cm.zero.vgam(constraints, x, .zero, M)
+ }), list(.independent = independent, .zero = zero))),
+ initialize = eval(substitute(expression({
+ if (!is.matrix(y) || ncol(y) != 2)
+ stop("the response must be a 2 column matrix")
+
+ predictors.names =
+ c(namesof("a", .la, earg = .ea , short = TRUE),
+ namesof("ap", .lap, earg = .eap, short = TRUE),
+ namesof("b", .lb, earg = .eb , short = TRUE),
+ namesof("bp", .lbp, earg = .ebp, short = TRUE))
+ extra$y1.lt.y2 = y[, 1] < y[, 2]
+
+ if (!(arr <- sum(extra$y1.lt.y2)) || arr==n)
+ stop("identifiability problem: either all y1<y2 or y2<y1")
+
+ if (!length(etastart)) {
+ sumx = sum(y[extra$y1.lt.y2, 1]); sumxp = sum(y[!extra$y1.lt.y2, 1])
+ sumy = sum(y[extra$y1.lt.y2, 2]); sumyp = sum(y[!extra$y1.lt.y2, 2])
+ if (FALSE) { # Noise:
+ arr = min(arr + n/10, n*0.95)
+ sumx = sumx * 1.1; sumxp = sumxp * 1.2;
+ sumy = sumy * 1.2; sumyp = sumyp * 1.3;
}
- }), list(.la=la, .lap=lap, .lb=lb, .lbp=lbp, .ia=ia, .iap=iap,
- .ib=ib, .ibp=ibp))),
- inverse = eval(substitute(function(eta, extra = NULL) {
- alpha = eta2theta(eta[, 1], .la)
- alphap = eta2theta(eta[,2], .lap)
- beta = eta2theta(eta[,3], .lb)
- betap = eta2theta(eta[,4], .lbp)
- cbind((alphap+beta) / (alphap*(alpha+beta)),
- (alpha+betap) / (betap*(alpha+beta)))
- }, list(.la=la, .lap=lap, .lb=lb, .lbp=lbp))),
- last = eval(substitute(expression({
- misc$link = c("a"= .la, "ap"= .lap, "b"= .lb, "bp"= .lbp)
- }), list(.la=la, .lap=lap, .lb=lb, .lbp=lbp))),
- loglikelihood = eval(substitute(
- function(mu, y, w, residuals = FALSE, eta, extra = NULL) {
- alpha = eta2theta(eta[, 1], .la)
- alphap = eta2theta(eta[,2], .lap)
- beta = eta2theta(eta[,3], .lb)
- betap = eta2theta(eta[,4], .lbp)
- if (residuals) stop("loglikelihood residuals not ",
- "implemented yet") else {
- tmp88 = extra$y1.lt.y2
- ell1 = log(alpha[tmp88]) + log(betap[tmp88]) -
- betap[tmp88] * y[tmp88,2] -
- (alpha+beta-betap)[tmp88] * y[tmp88, 1]
- ell2 = log(beta[!tmp88]) + log(alphap[!tmp88]) -
- alphap[!tmp88] * y[!tmp88, 1] -
- (alpha+beta-alphap)[!tmp88] * y[!tmp88,2]
- sum(w[tmp88] * ell1) + sum(w[!tmp88] * ell2) }
- }, list(.la=la, .lap=lap, .lb=lb, .lbp=lbp))),
- vfamily = c("freund61"),
- deriv = eval(substitute(expression({
+ ainit = if (length(.ia)) rep(.ia, len = n) else
+ arr / (sumx + sumyp)
+ apinit = if (length(.iap)) rep(.iap,len = n) else
+ (n-arr)/(sumxp-sumyp)
+ binit = if (length(.ib)) rep(.ib, len = n) else
+ (n-arr)/(sumx +sumyp)
+ bpinit = if (length(.ib)) rep(.ibp,len = n) else
+ arr / (sumy - sumx)
+
+ etastart =
+ cbind(theta2eta(rep(ainit, len = n), .la, earg = .ea ),
+ theta2eta(rep(apinit, len = n), .lap, earg = .eap ),
+ theta2eta(rep(binit, len = n), .lb, earg = .eb ),
+ theta2eta(rep(bpinit, len = n), .lbp, earg = .ebp ))
+ }
+ }), list(.la = la, .lap = lap, .lb = lb, .lbp = lbp,
+ .ea = ea, .eap = eap, .eb = eb, .ebp = ebp,
+ .ia = ia, .iap = iap, .ib = ib, .ibp = ibp))),
+ linkinv = eval(substitute(function(eta, extra = NULL) {
+ alpha = eta2theta(eta[, 1], .la, earg = .ea )
+ alphap = eta2theta(eta[, 2], .lap, earg = .eap )
+ beta = eta2theta(eta[, 3], .lb, earg = .eb )
+ betap = eta2theta(eta[, 4], .lbp, earg = .ebp )
+ cbind((alphap+beta) / (alphap*(alpha+beta)),
+ (alpha+betap) / (betap*(alpha+beta)))
+ }, list(.la = la, .lap = lap, .lb = lb, .lbp = lbp,
+ .ea = ea, .eap = eap, .eb = eb, .ebp = ebp ))),
+ last = eval(substitute(expression({
+ misc$link = c("a"= .la, "ap"= .lap, "b"= .lb, "bp"= .lbp)
+ }), list(.la = la, .lap = lap, .lb = lb, .lbp = lbp))),
+ loglikelihood = eval(substitute(
+ function(mu, y, w, residuals = FALSE, eta, extra = NULL) {
+ alpha = eta2theta(eta[, 1], .la, earg = .ea )
+ alphap = eta2theta(eta[, 2], .lap, earg = .eap )
+ beta = eta2theta(eta[, 3], .lb, earg = .eb )
+ betap = eta2theta(eta[, 4], .lbp, earg = .ebp )
+ if (residuals) stop("loglikelihood residuals not ",
+ "implemented yet") else {
tmp88 = extra$y1.lt.y2
- alpha = eta2theta(eta[, 1], .la)
- alphap = eta2theta(eta[,2], .lap)
- beta = eta2theta(eta[,3], .lb)
- betap = eta2theta(eta[,4], .lbp)
- d1 = 1/alpha - y[, 1]
- d1[!tmp88] = -y[!tmp88,2]
- d2 = 0 * alphap
- d2[!tmp88] = 1/alphap[!tmp88] - y[!tmp88, 1] + y[!tmp88,2]
- d3 = -y[, 1]
- d3[!tmp88] = 1/beta[!tmp88] - y[!tmp88,2]
- d4 = 1/betap - y[,2] + y[, 1]
- d4[!tmp88] = 0
- c(w) * cbind(d1 * dtheta.deta(alpha, .la),
- d2 * dtheta.deta(alphap, .lap),
- d3 * dtheta.deta(beta, .lb),
- d4 * dtheta.deta(betap, .lbp))
- }), list(.la=la, .lap=lap, .lb=lb, .lbp=lbp))),
- weight = eval(substitute(expression({
- py1.lt.y2 = alpha / (alpha+beta)
- d11 = py1.lt.y2 / alpha^2
- d22 = (1-py1.lt.y2) / alphap^2
- d33 = (1-py1.lt.y2) / beta^2
- d44 = py1.lt.y2 / betap^2
- wz = matrix(0, n, M) # diagonal
- wz[, iam(1,1,M)] = dtheta.deta(alpha, .la)^2 * d11
- wz[, iam(2,2,M)] = dtheta.deta(alphap, .lap)^2 * d22
- wz[, iam(3,3,M)] = dtheta.deta(beta, .lb)^2 * d33
- wz[, iam(4,4,M)] = dtheta.deta(betap, .lbp)^2 * d44
- c(w) * wz
- }), list(.la=la, .lap=lap, .lb=lb, .lbp=lbp))))
+ ell1 = log(alpha[tmp88]) + log(betap[tmp88]) -
+ betap[tmp88] * y[tmp88, 2] -
+ (alpha+beta-betap)[tmp88] * y[tmp88, 1]
+ ell2 = log(beta[!tmp88]) + log(alphap[!tmp88]) -
+ alphap[!tmp88] * y[!tmp88, 1] -
+ (alpha+beta-alphap)[!tmp88] * y[!tmp88, 2]
+ sum(w[tmp88] * ell1) + sum(w[!tmp88] * ell2) }
+ }, list(.la = la, .lap = lap, .lb = lb, .lbp = lbp,
+ .ea = ea, .eap = eap, .eb = eb, .ebp = ebp ))),
+ vfamily = c("freund61"),
+ deriv = eval(substitute(expression({
+ tmp88 = extra$y1.lt.y2
+ alpha = eta2theta(eta[, 1], .la, earg = .ea )
+ alphap = eta2theta(eta[, 2], .lap, earg = .eap )
+ beta = eta2theta(eta[, 3], .lb, earg = .eb )
+ betap = eta2theta(eta[, 4], .lbp, earg = .ebp )
+
+ dalpha.deta = dtheta.deta(alpha, .la, earg = .ea )
+ dalphap.deta = dtheta.deta(alphap, .lap, earg = .eap )
+ dbeta.deta = dtheta.deta(beta, .lb, earg = .eb )
+ dbetap.deta = dtheta.deta(betap, .lbp, earg = .ebp )
+
+ d1 = 1/alpha - y[, 1]
+ d1[!tmp88] = -y[!tmp88, 2]
+ d2 = 0 * alphap
+ d2[!tmp88] = 1/alphap[!tmp88] - y[!tmp88, 1] + y[!tmp88, 2]
+ d3 = -y[, 1]
+ d3[!tmp88] = 1/beta[!tmp88] - y[!tmp88, 2]
+ d4 = 1/betap - y[, 2] + y[, 1]
+ d4[!tmp88] = 0
+
+ c(w) * cbind(d1 * dalpha.deta,
+ d2 * dalphap.deta,
+ d3 * dbeta.deta,
+ d4 * dbetap.deta)
+ }), list(.la = la, .lap = lap, .lb = lb, .lbp = lbp,
+ .ea = ea, .eap = eap, .eb = eb, .ebp = ebp ))),
+ weight = eval(substitute(expression({
+ py1.lt.y2 = alpha / (alpha+beta)
+ d11 = py1.lt.y2 / alpha^2
+ d22 = (1-py1.lt.y2) / alphap^2
+ d33 = (1-py1.lt.y2) / beta^2
+ d44 = py1.lt.y2 / betap^2
+ wz = matrix(0, n, M) # diagonal
+ wz[, iam(1, 1, M)] = dalpha.deta^2 * d11
+ wz[, iam(2, 2, M)] = dalphap.deta^2 * d22
+ wz[, iam(3, 3, M)] = dbeta.deta^2 * d33
+ wz[, iam(4, 4, M)] = dbetap.deta^2 * d44
+ c(w) * wz
+ }), list(.la = la, .lap = lap, .lb = lb, .lbp = lbp,
+ .ea = ea, .eap = eap, .eb = eb, .ebp = ebp ))))
}
@@ -347,7 +386,7 @@ dbilogis4 = function(x1, x2, loc1=0, scale1 = 1, loc2=0, scale2 = 1, log = FALSE
new("vglmff",
blurb = c("Bivariate gamma: McKay's distribution\n",
"Links: ",
- namesof("scale", lscale), ", ",
+ namesof("scale", lscale), ", ",
namesof("shape1", lshape1), ", ",
namesof("shape2", lshape2)),
constraints = eval(substitute(expression({
@@ -356,19 +395,19 @@ dbilogis4 = function(x1, x2, loc1=0, scale1 = 1, loc2=0, scale2 = 1, log = FALSE
initialize = eval(substitute(expression({
if (!is.matrix(y) || ncol(y) != 2)
stop("the response must be a 2 column matrix")
- if (any(y[, 1] >= y[,2]))
+ if (any(y[, 1] >= y[, 2]))
stop("the second column minus the first column must be a vector ",
"of positive values")
- predictors.names = c(namesof("scale", .lscale, short = TRUE),
+ predictors.names = c(namesof("scale", .lscale, short = TRUE),
namesof("shape1", .lshape1, short = TRUE),
namesof("shape2", .lshape2, short = TRUE))
if (!length(etastart)) {
momentsY = if ( .imethod == 1) {
cbind(median(y[, 1]), # This may not be monotonic
- median(y[,2])) + 0.01
+ median(y[, 2])) + 0.01
} else {
cbind(weighted.mean(y[, 1], w),
- weighted.mean(y[,2], w))
+ weighted.mean(y[, 2], w))
}
mcg2.loglik = function(thetaval, y, x, w, extraargs) {
@@ -377,7 +416,7 @@ dbilogis4 = function(x1, x2, loc1=0, scale1 = 1, loc2=0, scale2 = 1, log = FALSE
p = (1/a) * abs(momentsY[1]) + 0.01
q = (1/a) * abs(momentsY[2] - momentsY[1]) + 0.01
sum(w * (-(p+q)*log(a) - lgamma(p) - lgamma(q) +
- (p - 1)*log(y[, 1]) + (q - 1)*log(y[,2]-y[, 1]) - y[,2] / a ))
+ (p - 1)*log(y[, 1]) + (q - 1)*log(y[, 2]-y[, 1]) - y[, 2] / a ))
}
a.grid = if (length( .iscale )) c( .iscale ) else
@@ -400,10 +439,10 @@ dbilogis4 = function(x1, x2, loc1=0, scale1 = 1, loc2=0, scale2 = 1, log = FALSE
}), list( .lscale=lscale, .lshape1=lshape1, .lshape2=lshape2,
.iscale=iscale, .ishape1=ishape1, .ishape2=ishape2,
.imethod = imethod ))),
- inverse = eval(substitute(function(eta, extra = NULL) {
+ linkinv = eval(substitute(function(eta, extra = NULL) {
a = eta2theta(eta[, 1], .lscale)
- p = eta2theta(eta[,2], .lshape1)
- q = eta2theta(eta[,3], .lshape2)
+ p = eta2theta(eta[, 2], .lshape1)
+ q = eta2theta(eta[, 3], .lshape2)
cbind("y1"=p*a, "y2"=(p+q)*a)
}, list( .lscale=lscale, .lshape1=lshape1, .lshape2=lshape2 ))),
last = eval(substitute(expression({
@@ -417,21 +456,21 @@ dbilogis4 = function(x1, x2, loc1=0, scale1 = 1, loc2=0, scale2 = 1, log = FALSE
loglikelihood = eval(substitute(
function(mu, y, w, residuals = FALSE, eta, extra = NULL) {
a = eta2theta(eta[, 1], .lscale)
- p = eta2theta(eta[,2], .lshape1)
- q = eta2theta(eta[,3], .lshape2)
+ p = eta2theta(eta[, 2], .lshape1)
+ q = eta2theta(eta[, 3], .lshape2)
if (residuals) stop("loglikelihood residuals not ",
"implemented yet") else
sum(w * (-(p+q)*log(a) - lgamma(p) - lgamma(q) +
- (p - 1)*log(y[, 1]) + (q - 1)*log(y[,2]-y[, 1]) - y[,2] / a))
+ (p - 1)*log(y[, 1]) + (q - 1)*log(y[, 2]-y[, 1]) - y[, 2] / a))
}, list( .lscale=lscale, .lshape1=lshape1, .lshape2=lshape2 ))),
vfamily = c("bivgamma.mckay"),
deriv = eval(substitute(expression({
aparam = eta2theta(eta[, 1], .lscale)
- shape1 = eta2theta(eta[,2], .lshape1)
- shape2 = eta2theta(eta[,3], .lshape2)
- dl.da = (-(shape1+shape2) + y[,2] / aparam) / aparam
+ shape1 = eta2theta(eta[, 2], .lshape1)
+ shape2 = eta2theta(eta[, 3], .lshape2)
+ dl.da = (-(shape1+shape2) + y[, 2] / aparam) / aparam
dl.dshape1 = -log(aparam) - digamma(shape1) + log(y[, 1])
- dl.dshape2 = -log(aparam) - digamma(shape2) + log(y[,2]-y[, 1])
+ dl.dshape2 = -log(aparam) - digamma(shape2) + log(y[, 2]-y[, 1])
c(w) * cbind(dl.da * dtheta.deta(aparam, .lscale),
dl.dshape1 * dtheta.deta(shape1, .lshape1),
dl.dshape2 * dtheta.deta(shape2, .lshape2))
@@ -444,14 +483,14 @@ dbilogis4 = function(x1, x2, loc1=0, scale1 = 1, loc2=0, scale2 = 1, log = FALSE
d13 = 1 / aparam
d23 = 0
wz = matrix(0, n, dimm(M))
- wz[, iam(1,1,M)] = dtheta.deta(aparam, .lscale)^2 * d11
- wz[, iam(2,2,M)] = dtheta.deta(shape1, .lshape1)^2 * d22
- wz[, iam(3,3,M)] = dtheta.deta(shape2, .lshape2)^2 * d33
- wz[, iam(1,2,M)] = dtheta.deta(aparam, .lscale) *
+ wz[, iam(1, 1, M)] = dtheta.deta(aparam, .lscale)^2 * d11
+ wz[, iam(2, 2, M)] = dtheta.deta(shape1, .lshape1)^2 * d22
+ wz[, iam(3, 3, M)] = dtheta.deta(shape2, .lshape2)^2 * d33
+ wz[, iam(1, 2, M)] = dtheta.deta(aparam, .lscale) *
dtheta.deta(shape1, .lshape1) * d12
- wz[, iam(1,3,M)] = dtheta.deta(aparam, .lscale) *
+ wz[, iam(1, 3, M)] = dtheta.deta(aparam, .lscale) *
dtheta.deta(shape2, .lshape2) * d13
- wz[, iam(2,3,M)] = dtheta.deta(shape1, .lshape1) *
+ wz[, iam(2, 3, M)] = dtheta.deta(shape1, .lshape1) *
dtheta.deta(shape2, .lshape2) * d23
c(w) * wz
}), list( .lscale=lscale, .lshape1=lshape1, .lshape2=lshape2 ))))
@@ -482,7 +521,7 @@ rfrank = function(n, alpha) {
ans = matrix(c(X,Y), nrow=n, ncol = 2)
if (any(index)) {
ans[index, 1] = runif(sum(index)) # Uniform density for alpha == 1
- ans[index,2] = runif(sum(index))
+ ans[index, 2] = runif(sum(index))
}
ans
}
@@ -540,7 +579,7 @@ dfrank = function(x1, x2, alpha, log = FALSE) {
if (any(!index))
ans[!index] = (alpha[!index] - 1) * log(alpha[!index]) *
(alpha[!index])^(x1[!index]+x2[!index]) / (temp[!index])^2
- ans[x1<=0 | x2<=0 | x1 >= 1 | x2 >= 1] = 0
+ ans[x1 <= 0 | x2 <= 0 | x1 >= 1 | x2 >= 1] = 0
ans[index] = 1
ans
}
@@ -575,7 +614,8 @@ frank.control <- function(save.weight = TRUE, ...)
stop("the response must be a 2 column matrix")
if (any(y <= 0) || any(y >= 1))
stop("the response must have values between 0 and 1")
- predictors.names = c(namesof("apar", .lapar, earg = .eapar, short = TRUE))
+ predictors.names =
+ c(namesof("apar", .lapar, earg = .eapar, short = TRUE))
if (length(dimnames(y)))
extra$dimnamesy2 = dimnames(y)[[2]]
if (!length(etastart)) {
@@ -583,7 +623,7 @@ frank.control <- function(save.weight = TRUE, ...)
etastart = cbind(theta2eta(apar.init, .lapar, earg = .eapar ))
}
}), list( .lapar = lapar, .eapar=eapar, .iapar=iapar))),
- inverse = eval(substitute(function(eta, extra = NULL) {
+ linkinv = eval(substitute(function(eta, extra = NULL) {
apar = eta2theta(eta, .lapar, earg = .eapar )
fv.matrix = matrix(0.5, length(apar), 2)
if (length(extra$dimnamesy2))
@@ -602,7 +642,7 @@ frank.control <- function(save.weight = TRUE, ...)
apar = eta2theta(eta, .lapar, earg = .eapar )
if (residuals) stop("loglikelihood residuals not ",
"implemented yet") else {
- sum(w * dfrank(x1=y[, 1], x2=y[,2], alpha=apar, log = TRUE))
+ sum(w * dfrank(x1=y[, 1], x2=y[, 2], alpha=apar, log = TRUE))
}
}, list(.lapar = lapar, .eapar=eapar ))),
vfamily = c("frank"),
@@ -614,11 +654,11 @@ frank.control <- function(save.weight = TRUE, ...)
2 * log(apar-1 + (apar^y1 - 1) * (apar^y2 - 1))),
name = "apar", hessian= TRUE)
- denom = apar-1 + (apar^y[, 1] - 1) * (apar^y[,2] - 1)
- tmp700 = 2*apar^(y[, 1]+y[,2]) - apar^y[, 1] - apar^y[,2]
- numerator = 1 + y[, 1] * apar^(y[, 1] - 1) * (apar^y[,2] - 1) +
- y[,2] * apar^(y[,2] - 1) * (apar^y[, 1] - 1)
- Dl.dapar = 1/(apar - 1) + 1/(apar*log(apar)) + (y[, 1]+y[,2])/apar -
+ denom = apar-1 + (apar^y[, 1] - 1) * (apar^y[, 2] - 1)
+ tmp700 = 2*apar^(y[, 1]+y[, 2]) - apar^y[, 1] - apar^y[, 2]
+ numerator = 1 + y[, 1] * apar^(y[, 1] - 1) * (apar^y[, 2] - 1) +
+ y[, 2] * apar^(y[, 2] - 1) * (apar^y[, 1] - 1)
+ Dl.dapar = 1/(apar - 1) + 1/(apar*log(apar)) + (y[, 1]+y[, 2])/apar -
2 * numerator / denom
w * Dl.dapar * dapar.deta
}), list(.lapar = lapar, .eapar=eapar, .nsimEIM = nsimEIM ))),
@@ -631,11 +671,11 @@ frank.control <- function(save.weight = TRUE, ...)
run.mean = 0
for(ii in 1:( .nsimEIM )) {
ysim = rfrank(n,alpha=apar)
- y1 = ysim[, 1]; y2 = ysim[,2];
+ y1 = ysim[, 1]; y2 = ysim[, 2];
eval.de3 = eval(de3)
d2l.dthetas2 = attr(eval.de3, "hessian")
rm(ysim)
- temp3 = -d2l.dthetas2[,1, 1] # M = 1
+ temp3 = -d2l.dthetas2[, 1, 1] # M = 1
run.mean = ((ii - 1) * run.mean + temp3) / ii
}
wz = if (intercept.only)
@@ -644,12 +684,12 @@ frank.control <- function(save.weight = TRUE, ...)
wz = wz * dapar.deta^2
c(w) * wz
} else {
- nump = apar^(y[, 1]+y[,2]-2) * (2 * y[, 1] * y[,2] +
- y[, 1]*(y[, 1] - 1) + y[,2]*(y[,2] - 1)) -
+ nump = apar^(y[, 1]+y[, 2]-2) * (2 * y[, 1] * y[, 2] +
+ y[, 1]*(y[, 1] - 1) + y[, 2]*(y[, 2] - 1)) -
y[, 1]*(y[, 1] - 1) * apar^(y[, 1]-2) -
- y[,2]*(y[,2] - 1) * apar^(y[,2]-2)
+ y[, 2]*(y[, 2] - 1) * apar^(y[, 2]-2)
D2l.dapar2 = 1/(apar - 1)^2 + (1+log(apar))/(apar*log(apar))^2 +
- (y[, 1]+y[,2])/apar^2 + 2 *
+ (y[, 1]+y[, 2])/apar^2 + 2 *
(nump / denom - (numerator/denom)^2)
d2apar.deta2 = d2theta.deta2(apar, .lapar)
wz = w * (dapar.deta^2 * D2l.dapar2 - Dl.dapar * d2apar.deta2)
@@ -682,17 +722,17 @@ frank.control <- function(save.weight = TRUE, ...)
initialize = eval(substitute(expression({
if (!is.matrix(y) || ncol(y) != 2)
stop("the response must be a 2 column matrix")
- if (any(y[, 1] <= 0) || any(y[,2] <= 1))
+ if (any(y[, 1] <= 0) || any(y[, 2] <= 1))
stop("the response has values that are out of range")
predictors.names = c(namesof("theta", .ltheta, short = TRUE))
if (!length(etastart)) {
theta.init = if (length( .itheta)) rep(.itheta, len = n) else {
- 1 / (y[,2] - 1 + 0.01)
+ 1 / (y[, 2] - 1 + 0.01)
}
etastart = cbind(theta2eta(theta.init, .ltheta))
}
}), list(.ltheta=ltheta, .itheta=itheta))),
- inverse = eval(substitute(function(eta, extra = NULL) {
+ linkinv = eval(substitute(function(eta, extra = NULL) {
theta = eta2theta(eta, .ltheta)
cbind(theta*exp(theta), 1+1/theta)
}, list(.ltheta=ltheta))),
@@ -705,13 +745,13 @@ frank.control <- function(save.weight = TRUE, ...)
theta = eta2theta(eta, .ltheta)
if (residuals) stop("loglikelihood residuals not ",
"implemented yet") else {
- sum(w * (-exp(-theta)*y[, 1]/theta - theta*y[,2]))
+ sum(w * (-exp(-theta)*y[, 1]/theta - theta*y[, 2]))
}
}, list(.ltheta=ltheta))),
vfamily = c("gammahyp"),
deriv = eval(substitute(expression({
theta = eta2theta(eta, .ltheta)
- Dl.dtheta = exp(-theta) * y[, 1] * (1+theta) / theta^2 - y[,2]
+ Dl.dtheta = exp(-theta) * y[, 1] * (1+theta) / theta^2 - y[, 2]
Dtheta.deta = dtheta.deta(theta, .ltheta)
w * Dl.dtheta * Dtheta.deta
}), list(.ltheta=ltheta))),
@@ -731,7 +771,7 @@ frank.control <- function(save.weight = TRUE, ...)
- morgenstern = function(lapar = "rhobit", earg =list(), iapar = NULL, tola0=0.01,
+ morgenstern = function(lapar = "rhobit", earg =list(), iapar = NULL, tola0 = 0.01,
imethod = 1) {
if (mode(lapar) != "character" && mode(lapar) != "name")
lapar = as.character(substitute(lapar))
@@ -761,8 +801,8 @@ frank.control <- function(save.weight = TRUE, ...)
if (!length(etastart)) {
ainit = if (length(.iapar)) rep(.iapar, len = n) else {
mean1 = if ( .imethod == 1) median(y[, 1]) else mean(y[, 1])
- mean2 = if ( .imethod == 1) median(y[,2]) else mean(y[,2])
- Finit = 0.01 + mean(y[, 1] <= mean1 & y[,2] <= mean2)
+ mean2 = if ( .imethod == 1) median(y[, 2]) else mean(y[, 2])
+ Finit = 0.01 + mean(y[, 1] <= mean1 & y[, 2] <= mean2)
((Finit+expm1(-mean1)+exp(-mean2)) / exp(-mean1-mean2) - 1)/(
expm1(-mean1) * expm1(-mean2))
}
@@ -770,7 +810,7 @@ frank.control <- function(save.weight = TRUE, ...)
}
}), list( .iapar=iapar, .lapar = lapar, .earg = earg,
.imethod = imethod ))),
- inverse = eval(substitute(function(eta, extra = NULL) {
+ linkinv = eval(substitute(function(eta, extra = NULL) {
alpha = eta2theta(eta, .lapar, earg = .earg )
fv.matrix = matrix(1, length(alpha), 2)
if (length(extra$dimnamesy2))
@@ -789,18 +829,18 @@ frank.control <- function(save.weight = TRUE, ...)
alpha[abs(alpha) < .tola0 ] = .tola0
if (residuals) stop("loglikelihood residuals not ",
"implemented yet") else {
- denom = (1 + alpha - 2*alpha*(exp(-y[, 1]) + exp(-y[,2])) +
- 4*alpha*exp(-y[, 1] - y[,2]))
- sum(w * (-y[, 1] - y[,2] + log(denom)))
+ denom = (1 + alpha - 2*alpha*(exp(-y[, 1]) + exp(-y[, 2])) +
+ 4*alpha*exp(-y[, 1] - y[, 2]))
+ sum(w * (-y[, 1] - y[, 2] + log(denom)))
}
}, list( .lapar = lapar, .earg = earg, .tola0=tola0 ))),
vfamily = c("morgenstern"),
deriv = eval(substitute(expression({
alpha = eta2theta(eta, .lapar, earg = .earg )
alpha[abs(alpha) < .tola0 ] = .tola0
- numerator = 1 - 2*(exp(-y[, 1]) + exp(-y[,2])) + 4*exp(-y[, 1] - y[,2])
- denom = (1 + alpha - 2*alpha*(exp(-y[, 1]) + exp(-y[,2])) +
- 4 *alpha*exp(-y[, 1] - y[,2]))
+ numerator = 1 - 2*(exp(-y[, 1]) + exp(-y[, 2])) + 4*exp(-y[, 1] - y[, 2])
+ denom = (1 + alpha - 2*alpha*(exp(-y[, 1]) + exp(-y[, 2])) +
+ 4 *alpha*exp(-y[, 1] - y[, 2]))
dl.dalpha = numerator / denom
dalpha.deta = dtheta.deta(alpha, .lapar, earg = .earg )
c(w) * cbind(dl.dalpha * dalpha.deta)
@@ -881,7 +921,7 @@ pfgm = function(q1, q2, alpha) {
if (length(alpha) != L) alpha = rep(alpha, len = L)
x=q1; y=q2
- index = (x >= 1 & y<1) | (y >= 1 & x<1) | (x<=0 | y<=0) | (x >= 1 & y >= 1)
+ index = (x >= 1 & y<1) | (y >= 1 & x<1) | (x <= 0 | y <= 0) | (x >= 1 & y >= 1)
ans = as.numeric(index)
if (any(!index)) {
ans[!index] = q1[!index] * q2[!index] * (1 + alpha[!index] *
@@ -889,7 +929,7 @@ pfgm = function(q1, q2, alpha) {
}
ans[x >= 1 & y<1] = y[x >= 1 & y<1] # P(Y2 < q2) = q2
ans[y >= 1 & x<1] = x[y >= 1 & x<1] # P(Y1 < q1) = q1
- ans[x<=0 | y<=0] = 0
+ ans[x <= 0 | y <= 0] = 0
ans[x >= 1 & y >= 1] = 1
ans
}
@@ -934,9 +974,9 @@ fgm.control <- function(save.weight = TRUE, ...)
ainit = if (length( .iapar )) .iapar else {
mean1 = if ( .imethod == 1) weighted.mean(y[, 1],w) else
median(y[, 1])
- mean2 = if ( .imethod == 1) weighted.mean(y[,2],w) else
- median(y[,2])
- Finit = weighted.mean(y[, 1] <= mean1 & y[,2] <= mean2, w)
+ mean2 = if ( .imethod == 1) weighted.mean(y[, 2],w) else
+ median(y[, 2])
+ Finit = weighted.mean(y[, 1] <= mean1 & y[, 2] <= mean2, w)
(Finit / (mean1 * mean2) - 1) / ((1-mean1) * (1-mean2))
}
@@ -946,7 +986,7 @@ fgm.control <- function(save.weight = TRUE, ...)
}
}), list( .iapar=iapar, .lapar = lapar, .earg = earg,
.imethod = imethod ))),
- inverse = eval(substitute(function(eta, extra = NULL) {
+ linkinv = eval(substitute(function(eta, extra = NULL) {
alpha = eta2theta(eta, .lapar, earg = .earg )
fv.matrix = matrix(0.5, length(alpha), 2)
if (length(extra$dimnamesy2))
@@ -964,14 +1004,14 @@ fgm.control <- function(save.weight = TRUE, ...)
alpha = eta2theta(eta, .lapar, earg = .earg )
if (residuals) stop("loglikelihood residuals not ",
"implemented yet") else {
- sum(w * dfgm(x1=y[, 1], x2=y[,2], alpha=alpha, log = TRUE))
+ sum(w * dfgm(x1=y[, 1], x2=y[, 2], alpha=alpha, log = TRUE))
}
}, list( .lapar = lapar, .earg = earg ))),
vfamily = c("fgm"),
deriv = eval(substitute(expression({
alpha = eta2theta(eta, .lapar, earg = .earg )
dalpha.deta = dtheta.deta(alpha, .lapar, earg = .earg )
- numerator = (1 - 2 * y[, 1]) * (1 - 2 * y[,2])
+ numerator = (1 - 2 * y[, 1]) * (1 - 2 * y[, 2])
denom = 1 + alpha * numerator
mytolerance = .Machine$double.eps
bad <- (denom <= mytolerance) # Range violation
@@ -987,7 +1027,7 @@ fgm.control <- function(save.weight = TRUE, ...)
run.var = 0
for(ii in 1:( .nsimEIM )) {
ysim = rfgm(n, alpha=alpha)
- numerator = (1 - 2 * ysim[, 1]) * (1 - 2 * ysim[,2])
+ numerator = (1 - 2 * ysim[, 1]) * (1 - 2 * ysim[, 2])
denom = 1 + alpha * numerator
dl.dalpha = numerator / denom
rm(ysim)
@@ -1029,15 +1069,15 @@ fgm.control <- function(save.weight = TRUE, ...)
if (!length(etastart)) {
ainit = if (length( .iapar )) rep( .iapar, len = n) else {
mean1 = if ( .imethod == 1) median(y[, 1]) else mean(y[, 1])
- mean2 = if ( .imethod == 1) median(y[,2]) else mean(y[,2])
- Finit = 0.01 + mean(y[, 1] <= mean1 & y[,2] <= mean2)
+ mean2 = if ( .imethod == 1) median(y[, 2]) else mean(y[, 2])
+ Finit = 0.01 + mean(y[, 1] <= mean1 & y[, 2] <= mean2)
(log(Finit+expm1(-mean1)+exp(-mean2))+mean1+mean2)/(mean1*mean2)
}
etastart = theta2eta(rep(ainit, len = n), .lapar, earg = .earg )
}
}), list( .iapar=iapar, .lapar = lapar, .earg = earg,
.imethod = imethod ))),
- inverse = eval(substitute(function(eta, extra = NULL) {
+ linkinv = eval(substitute(function(eta, extra = NULL) {
alpha = eta2theta(eta, .lapar, earg = .earg )
cbind(rep(1, len=length(alpha)),
rep(1, len=length(alpha)))
@@ -1053,7 +1093,7 @@ fgm.control <- function(save.weight = TRUE, ...)
alpha = eta2theta(eta, .lapar, earg = .earg )
if (residuals) stop("loglikelihood residuals not ",
"implemented yet") else {
- denom = (alpha*y[, 1] - 1) * (alpha*y[,2] - 1) + alpha
+ denom = (alpha*y[, 1] - 1) * (alpha*y[, 2] - 1) + alpha
mytolerance = .Machine$double.xmin
bad <- (denom <= mytolerance) # Range violation
if (any(bad)) {
@@ -1061,22 +1101,22 @@ fgm.control <- function(save.weight = TRUE, ...)
flush.console()
}
sum(bad) * (-1.0e10) +
- sum(w[!bad] * (-y[!bad, 1] - y[!bad,2] +
- alpha[!bad]*y[!bad, 1]*y[!bad,2] + log(denom[!bad])))
+ sum(w[!bad] * (-y[!bad, 1] - y[!bad, 2] +
+ alpha[!bad]*y[!bad, 1]*y[!bad, 2] + log(denom[!bad])))
}
}, list( .lapar = lapar, .earg = earg ))),
vfamily = c("gumbelIbiv"),
deriv = eval(substitute(expression({
alpha = eta2theta(eta, .lapar, earg = .earg )
- numerator = (alpha*y[, 1] - 1)*y[,2] + (alpha*y[,2] - 1)*y[, 1] + 1
- denom = (alpha*y[, 1] - 1) * (alpha*y[,2] - 1) + alpha
+ numerator = (alpha*y[, 1] - 1)*y[, 2] + (alpha*y[, 2] - 1)*y[, 1] + 1
+ denom = (alpha*y[, 1] - 1) * (alpha*y[, 2] - 1) + alpha
denom = abs(denom)
- dl.dalpha = numerator / denom + y[, 1]*y[,2]
+ dl.dalpha = numerator / denom + y[, 1]*y[, 2]
dalpha.deta = dtheta.deta(alpha, .lapar, earg = .earg )
c(w) * cbind(dl.dalpha * dalpha.deta)
}), list( .lapar = lapar, .earg = earg ))),
weight = eval(substitute(expression({
- d2l.dalpha2 = (numerator/denom)^2 - 2*y[, 1]*y[,2] / denom
+ d2l.dalpha2 = (numerator/denom)^2 - 2*y[, 1]*y[, 2] / denom
d2alpha.deta2 = d2theta.deta2(alpha, .lapar, earg = .earg )
wz = w * (dalpha.deta^2 * d2l.dalpha2 - d2alpha.deta2 * dl.dalpha)
if (TRUE &&
@@ -1125,7 +1165,7 @@ pplack = function(q1, q2, oratio) {
ans[ind2] = x[ind2] * y[ind2]
ans[x >= 1 & y<1] = y[x >= 1 & y<1] # P(Y2 < q2) = q2
ans[y >= 1 & x<1] = x[y >= 1 & x<1] # P(Y1 < q1) = q1
- ans[x<=0 | y<=0] = 0
+ ans[x <= 0 | y <= 0] = 0
ans[x >= 1 & y >= 1] = 1
ans
}
@@ -1209,25 +1249,25 @@ plackett.control <- function(save.weight = TRUE, ...)
if (!length(etastart)) {
orinit = if (length( .ioratio )) .ioratio else {
if ( .imethod == 2) {
- scorp = cor(y)[1,2]
+ scorp = cor(y)[1, 2]
if (abs(scorp) <= 0.1) 1 else
if (abs(scorp) <= 0.3) 3^sign(scorp) else
if (abs(scorp) <= 0.6) 5^sign(scorp) else
if (abs(scorp) <= 0.8) 20^sign(scorp) else 40^sign(scorp)
} else {
y10 = weighted.mean(y[, 1], w)
- y20 = weighted.mean(y[,2], w)
- (0.5 + sum(w[(y[, 1] < y10) & (y[,2] < y20)])) *
- (0.5 + sum(w[(y[, 1] >= y10) & (y[,2] >= y20)])) / (
- ((0.5 + sum(w[(y[, 1] < y10) & (y[,2] >= y20)])) *
- (0.5 + sum(w[(y[, 1] >= y10) & (y[,2] < y20)]))))
+ y20 = weighted.mean(y[, 2], w)
+ (0.5 + sum(w[(y[, 1] < y10) & (y[, 2] < y20)])) *
+ (0.5 + sum(w[(y[, 1] >= y10) & (y[, 2] >= y20)])) / (
+ ((0.5 + sum(w[(y[, 1] < y10) & (y[, 2] >= y20)])) *
+ (0.5 + sum(w[(y[, 1] >= y10) & (y[, 2] < y20)]))))
}
}
etastart = theta2eta(rep(orinit, len = n), .link, earg = .earg)
}
}), list( .ioratio=ioratio, .link = link, .earg = earg,
.imethod = imethod ))),
- inverse = eval(substitute(function(eta, extra = NULL) {
+ linkinv = eval(substitute(function(eta, extra = NULL) {
oratio = eta2theta(eta, .link, earg = .earg )
fv.matrix = matrix(0.5, length(oratio), 2)
if (length(extra$dimnamesy2))
@@ -1246,7 +1286,7 @@ plackett.control <- function(save.weight = TRUE, ...)
oratio = eta2theta(eta, .link, earg = .earg )
if (residuals) stop("loglikelihood residuals not ",
"implemented yet") else {
- sum(w * dplack(x1= y[, 1], x2= y[,2], oratio=oratio, log = TRUE))
+ sum(w * dplack(x1= y[, 1], x2= y[, 2], oratio=oratio, log = TRUE))
}
}, list( .link = link, .earg = earg ))),
vfamily = c("plackett"),
@@ -1254,7 +1294,7 @@ plackett.control <- function(save.weight = TRUE, ...)
oratio = eta2theta(eta, .link, earg = .earg )
doratio.deta = dtheta.deta(oratio, .link, earg = .earg )
y1 = y[, 1]
- y2 = y[,2]
+ y2 = y[, 2]
de3 = deriv3(~ (log(oratio) + log(1+(oratio - 1) *
(y1+y2-2*y1*y2)) - 1.5 *
log((1 + (y1+y2)*(oratio - 1))^2 - 4 * oratio * (oratio - 1)*y1*y2)),
@@ -1389,9 +1429,9 @@ amh.control <- function(save.weight = TRUE, ...)
ainit = if (length( .ialpha )) .ialpha else {
mean1 = if ( .imethod == 1) weighted.mean(y[, 1],w) else
median(y[, 1])
- mean2 = if ( .imethod == 1) weighted.mean(y[,2],w) else
- median(y[,2])
- Finit = weighted.mean(y[, 1] <= mean1 & y[,2] <= mean2, w)
+ mean2 = if ( .imethod == 1) weighted.mean(y[, 2],w) else
+ median(y[, 2])
+ Finit = weighted.mean(y[, 1] <= mean1 & y[, 2] <= mean2, w)
(1 - (mean1 * mean2 / Finit)) / ((1-mean1) * (1-mean2))
}
ainit = min(0.95, max(ainit, -0.95))
@@ -1399,7 +1439,7 @@ amh.control <- function(save.weight = TRUE, ...)
}
}), list( .lalpha = lalpha, .ealpha = ealpha, .ialpha=ialpha,
.imethod = imethod))),
- inverse = eval(substitute(function(eta, extra = NULL) {
+ linkinv = eval(substitute(function(eta, extra = NULL) {
alpha = eta2theta(eta, .lalpha, earg = .ealpha )
fv.matrix = matrix(0.5, length(alpha), 2)
if (length(extra$dimnamesy2))
@@ -1417,7 +1457,7 @@ amh.control <- function(save.weight = TRUE, ...)
alpha = eta2theta(eta, .lalpha, earg = .ealpha )
if (residuals) stop("loglikelihood residuals not ",
"implemented yet") else {
- sum(w * damh(x1=y[, 1], x2=y[,2], alpha=alpha, log = TRUE))
+ sum(w * damh(x1=y[, 1], x2=y[, 2], alpha=alpha, log = TRUE))
}
}, list( .lalpha = lalpha, .earg = ealpha ))),
vfamily = c("amh"),
@@ -1425,7 +1465,7 @@ amh.control <- function(save.weight = TRUE, ...)
alpha = eta2theta(eta, .lalpha, earg = .ealpha )
dalpha.deta = dtheta.deta(alpha, .lalpha, earg = .ealpha )
y1 = y[, 1]
- y2 = y[,2]
+ y2 = y[, 2]
de3 = deriv3(~ (log(1-alpha+(2*alpha*y1*y2/(1-alpha*(1-y1)*(1-y2))))-
2*log(1-alpha*(1-y1)*(1-y2))) ,
name = "alpha", hessian= FALSE)
@@ -1526,10 +1566,10 @@ dbinorm = function(x1, x2, mean1 = 0, mean2 = 0, sd1 = 1, sd2 = 1,
new("vglmff",
blurb = c("Bivariate normal distribution\n",
"Links: ",
- namesof("mean1", lmean1, earg = emean1 ), "\n",
- namesof("mean2", lmean2, earg = emean2 ), "\n",
- namesof("sd1", lsd1, earg = sd1 ), "\n",
- namesof("sd2", lsd2, earg = sd2 ), "\n",
+ namesof("mean1", lmean1, earg = emean1 ), ", ",
+ namesof("mean2", lmean2, earg = emean2 ), ", ",
+ namesof("sd1", lsd1, earg = esd1 ), ", ",
+ namesof("sd2", lsd2, earg = esd2 ), ", ",
namesof("rho", lrho, earg = erho )),
constraints = eval(substitute(expression({
temp8.m <- diag(5)[, -2]
@@ -1565,7 +1605,7 @@ dbinorm = function(x1, x2, mean1 = 0, mean2 = 0, sd1 = 1, sd2 = 1,
weighted.mean(y[, 2], w = w), len = n)
isd1 = rep(if (length( .isd1 )) .isd1 else sd(y[, 1]), len = n)
isd2 = rep(if (length( .isd2 )) .isd2 else sd(y[, 2]), len = n)
- irho = rep(if (length( .irho )) .irho else cor(y[, 1], y[,2]),
+ irho = rep(if (length( .irho )) .irho else cor(y[, 1], y[, 2]),
len = n)
if ( .imethod == 2) {
@@ -1586,7 +1626,7 @@ dbinorm = function(x1, x2, mean1 = 0, mean2 = 0, sd1 = 1, sd2 = 1,
.imean1 = imean1, .imean2 = imean2,
.isd1 = isd1, .isd2 = isd2,
.irho = irho ))),
- inverse = eval(substitute(function(eta, extra = NULL) {
+ linkinv = eval(substitute(function(eta, extra = NULL) {
mean1 = eta2theta(eta[, 1], .lmean1, earg = .emean1)
mean2 = eta2theta(eta[, 2], .lmean2, earg = .emean2)
fv.matrix = cbind(mean1, mean2)
diff --git a/R/family.categorical.R b/R/family.categorical.R
index e9a47bb..b406c24 100644
--- a/R/family.categorical.R
+++ b/R/family.categorical.R
@@ -121,7 +121,7 @@ Deviance.categorical.data.vgam <-
dmultinomial = function(x, size = NULL, prob, log = FALSE,
- dochecking=TRUE, smallno = 1.0e-7) {
+ dochecking = TRUE, smallno = 1.0e-7) {
if (!is.logical(log.arg <- log))
stop("bad input for argument 'log'")
rm(log)
@@ -185,16 +185,16 @@ dmultinomial = function(x, size = NULL, prob, log = FALSE,
eval(process.categorical.data.vgam)
M = ncol(y) - 1
mynames = if ( .reverse)
- paste("P[Y=", 2:(M+1),"|Y<=", 2:(M+1),"]", sep="") else
- paste("P[Y=", 1:M, "|Y>=", 1:M, "]", sep="")
+ paste("P[Y=", 2:(M+1),"|Y<=", 2:(M+1),"]", sep = "") else
+ paste("P[Y=", 1:M, "|Y>=", 1:M, "]", sep = "")
predictors.names = namesof(mynames, .link, short = TRUE, earg = .earg)
- y.names = paste("mu", 1:(M+1), sep="")
+ y.names = paste("mu", 1:(M+1), sep = "")
extra$mymat = if ( .reverse ) tapplymat1(y, "cumsum") else
tapplymat1(y[,ncol(y):1], "cumsum")[,ncol(y):1]
if (length(dimnames(y)))
extra$dimnamesy2 = dimnames(y)[[2]]
}), list( .earg = earg, .link = link, .reverse = reverse ))),
- inverse = eval(substitute( function(eta, extra = NULL) {
+ linkinv = eval(substitute( function(eta, extra = NULL) {
if (!is.matrix(eta))
eta = as.matrix(eta)
fv.matrix =
@@ -218,13 +218,13 @@ dmultinomial = function(x, size = NULL, prob, log = FALSE,
misc$earg = vector("list", M)
names(misc$earg) = names(misc$link)
- for(ii in 1:M) misc$earg[[ii]] = .earg
+ for (ii in 1:M) misc$earg[[ii]] = .earg
misc$parameters = mynames
misc$reverse = .reverse
extra = list() # kill what was used
}), list( .earg = earg, .link = link, .reverse = reverse ))),
- link = eval(substitute( function(mu, extra = NULL) {
+ linkfun = eval(substitute( function(mu, extra = NULL) {
cump = tapplymat1(mu, "cumsum")
if ( .reverse ) {
djr = mu[,-1] / cump[,-1]
@@ -315,16 +315,16 @@ dmultinomial = function(x, size = NULL, prob, log = FALSE,
eval(process.categorical.data.vgam)
M = ncol(y) - 1
mynames = if ( .reverse )
- paste("P[Y<",2:(M+1),"|Y<=",2:(M+1),"]", sep="") else
- paste("P[Y>",1:M,"|Y>=",1:M,"]", sep="")
+ paste("P[Y<",2:(M+1),"|Y<=",2:(M+1),"]", sep = "") else
+ paste("P[Y>",1:M,"|Y>=",1:M,"]", sep = "")
predictors.names = namesof(mynames, .link, short = TRUE, earg = .earg)
- y.names = paste("mu", 1:(M+1), sep="")
+ y.names = paste("mu", 1:(M+1), sep = "")
extra$mymat = if ( .reverse ) tapplymat1(y, "cumsum") else
tapplymat1(y[,ncol(y):1], "cumsum")[,ncol(y):1]
if (length(dimnames(y)))
extra$dimnamesy2 = dimnames(y)[[2]]
}), list( .earg = earg, .link = link, .reverse = reverse ))),
- inverse = eval(substitute( function(eta, extra = NULL) {
+ linkinv = eval(substitute( function(eta, extra = NULL) {
if (!is.matrix(eta))
eta = as.matrix(eta)
fv.matrix =
@@ -347,12 +347,12 @@ dmultinomial = function(x, size = NULL, prob, log = FALSE,
names(misc$link) = mynames
misc$earg = vector("list", M)
names(misc$earg) = names(misc$link)
- for(ii in 1:M) misc$earg[[ii]] = .earg
+ for (ii in 1:M) misc$earg[[ii]] = .earg
misc$parameters = mynames
misc$reverse = .reverse
extra = list() # kill what was used
}), list( .earg = earg, .link = link, .reverse = reverse ))),
- link = eval(substitute( function(mu, extra = NULL) {
+ linkfun = eval(substitute( function(mu, extra = NULL) {
cump = tapplymat1(mu, "cumsum")
if ( .reverse ) {
djrs = 1 - mu[,-1] / cump[,-1]
@@ -440,11 +440,11 @@ vglm.multinomial.control = function(maxit=21, panic=FALSE,
}
list(maxit=maxit, panic=as.logical(panic)[1],
criterion=criterion,
- min.criterion=c("aic1"=FALSE, "aic2"=TRUE, .min.criterion.VGAM))
+ min.criterion=c("aic1"=FALSE, "aic2" = TRUE, .min.criterion.VGAM))
}
-vglm.vcategorical.control = function(maxit=30, trace=FALSE, panic=TRUE, ...)
+vglm.vcategorical.control = function(maxit=30, trace=FALSE, panic = TRUE, ...)
{
if (maxit < 1) {
warning("bad value of maxit; using 200 instead")
@@ -468,9 +468,9 @@ vglm.vcategorical.control = function(maxit=30, trace=FALSE, panic=TRUE, ...)
warning("'refLevel' is from an ordered factor")
refLevel = as.character(refLevel) == levels(refLevel)
refLevel = (1:length(refLevel))[refLevel]
- if (!is.Numeric(refLevel, allow=1, integer=TRUE, posit=TRUE))
+ if (!is.Numeric(refLevel, allow=1, integer = TRUE, posit = TRUE))
stop("could not coerce 'refLevel' into a single positive integer")
- } else if (!is.Numeric(refLevel, allow=1, integer=TRUE, posit=TRUE))
+ } else if (!is.Numeric(refLevel, allow=1, integer = TRUE, posit = TRUE))
stop("'refLevel' must be a single positive integer")
new("vglmff",
@@ -479,11 +479,11 @@ vglm.vcategorical.control = function(maxit=30, trace=FALSE, panic=TRUE, ...)
"Links: log(mu[,j]/mu[,M+1]), j=1:M,\n" else {
if (refLevel==1)
paste("Links: log(mu[,j]/mu[,", refLevel,
- "]), j=2:(M+1),\n", sep="") else
+ "]), j=2:(M+1),\n", sep = "") else
paste("Links: log(mu[,j]/mu[,", refLevel,
"]), j=c(1:", refLevel-1,
",", refLevel+1, ":(M+1)),\n",
- sep="")
+ sep = "")
},
"Variance: mu[,j]*(1-mu[,j]); -mu[,j]*mu[,k]"),
constraints = eval(substitute(expression({
@@ -508,10 +508,10 @@ vglm.vcategorical.control = function(maxit=30, trace=FALSE, panic=TRUE, ...)
stop("argument 'refLevel' has a value that is too high")
allbut.refLevel = (1:(M+1))[-use.refLevel]
predictors.names = paste("log(mu[,", allbut.refLevel,
- "]/mu[,", use.refLevel, "])", sep="")
- y.names = paste("mu", 1:(M+1), sep="")
+ "]/mu[,", use.refLevel, "])", sep = "")
+ y.names = paste("mu", 1:(M+1), sep = "")
}), list( .refLevel = refLevel ))),
- inverse = eval(substitute( function(eta, extra = NULL) {
+ linkinv = eval(substitute( function(eta, extra = NULL) {
if (any(is.na(eta)))
warning("there are NAs in eta in slot inverse")
M = ncol(cbind(eta))
@@ -538,8 +538,11 @@ vglm.vcategorical.control = function(maxit=30, trace=FALSE, panic=TRUE, ...)
dy = dimnames(y)
if (!is.null(dy[[2]]))
dimnames(fit$fitted.values) = dy
- }), list( .refLevel = refLevel ))),
- link = eval(substitute( function(mu, extra = NULL) {
+
+ misc$nointercept = .nointercept
+ }), list( .refLevel = refLevel,
+ .nointercept = nointercept ))),
+ linkfun = eval(substitute( function(mu, extra = NULL) {
if ( .refLevel < 0) {
log(mu[,-ncol(mu)] / mu[,ncol(mu)])
} else {
@@ -582,7 +585,7 @@ vglm.vcategorical.control = function(maxit=30, trace=FALSE, panic=TRUE, ...)
if (M == 1) {
wz = mu[,3-use.refLevel] * (1-mu[,3-use.refLevel])
} else {
- index = iam(NA, NA, M, both=TRUE, diag=TRUE)
+ index = iam(NA, NA, M, both = TRUE, diag = TRUE)
myinc = (index$row.index >= use.refLevel)
index$row.index[myinc] = index$row.index[myinc] + 1
myinc = (index$col.index >= use.refLevel)
@@ -651,7 +654,7 @@ vglm.vcategorical.control = function(maxit=30, trace=FALSE, panic=TRUE, ...)
totdev = 0
NOS = extra$NOS
Llevels = extra$Llevels
- for(iii in 1:NOS) {
+ for (iii in 1:NOS) {
cindex = (iii-1)*(Llevels-1) + 1:(Llevels-1)
aindex = (iii-1)*(Llevels) + 1:(Llevels)
totdev = totdev + Deviance.categorical.data.vgam(
@@ -681,7 +684,7 @@ vglm.vcategorical.control = function(maxit=30, trace=FALSE, panic=TRUE, ...)
orig.y = cbind(y) # Convert y into a matrix if necessary
NOS = ncol(cbind(orig.y))
use.y = use.mustart = NULL
- for(iii in 1:NOS) {
+ for (iii in 1:NOS) {
y = as.factor(orig.y[,iii])
eval(process.categorical.data.vgam)
use.y = cbind(use.y, y)
@@ -691,19 +694,19 @@ vglm.vcategorical.control = function(maxit=30, trace=FALSE, panic=TRUE, ...)
y = use.y # n x (Llevels*NOS)
M = NOS * (Llevels-1)
mynames = y.names = NULL
- for(iii in 1:NOS) {
- Y.names = paste("Y", iii, sep="")
- mu.names = paste("mu", iii, ".", sep="")
+ for (iii in 1:NOS) {
+ Y.names = paste("Y", iii, sep = "")
+ mu.names = paste("mu", iii, ".", sep = "")
mynames = c(mynames, if ( .reverse )
- paste("P[",Y.names,">=",2:Llevels,"]", sep="") else
- paste("P[",Y.names,"<=",1:(Llevels-1),"]", sep=""))
- y.names = c(y.names, paste(mu.names, 1:Llevels, sep=""))
+ paste("P[",Y.names,">=",2:Llevels,"]", sep = "") else
+ paste("P[",Y.names,"<=",1:(Llevels-1),"]", sep = ""))
+ y.names = c(y.names, paste(mu.names, 1:Llevels, sep = ""))
}
predictors.names = namesof(mynames, .link, short = TRUE, earg = .earg)
extra$NOS = NOS
extra$Llevels = Llevels
} else {
- delete.zero.colns=TRUE # Cannot have FALSE since then prob(Y=jay)=0
+ delete.zero.colns = TRUE # Cannot have FALSE since then prob(Y=jay)=0
eval(process.categorical.data.vgam)
M = ncol(y)-1
mynames = if ( .reverse )
@@ -714,7 +717,7 @@ vglm.vcategorical.control = function(maxit=30, trace=FALSE, panic=TRUE, ...)
y.names = paste("mu", 1:(M+1), sep = "")
if (ncol(cbind(w)) == 1) {
if (length(mustart) && all(c(y) %in% c(0, 1)))
- for(iii in 1:ncol(y))
+ for (iii in 1:ncol(y))
mustart[,iii] = weighted.mean(y[,iii], w)
}
@@ -722,13 +725,13 @@ vglm.vcategorical.control = function(maxit=30, trace=FALSE, panic=TRUE, ...)
extra$dimnamesy2 = dimnames(y)[[2]]
}
}), list( .link = link, .reverse = reverse, .mv = mv, .earg = earg ))),
- inverse = eval(substitute( function(eta, extra = NULL) {
+ linkinv = eval(substitute( function(eta, extra = NULL) {
answer =
if ( .mv ) {
NOS = extra$NOS
Llevels = extra$Llevels
fv.matrix = matrix(0, nrow(eta), NOS*Llevels)
- for(iii in 1:NOS) {
+ for (iii in 1:NOS) {
cindex = (iii-1)*(Llevels-1) + 1:(Llevels-1)
aindex = (iii-1)*(Llevels) + 1:(Llevels)
if ( .reverse ) {
@@ -768,7 +771,7 @@ vglm.vcategorical.control = function(maxit=30, trace=FALSE, panic=TRUE, ...)
names(misc$link) = mynames
misc$earg = vector("list", M)
names(misc$earg) = names(misc$link)
- for(ii in 1:M) misc$earg[[ii]] = .earg
+ for (ii in 1:M) misc$earg[[ii]] = .earg
}
misc$parameters = mynames
@@ -777,13 +780,13 @@ vglm.vcategorical.control = function(maxit=30, trace=FALSE, panic=TRUE, ...)
misc$mv = .mv
}), list( .link = link, .reverse = reverse, .parallel = parallel,
.mv = mv, .earg = earg ))),
- link = eval(substitute( function(mu, extra = NULL) {
+ linkfun = eval(substitute( function(mu, extra = NULL) {
answer =
if ( .mv ) {
NOS = extra$NOS
Llevels = extra$Llevels
eta.matrix = matrix(0, nrow(mu), NOS*(Llevels-1))
- for(iii in 1:NOS) {
+ for (iii in 1:NOS) {
cindex = (iii-1)*(Llevels-1) + 1:(Llevels-1)
aindex = (iii-1)*(Llevels) + 1:(Llevels)
cump = tapplymat1(as.matrix(mu[,aindex]), "cumsum")
@@ -825,7 +828,7 @@ vglm.vcategorical.control = function(maxit=30, trace=FALSE, panic=TRUE, ...)
NOS = extra$NOS
Llevels = extra$Llevels
dcump.deta = resmat = matrix(0, n, NOS * (Llevels-1))
- for(iii in 1:NOS) {
+ for (iii in 1:NOS) {
cindex = (iii-1)*(Llevels-1) + 1:(Llevels-1)
aindex = (iii-1)*(Llevels) + 1:(Llevels-1)
cump = eta2theta(eta[,cindex, drop = FALSE], .link, earg = .earg)
@@ -848,7 +851,7 @@ vglm.vcategorical.control = function(maxit=30, trace=FALSE, panic=TRUE, ...)
NOS = extra$NOS
Llevels = extra$Llevels
wz = matrix(0, n, NOS*(Llevels-1)) # Diagonal elts only for a start
- for(iii in 1:NOS) {
+ for (iii in 1:NOS) {
cindex = (iii-1)*(Llevels-1) + 1:(Llevels-1)
aindex = (iii-1)*(Llevels) + 1:(Llevels-1)
wz[,cindex] = c(w) * dcump.deta[,cindex, drop = FALSE]^2 *
@@ -865,7 +868,7 @@ vglm.vcategorical.control = function(maxit=30, trace=FALSE, panic=TRUE, ...)
if (NOS > 1) {
cptrwz = ncol(wz) # Like a pointer
wz = cbind(wz, matrix(0, nrow(wz), (NOS-1) * (Llevels-1)))
- for(iii in 2:NOS) {
+ for (iii in 2:NOS) {
oindex = (iii-1)*(Llevels-1) + 1:(Llevels-2)
wz[,cptrwz + 1 + (1:(Llevels-2))] =
-c(w) * dcump.deta[,oindex] *
@@ -927,15 +930,15 @@ vglm.vcategorical.control = function(maxit=30, trace=FALSE, panic=TRUE, ...)
eval(process.categorical.data.vgam)
M = ncol(y) - 1
mynames = if ( .reverse )
- paste("P[Y=", 1:M, "]/P[Y=", 2:(M+1), "]", sep="") else
- paste("P[Y=", 2:(M+1), "]/P[Y=", 1:M, "]", sep="")
+ paste("P[Y=", 1:M, "]/P[Y=", 2:(M+1), "]", sep = "") else
+ paste("P[Y=", 2:(M+1), "]/P[Y=", 1:M, "]", sep = "")
predictors.names = namesof(mynames, .link, short = TRUE, earg = .earg)
- y.names = paste("mu", 1:(M+1), sep="")
+ y.names = paste("mu", 1:(M+1), sep = "")
if (length(dimnames(y)))
extra$dimnamesy2 = dimnames(y)[[2]]
}), list( .earg = earg, .link = link, .reverse = reverse ))),
- inverse = eval(substitute( function(eta, extra = NULL) {
+ linkinv = eval(substitute( function(eta, extra = NULL) {
if (!is.matrix(eta))
eta = as.matrix(eta)
M = ncol(eta)
@@ -958,12 +961,12 @@ vglm.vcategorical.control = function(maxit=30, trace=FALSE, panic=TRUE, ...)
misc$earg = vector("list", M)
names(misc$earg) = names(misc$link)
- for(ii in 1:M) misc$earg[[ii]] = .earg
+ for (ii in 1:M) misc$earg[[ii]] = .earg
misc$parameters = mynames
misc$reverse = .reverse
}), list( .earg = earg, .link = link, .reverse = reverse ))),
- link = eval(substitute( function(mu, extra = NULL) {
+ linkfun = eval(substitute( function(mu, extra = NULL) {
M = ncol(mu) - 1
theta2eta(if ( .reverse ) mu[,1:M] / mu[,-1] else
mu[,-1] / mu[,1:M], .link, earg = .earg )
@@ -1005,8 +1008,8 @@ vglm.vcategorical.control = function(maxit=30, trace=FALSE, panic=TRUE, ...)
hess = attr(d1, "hessian") / d1
if (M > 1)
- for(jay in 1:(M-1))
- for(kay in (jay+1):M)
+ for (jay in 1:(M-1))
+ for (kay in (jay+1):M)
wz[,iam(jay,kay,M)] = (hess[,jay,kay] - score[,jay] *
score[,kay]) * dzeta.deta[,jay] * dzeta.deta[,kay]
if ( .reverse ) {
@@ -1025,7 +1028,7 @@ acat.deriv = function(zeta, reverse, M, n)
{
alltxt = NULL
- for(ii in 1:M) {
+ for (ii in 1:M) {
index = if (reverse) ii:M else 1:ii
vars = paste("zeta", index, sep = "")
txt = paste(vars, collapse = "*")
@@ -1035,12 +1038,12 @@ acat.deriv = function(zeta, reverse, M, n)
alltxt = paste(" ~ 1 +", alltxt)
txt = as.formula(alltxt)
- allvars = paste("zeta", 1:M, sep="")
- d1 = deriv3(txt, allvars, hessian=TRUE) # deriv3() computes the Hessian
+ allvars = paste("zeta", 1:M, sep = "")
+ d1 = deriv3(txt, allvars, hessian = TRUE) # deriv3() computes the Hessian
zeta = as.matrix(zeta)
- for(ii in 1:M)
- assign(paste("zeta", ii, sep=""), zeta[,ii])
+ for (ii in 1:M)
+ assign(paste("zeta", ii, sep = ""), zeta[,ii])
ans = eval(d1)
ans
@@ -1053,12 +1056,12 @@ acat.deriv = function(zeta, reverse, M, n)
refvalue = 1,
init.alpha = 1)
{
- if (!is.Numeric(init.alpha, posit=TRUE))
+ if (!is.Numeric(init.alpha, posit = TRUE))
stop("'init.alpha' must contain positive values only")
- if (!is.Numeric(refvalue, allow=1, posit=TRUE))
+ if (!is.Numeric(refvalue, allow=1, posit = TRUE))
stop("'refvalue' must be a single positive value")
if (!is.character(refgp) &&
- !is.Numeric(refgp, allow=1, integer=TRUE, posit=TRUE))
+ !is.Numeric(refgp, allow=1, integer = TRUE, posit = TRUE))
stop("'refgp' must be a single positive integer")
new("vglmff",
@@ -1073,20 +1076,20 @@ acat.deriv = function(zeta, reverse, M, n)
try.index = 1:400
M = (1:length(try.index))[(try.index+1)*(try.index) == ncol(y)]
if (!is.finite(M)) stop("cannot determine 'M'")
- init.alpha = matrix( rep( .init.alpha, len=M), n, M, byrow=TRUE)
- etastart = matrix(theta2eta(init.alpha, "loge", earg = list()), n, M, byrow=TRUE)
+ init.alpha = matrix( rep( .init.alpha, len=M), n, M, byrow = TRUE)
+ etastart = matrix(theta2eta(init.alpha, "loge", earg = list()), n, M, byrow = TRUE)
refgp = .refgp
if (!intercept.only)
warning("this function only works with intercept-only models")
extra$ybrat.indices = .brat.indices(NCo=M+1, are.ties=FALSE)
uindex = if ( .refgp =="last") 1:M else (1:(M+1))[-( .refgp ) ]
- predictors.names=namesof(paste("alpha",uindex,sep=""),"loge",short = TRUE)
+ predictors.names=namesof(paste("alpha",uindex,sep = ""),"loge",short = TRUE)
}), list( .refgp = refgp, .init.alpha=init.alpha ))),
- inverse = eval(substitute( function(eta, extra = NULL) {
+ linkinv = eval(substitute( function(eta, extra = NULL) {
probs = NULL
eta = as.matrix(eta) # in case M=1
- for(ii in 1:nrow(eta)) {
+ for (ii in 1:nrow(eta)) {
alpha = .brat.alpha(eta2theta(eta[ii,], "loge", earg = list()),
.refvalue, .refgp)
alpha1 = alpha[extra$ybrat.indices[,"rindex"]]
@@ -1098,7 +1101,7 @@ acat.deriv = function(zeta, reverse, M, n)
}, list( .refgp = refgp, .refvalue = refvalue) )),
last = eval(substitute(expression({
misc$link = rep( "loge", length=M)
- names(misc$link) = paste("alpha",uindex,sep="")
+ names(misc$link) = paste("alpha",uindex,sep = "")
misc$refgp = .refgp
misc$refvalue = .refvalue
}), list( .refgp = refgp, .refvalue = refvalue ))),
@@ -1124,12 +1127,12 @@ acat.deriv = function(zeta, reverse, M, n)
ans = NULL
uindex = if ( .refgp =="last") 1:M else (1:(M+1))[-( .refgp ) ]
eta = as.matrix(eta) # in case M=1
- for(ii in 1:nrow(eta)) {
+ for (ii in 1:nrow(eta)) {
alpha = .brat.alpha(eta2theta(eta[ii,], "loge", earg = list()),
.refvalue, .refgp)
ymat = InverseBrat(y[ii,], NCo=M+1, diag=0)
answer = rep(0, len=M)
- for(aa in 1:(M+1)) {
+ for (aa in 1:(M+1)) {
answer = answer + (1-(aa==uindex)) *
(ymat[uindex,aa] * alpha[aa] - ymat[aa,uindex] *
alpha[uindex]) / (alpha[aa] + alpha[uindex])
@@ -1141,17 +1144,17 @@ acat.deriv = function(zeta, reverse, M, n)
}), list( .refvalue = refvalue, .refgp = refgp) )),
weight = eval(substitute(expression({
wz = matrix(0, n, dimm(M))
- for(ii in 1:nrow(eta)) {
+ for (ii in 1:nrow(eta)) {
alpha = .brat.alpha(eta2theta(eta[ii,], "loge", earg = list()),
.refvalue, .refgp)
ymat = InverseBrat(y[ii,], NCo=M+1, diag=0)
- for(aa in 1:(M+1)) {
+ for (aa in 1:(M+1)) {
wz[ii,1:M] = wz[ii,1:M] + (1-(aa==uindex)) *
(ymat[aa,uindex] + ymat[uindex,aa]) * alpha[aa] *
alpha[uindex] / (alpha[aa] + alpha[uindex])^2
}
if (M > 1) {
- ind5 = iam(1,1,M, both=TRUE, diag=FALSE)
+ ind5 = iam(1,1,M, both = TRUE, diag=FALSE)
wz[ii,(M+1):ncol(wz)] =
-(ymat[cbind(uindex[ind5$row],uindex[ind5$col])] +
ymat[cbind(uindex[ind5$col],uindex[ind5$row])]) *
@@ -1172,14 +1175,14 @@ bratt = function(refgp="last",
init.alpha = 1,
i0 = 0.01)
{
- if (!is.Numeric(i0, allow=1, positi=TRUE))
+ if (!is.Numeric(i0, allow=1, positi = TRUE))
stop("'i0' must be a single positive value")
- if (!is.Numeric(init.alpha, positi=TRUE))
+ if (!is.Numeric(init.alpha, positi = TRUE))
stop("'init.alpha' must contain positive values only")
- if (!is.Numeric(refvalue, allow=1, positi=TRUE))
+ if (!is.Numeric(refvalue, allow=1, positi = TRUE))
stop("'refvalue' must be a single positive value")
if (!is.character(refgp) &&
- !is.Numeric(refgp, allow=1, integer=TRUE, positi=TRUE))
+ !is.Numeric(refgp, allow=1, integer = TRUE, positi = TRUE))
stop("'refgp' must be a single positive integer")
new("vglmff",
blurb = c(paste("Bradley-Terry model (with ties)\n\n"),
@@ -1188,7 +1191,7 @@ bratt = function(refgp="last",
initialize = eval(substitute(expression({
try.index = 1:400
M = (1:length(try.index))[(try.index*(try.index-1)) == ncol(y)]
- if (!is.Numeric(M, allow=1, integ=TRUE)) stop("cannot determine 'M'")
+ if (!is.Numeric(M, allow=1, integ = TRUE)) stop("cannot determine 'M'")
NCo = M # number of contestants
are.ties = attr(y, "are.ties") # If Brat() was used
@@ -1204,27 +1207,27 @@ bratt = function(refgp="last",
init.alpha = rep( .init.alpha, len=NCo-1)
ialpha0 = .i0
etastart = cbind(matrix(theta2eta(init.alpha, "loge"),
- n, NCo-1, byrow=TRUE),
+ n, NCo-1, byrow = TRUE),
theta2eta( rep(ialpha0, len=n), "loge"))
refgp = .refgp
if (!intercept.only)
warning("this function only works with intercept-only models")
extra$ties = ties # Flat (1-row) matrix
extra$ybrat.indices = .brat.indices(NCo=NCo, are.ties=FALSE)
- extra$tbrat.indices = .brat.indices(NCo=NCo, are.ties=TRUE) # unused
+ extra$tbrat.indices = .brat.indices(NCo=NCo, are.ties = TRUE) # unused
extra$dnties = dimnames(ties)
uindex = if (refgp=="last") 1:(NCo-1) else (1:(NCo))[-refgp ]
predictors.names=c(
- namesof(paste("alpha",uindex,sep=""),"loge",short = TRUE),
+ namesof(paste("alpha",uindex,sep = ""),"loge",short = TRUE),
namesof("alpha0", "loge", short = TRUE))
}), list( .refgp = refgp,
.i0 = i0,
.init.alpha=init.alpha ))),
- inverse = eval(substitute( function(eta, extra = NULL) {
+ linkinv = eval(substitute( function(eta, extra = NULL) {
probs = qprobs = NULL
M = ncol(eta)
- for(ii in 1:nrow(eta)) {
+ for (ii in 1:nrow(eta)) {
alpha = .brat.alpha(eta2theta(eta[ii,-M],"loge"), .refvalue, .refgp)
alpha0 = eta2theta(eta[ii,M], "loge")
alpha1 = alpha[extra$ybrat.indices[,"rindex"]]
@@ -1239,7 +1242,7 @@ bratt = function(refgp="last",
}, list( .refgp = refgp, .refvalue = refvalue) )),
last = eval(substitute(expression({
misc$link = rep( "loge", length=M)
- names(misc$link) = c(paste("alpha",uindex,sep=""), "alpha0")
+ names(misc$link) = c(paste("alpha",uindex,sep = ""), "alpha0")
misc$refgp = .refgp
misc$refvalue = .refvalue
misc$alpha = alpha
@@ -1258,13 +1261,13 @@ bratt = function(refgp="last",
NCo = M
uindex = if ( .refgp =="last") 1:(M-1) else (1:(M))[-( .refgp )]
eta = as.matrix(eta)
- for(ii in 1:nrow(eta)) {
+ for (ii in 1:nrow(eta)) {
alpha = .brat.alpha(eta2theta(eta[ii,-M],"loge"), .refvalue, .refgp)
alpha0 = eta2theta(eta[ii,M], "loge") # M == ncol(eta)
ymat = InverseBrat(y[ii,], NCo=M, diag=0)
tmat = InverseBrat(ties[ii,], NCo=M, diag=0)
answer = rep(0, len=NCo-1) # deriv wrt eta[-M]
- for(aa in 1:NCo) {
+ for (aa in 1:NCo) {
Daj = alpha[aa] + alpha[uindex] + alpha0
pja = alpha[uindex] / Daj
answer = answer + alpha[uindex] *
@@ -1272,8 +1275,8 @@ bratt = function(refgp="last",
tmat[uindex,aa]) / Daj
}
deriv0 = 0 # deriv wrt eta[M]
- for(aa in 1:(NCo-1))
- for(bb in (aa+1):NCo) {
+ for (aa in 1:(NCo-1))
+ for (bb in (aa+1):NCo) {
Dab = alpha[aa] + alpha[bb] + alpha0
qab = alpha0 / Dab
deriv0 = deriv0 + alpha0 *
@@ -1287,19 +1290,19 @@ bratt = function(refgp="last",
}), list( .refvalue = refvalue, .refgp = refgp) )),
weight = eval(substitute(expression({
wz = matrix(0, n, dimm(M)) # includes diagonal
- for(ii in 1:nrow(eta)) {
+ for (ii in 1:nrow(eta)) {
alpha = .brat.alpha(eta2theta(eta[ii,-M],"loge"), .refvalue, .refgp)
alpha0 = eta2theta(eta[ii,M], "loge") # M == ncol(eta)
ymat = InverseBrat(y[ii,], NCo=M, diag=0)
tmat = InverseBrat(ties[ii,], NCo=M, diag=0)
- for(aa in 1:(NCo)) {
+ for (aa in 1:(NCo)) {
Daj = alpha[aa] + alpha[uindex] + alpha0
pja = alpha[uindex] / Daj
nja = ymat[aa,uindex] + ymat[uindex,aa] + tmat[uindex,aa]
wz[ii,1:(NCo-1)] = wz[ii,1:(NCo-1)] +
alpha[uindex]^2 * nja * (1-pja)/(pja * Daj^2)
if (aa < NCo)
- for(bb in (aa+1):(NCo)) {
+ for (bb in (aa+1):(NCo)) {
nab = ymat[aa,bb] + ymat[bb,aa] + tmat[bb,aa]
Dab = alpha[aa] + alpha[bb] + alpha0
qab = alpha0 / Dab
@@ -1308,7 +1311,7 @@ bratt = function(refgp="last",
}
}
if (NCo > 2) {
- ind5 = iam(1,1, M=NCo, both=TRUE, diag=FALSE)
+ ind5 = iam(1,1, M=NCo, both = TRUE, diag=FALSE)
alphajunk = c(alpha, junk=NA)
mat4 = cbind(uindex[ind5$row],uindex[ind5$col])
wz[ii,(M+1):ncol(wz)] = -(ymat[mat4] + ymat[mat4[,2:1]] +
@@ -1316,11 +1319,11 @@ bratt = function(refgp="last",
alphajunk[uindex[ind5$row]] / (alpha0 +
alphajunk[uindex[ind5$row]] + alphajunk[uindex[ind5$col]])^2
}
- for(sss in 1:length(uindex)) {
+ for (sss in 1:length(uindex)) {
jay = uindex[sss]
naj = ymat[,jay] + ymat[jay,] + tmat[,jay]
Daj = alpha[jay] + alpha + alpha0
- wz[ii,iam(sss, NCo, M=NCo, diag=TRUE)] =
+ wz[ii,iam(sss, NCo, M=NCo, diag = TRUE)] =
-alpha[jay] * alpha0 * sum(naj / Daj^2)
}
}
@@ -1339,7 +1342,7 @@ bratt = function(refgp="last",
}
.brat.indices = function(NCo, are.ties=FALSE) {
- if (!is.Numeric(NCo, allow=1, integ=TRUE) || NCo < 2)
+ if (!is.Numeric(NCo, allow=1, integ = TRUE) || NCo < 2)
stop("bad input for 'NCo'")
m = diag(NCo)
if (are.ties) {
@@ -1354,7 +1357,7 @@ Brat = function(mat, ties=0*mat, string=c(" > "," == ")) {
callit = if (length(names(allargs))) names(allargs) else
as.character(1:length(allargs))
ans = ans.ties = NULL
- for(ii in 1:length(allargs)) {
+ for (ii in 1:length(allargs)) {
m = allargs[[ii]]
if (!is.matrix(m) || dim(m)[1] != dim(m)[2])
stop("m must be a square matrix")
@@ -1374,8 +1377,8 @@ Brat = function(mat, ties=0*mat, string=c(" > "," == ")) {
dt = as.data.frame.table(ties)
dm = dm[!is.na(dm$Freq),]
dt = dt[!is.na(dt$Freq),]
- usethis1 = paste(dm[,1], string[1], dm[,2], sep="")
- usethis2 = paste(dm[,1], string[2], dm[,2], sep="")
+ usethis1 = paste(dm[,1], string[1], dm[,2], sep = "")
+ usethis2 = paste(dm[,1], string[2], dm[,2], sep = "")
ans = rbind(ans, matrix(dm$Freq, nrow=1))
ans.ties = rbind(ans.ties, matrix(dt$Freq, nrow=1))
}
@@ -1395,9 +1398,9 @@ InverseBrat = function(yvec, NCo =
yvec.orig = yvec
yvec = c(yvec)
ptr = 1
- for(mul in 1:multiplicity)
- for(i1 in 1:(NCo))
- for(i2 in 1:(NCo))
+ for (mul in 1:multiplicity)
+ for (i1 in 1:(NCo))
+ for (i2 in 1:(NCo))
if (i1 != i2) {
ans[i2,i1,mul] = yvec[ptr]
ptr = ptr + 1
@@ -1408,7 +1411,7 @@ InverseBrat = function(yvec, NCo =
names.yvec = dimnames(yvec.orig)[[2]]
ii = strsplit(names.yvec, string[1])
cal = NULL
- for(kk in c(NCo, 1:(NCo-1)))
+ for (kk in c(NCo, 1:(NCo-1)))
cal = c(cal, (ii[[kk]])[1])
if (multiplicity>1) {
dimnames(ans) = list(cal, cal, dimnames(yvec.orig)[[1]])
@@ -1451,14 +1454,14 @@ tapplymat1 = function(mat, function.arg=c("cumsum", "diff", "cumprod"))
ordpoisson = function(cutpoints,
- countdata=FALSE, NOS=NULL, Levels=NULL,
+ countdata=FALSE, NOS = NULL, Levels = NULL,
init.mu = NULL, parallel = FALSE, zero = NULL,
link = "loge", earg = list()) {
if (mode(link) != "character" && mode(link) != "name")
link = as.character(substitute(link))
if (!is.list(earg)) earg = list()
fcutpoints = cutpoints[is.finite(cutpoints)]
- if (!is.Numeric(fcutpoints, integ=TRUE) || any(fcutpoints < 0))
+ if (!is.Numeric(fcutpoints, integ = TRUE) || any(fcutpoints < 0))
stop("'cutpoints' must have non-negative integer or Inf values only")
if (is.finite(cutpoints[length(cutpoints)]))
cutpoints = c(cutpoints, Inf)
@@ -1466,9 +1469,9 @@ tapplymat1 = function(mat, function.arg=c("cumsum", "diff", "cumprod"))
if (!is.logical(countdata) || length(countdata) != 1)
stop("argument 'countdata' must be a single logical")
if (countdata) {
- if (!is.Numeric(NOS, integ=TRUE, posit=TRUE))
+ if (!is.Numeric(NOS, integ = TRUE, posit = TRUE))
stop("'NOS' must have integer values only")
- if (!is.Numeric(Levels, integ=TRUE, posit=TRUE) || any(Levels < 2))
+ if (!is.Numeric(Levels, integ = TRUE, posit = TRUE) || any(Levels < 2))
stop("'Levels' must have integer values (>= 2) only")
Levels = rep(Levels, length=NOS)
}
@@ -1478,7 +1481,7 @@ tapplymat1 = function(mat, function.arg=c("cumsum", "diff", "cumprod"))
"Link: ", namesof("mu", link, earg = earg)),
constraints = eval(substitute(expression({
constraints = cm.vgam(matrix(1,M,1), x, .parallel, constraints,
- intercept.apply=TRUE)
+ intercept.apply = TRUE)
constraints = cm.zero.vgam(constraints, x, .zero, M)
}), list( .parallel = parallel, .zero = zero ))),
initialize = eval(substitute(expression({
@@ -1494,7 +1497,7 @@ tapplymat1 = function(mat, function.arg=c("cumsum", "diff", "cumprod"))
ncol(orig.y)
Levels = rep( if (is.Numeric( .Levels )) .Levels else 0, len=NOS)
if (!is.Numeric( .Levels ))
- for(iii in 1:NOS) {
+ for (iii in 1:NOS) {
Levels[iii] = length(unique(sort(orig.y[,iii])))
}
extra$Levels = Levels
@@ -1507,7 +1510,7 @@ tapplymat1 = function(mat, function.arg=c("cumsum", "diff", "cumprod"))
use.y = if ( .countdata ) y else matrix(0, n, sum(Levels))
use.etastart = matrix(0, n, M)
cptr = 1
- for(iii in 1:NOS) {
+ for (iii in 1:NOS) {
y = factor(orig.y[,iii], levels=(1:Levels[iii]))
if ( !( .countdata )) {
eval(process.categorical.data.vgam) # Creates mustart and y
@@ -1521,8 +1524,8 @@ tapplymat1 = function(mat, function.arg=c("cumsum", "diff", "cumprod"))
etastart = theta2eta(use.etastart, .link, earg = .earg)
y = use.y # n x sum(Levels)
M = NOS
- for(iii in 1:NOS) {
- mu.names = paste("mu", iii, ".", sep="")
+ for (iii in 1:NOS) {
+ mu.names = paste("mu", iii, ".", sep = "")
}
ncoly = extra$ncoly = sum(Levels)
@@ -1530,13 +1533,13 @@ tapplymat1 = function(mat, function.arg=c("cumsum", "diff", "cumprod"))
extra$countdata = .countdata
extra$cutpoints = cp.vector
extra$n = n
- mynames = if (M > 1) paste("mu",1:M,sep="") else "mu"
+ mynames = if (M > 1) paste("mu",1:M,sep = "") else "mu"
predictors.names = namesof(mynames, .link, short = TRUE, earg = .earg)
}), list( .link = link, .countdata = countdata, .earg = earg,
.cutpoints=cutpoints, .NOS=NOS, .Levels=Levels,
.init.mu = init.mu
))),
- inverse = eval(substitute( function(eta, extra = NULL) {
+ linkinv = eval(substitute( function(eta, extra = NULL) {
mu = eta2theta(eta, link= .link, earg = .earg) # Poisson means
mu = cbind(mu)
mu
@@ -1550,7 +1553,7 @@ tapplymat1 = function(mat, function.arg=c("cumsum", "diff", "cumprod"))
names(misc$link) = mynames
misc$earg = vector("list", M)
names(misc$earg) = names(misc$link)
- for(ii in 1:M) misc$earg[[ii]] = .earg
+ for (ii in 1:M) misc$earg[[ii]] = .earg
}
misc$parameters = mynames
misc$countdata = .countdata
@@ -1580,8 +1583,8 @@ tapplymat1 = function(mat, function.arg=c("cumsum", "diff", "cumprod"))
dmu.deta = dtheta.deta(mu, .link, earg=.earg)
dprob.dmu = ordpoissonProbs(extra, mu, deriv=1)
cptr = 1
- for(iii in 1:NOS) {
- for(kkk in 1:Levels[iii]) {
+ for (iii in 1:NOS) {
+ for (kkk in 1:Levels[iii]) {
resmat[,iii] = resmat[,iii] + dl.dprob[,cptr] * dprob.dmu[,cptr]
cptr = cptr + 1
}
@@ -1592,8 +1595,8 @@ tapplymat1 = function(mat, function.arg=c("cumsum", "diff", "cumprod"))
weight = eval(substitute(expression({
d2l.dmu2 = matrix(0, n, M) # Diagonal matrix
cptr = 1
- for(iii in 1:NOS) {
- for(kkk in 1:Levels[iii]) {
+ for (iii in 1:NOS) {
+ for (kkk in 1:Levels[iii]) {
d2l.dmu2[,iii] = d2l.dmu2[,iii] +
dprob.dmu[,cptr]^2 / probs.use[,cptr]
cptr = cptr + 1
@@ -1614,7 +1617,7 @@ ordpoissonProbs = function(extra, mu, deriv=0) {
}
mu = cbind(mu)
cptr = 1
- for(iii in 1:NOS) {
+ for (iii in 1:NOS) {
if (deriv == 1) {
dprob.dmu[,cptr] = -dpois(x=cp.vector[cptr], lamb=mu[,iii])
} else {
@@ -1661,7 +1664,7 @@ ordpoissonProbs = function(extra, mu, deriv=0) {
if (mode(lscale) != "character" && mode(lscale) != "name")
lscale = as.character(substitute(lscale))
if (!is.list(escale)) escale = list()
- if (!is.Numeric(iscale, posit=TRUE))
+ if (!is.Numeric(iscale, posit = TRUE))
stop("bad input for argument 'iscale'")
if (!is.logical(reverse) || length(reverse) != 1)
stop("argument 'reverse' must be a single logical")
@@ -1680,16 +1683,16 @@ ordpoissonProbs = function(extra, mu, deriv=0) {
constraints[["(Intercept)"]] = rbind(constraints[["(Intercept)"]],
matrix(0, J, ncol(constraints[["(Intercept)"]])))
- cm2 = cm.vgam(matrix(1,J,1), x, .sparallel, constraints=NULL,
+ cm2 = cm.vgam(matrix(1,J,1), x, .sparallel, constraints = NULL,
intercept.apply = FALSE)
- for(ii in 2:length(constraints))
+ for (ii in 2:length(constraints))
constraints[[ii]] =
cbind(rbind(constraints[[ii]],
matrix(0, J, ncol(constraints[[ii]]))),
rbind(matrix(0, J, ncol(cm2[[ii]])), cm2[[ii]]))
- for(ii in 1:length(constraints))
+ for (ii in 1:length(constraints))
constraints[[ii]] =
(constraints[[ii]])[interleave.VGAM(M, M=2),, drop = FALSE]
}), list( .parallel = parallel, .sparallel=sparallel ))),
@@ -1708,13 +1711,13 @@ ordpoissonProbs = function(extra, mu, deriv=0) {
M = 2*(ncol(y)-1)
J = M / 2
extra$J = J
- mynames = if ( .reverse ) paste("P[Y>=",2:(1+J),"]", sep="") else
- paste("P[Y<=",1:J,"]", sep="")
+ mynames = if ( .reverse ) paste("P[Y>=",2:(1+J),"]", sep = "") else
+ paste("P[Y<=",1:J,"]", sep = "")
predictors.names = c(
namesof(mynames, .link, short = TRUE, earg = .earg),
- namesof(paste("scale_", 1:J, sep=""),
+ namesof(paste("scale_", 1:J, sep = ""),
.lscale, short = TRUE, earg = .escale))
- y.names = paste("mu", 1:(J+1), sep="")
+ y.names = paste("mu", 1:(J+1), sep = "")
if (length(dimnames(y)))
extra$dimnamesy2 = dimnames(y)[[2]]
@@ -1723,7 +1726,7 @@ ordpoissonProbs = function(extra, mu, deriv=0) {
}), list( .link = link, .lscale = lscale, .reverse = reverse,
.earg = earg, .escale = escale ))),
- inverse = eval(substitute( function(eta, extra = NULL) {
+ linkinv = eval(substitute( function(eta, extra = NULL) {
J = extra$J
M = 2*J
etamat1 = eta[,2*(1:J)-1, drop = FALSE]
@@ -1749,8 +1752,8 @@ ordpoissonProbs = function(extra, mu, deriv=0) {
names(misc$link) = predictors.names
misc$earg = vector("list", M)
names(misc$earg) = names(misc$link)
- for(ii in 1:J) misc$earg[[2*ii-1]] = .earg
- for(ii in 1:J) misc$earg[[2*ii ]] = .escale
+ for (ii in 1:J) misc$earg[[2*ii-1]] = .earg
+ for (ii in 1:J) misc$earg[[2*ii ]] = .escale
misc$parameters = mynames
misc$reverse = .reverse
misc$parallel = .parallel
@@ -1758,7 +1761,7 @@ ordpoissonProbs = function(extra, mu, deriv=0) {
}), list( .link = link, .lscale = lscale,
.reverse = reverse, .parallel = parallel, .sparallel=sparallel,
.earg = earg, .escale = escale ))),
- link = eval(substitute( function(mu, extra = NULL) {
+ linkfun = eval(substitute( function(mu, extra = NULL) {
cump = tapplymat1(as.matrix(mu), "cumsum")
J = ncol(as.matrix(mu)) - 1
M = 2 * J
@@ -1766,7 +1769,7 @@ ordpoissonProbs = function(extra, mu, deriv=0) {
theta2eta(if ( .reverse ) 1-cump[,1:J] else cump[,1:J], .link,
earg= .earg),
matrix(theta2eta( .iscale, .lscale, earg = .escale),
- nrow(as.matrix(mu)), J, byrow=TRUE))
+ nrow(as.matrix(mu)), J, byrow = TRUE))
answer = answer[,interleave.VGAM(M, M=2)]
answer
}, list( .link = link, .lscale = lscale, .reverse = reverse,
@@ -1824,19 +1827,19 @@ ordpoissonProbs = function(extra, mu, deriv=0) {
(dcump.dscale * dscale.deta) *
(1/mu.use[,1:J] + 1/mu.use[,-1])
wz0 = as.matrix(wz0)
- for(ii in 1:J)
+ for (ii in 1:J)
wz[,iam(2*ii-1,2*ii,M=M)] = if (ooz) wz0[,ii] else 0
if (J > 1) {
wz0 = -c(w) * (dcump.deta[,-J] / scalemat[,-J]) *
(dcump.deta[,-1] / scalemat[,-1]) / mu.use[,2:J]
wz0 = as.matrix(wz0) # Just in case J=2
- for(ii in 1:(J-1))
+ for (ii in 1:(J-1))
wz[,iam(2*ii-1,2*ii+1,M=M)] = if (ooz) wz0[,ii] else 0
wz0 = -c(w) * (dcump.dscale[,-1] * dscale.deta[,-1]) *
(dcump.dscale[,-J] * dscale.deta[,-J]) / mu.use[,2:J]
wz0 = as.matrix(wz0)
- for(ii in 1:(J-1))
+ for (ii in 1:(J-1))
wz[,iam(2*ii,2*ii+2,M=M)] = if (ooz) wz0[,ii] else 0
@@ -1844,12 +1847,12 @@ ordpoissonProbs = function(extra, mu, deriv=0) {
wz0 = -c(w) * (dcump.deta[,-J] / scalemat[,-J]) *
(dcump.dscale[,-1] * dscale.deta[,-1]) / mu.use[,2:J]
wz0 = as.matrix(wz0)
- for(ii in 1:(J-1))
+ for (ii in 1:(J-1))
wz[,iam(2*ii-1,2*ii+2,M=M)] = if (ooz) wz0[,ii] else 0
wz0 = -c(w) * (dcump.deta[,-1] / scalemat[,-1]) *
(dcump.dscale[,-J] * dscale.deta[,-J]) / mu.use[,2:J]
wz0 = as.matrix(wz0)
- for(ii in 1:(J-1))
+ for (ii in 1:(J-1))
wz[,iam(2*ii,2*ii+1,M=M)] = if (ooz) wz0[,ii] else 0
}
wz
@@ -1861,34 +1864,35 @@ ordpoissonProbs = function(extra, mu, deriv=0) {
-margeff = function(object, subset=NULL) {
+margeff = function(object, subset = NULL) {
+
- ii = ii.save = subset
- if (!is(object, "vglm"))
- stop("'object' is not a vglm() object")
- if (!any(temp.logical <- is.element(c("multinomial","cumulative"),
- object at family@vfamily)))
- stop("'object' is not a 'multinomial' or 'cumulative' VGLM!")
- model.multinomial = temp.logical[1]
- if (is(object, "vgam"))
- stop("'object' is a vgam() object")
- if (length(object at control$xij))
- stop("'object' contains 'xij' terms")
- if (length(object at misc$form2))
- stop("'object' contains 'form2' terms")
+ ii = ii.save = subset
+ if (!is(object, "vglm"))
+ stop("'object' is not a vglm() object")
+ if (!any(temp.logical <- is.element(c("multinomial","cumulative"),
+ object at family@vfamily)))
+ stop("'object' is not a 'multinomial' or 'cumulative' VGLM!")
+ model.multinomial = temp.logical[1]
+ if (is(object, "vgam"))
+ stop("'object' is a vgam() object")
+ if (length(object at control$xij))
+ stop("'object' contains 'xij' terms")
+ if (length(object at misc$form2))
+ stop("'object' contains 'form2' terms")
- oassign = object at misc$orig.assign
- if (any(unlist(lapply(oassign, length)) > 1))
- warning("some terms in 'object' create more than one column of ",
- "the LM design matrix")
+ oassign = object at misc$orig.assign
+ if (any(unlist(lapply(oassign, length)) > 1))
+ warning("some terms in 'object' create more than one column of ",
+ "the LM design matrix")
- nnn = object at misc$n
- M = object at misc$M # ncol(B) # length(pvec) - 1
+ nnn = object at misc$n
+ M = object at misc$M # ncol(B) # length(pvec) - 1
if (model.multinomial) {
rlev = object at misc$refLevel
- cfit = coefvlm(object, matrix=TRUE)
+ cfit = coefvlm(object, matrix = TRUE)
B = if (!length(rlev)) {
cbind(cfit, 0)
} else {
@@ -1903,7 +1907,7 @@ margeff = function(object, subset=NULL) {
ppp = nrow(B)
pvec1 = fitted(object)[ 1,]
colnames(B) = if (length(names(pvec1))) names(pvec1) else
- paste("mu", 1:(M+1), sep="")
+ paste("mu", 1:(M+1), sep = "")
if (is.null(ii)) {
BB = array(B, c(ppp, M+1, nnn))
@@ -1922,21 +1926,23 @@ margeff = function(object, subset=NULL) {
} else
if (is.numeric(ii) && (length(ii) == 1)) {
pvec = fitted(object)[ii,]
- temp1 = B * matrix(pvec, ppp, M+1, byrow=TRUE)
+ temp1 = B * matrix(pvec, ppp, M+1, byrow = TRUE)
temp2 = matrix(rowSums(temp1), ppp, M+1)
- temp3 = matrix(pvec, nrow(B), M+1, byrow=TRUE)
+ temp3 = matrix(pvec, nrow(B), M+1, byrow = TRUE)
(B - temp2) * temp3
} else {
if (is.logical(ii))
ii = (1:nnn)[ii]
- ans = array(0, c(ppp, M+1, length(ii)), dimnames=list(dimnames(B)[[1]],
- dimnames(B)[[2]], dimnames(fitted(object)[ii,])[[1]]))
- for(ilocal in 1:length(ii)) {
+ ans = array(0, c(ppp, M+1, length(ii)),
+ dimnames = list(dimnames(B)[[1]],
+ dimnames(B)[[2]],
+ dimnames(fitted(object)[ii,])[[1]]))
+ for (ilocal in 1:length(ii)) {
pvec = fitted(object)[ii[ilocal],]
- temp1 = B * matrix(pvec, ppp, M+1, byrow=TRUE)
+ temp1 = B * matrix(pvec, ppp, M+1, byrow = TRUE)
temp2 = matrix(rowSums(temp1), ppp, M+1)
- temp3 = matrix(pvec, nrow(B), M+1, byrow=TRUE)
+ temp3 = matrix(pvec, nrow(B), M+1, byrow = TRUE)
ans[,,ilocal] = (B - temp2) * temp3
}
ans
@@ -1948,40 +1954,45 @@ margeff = function(object, subset=NULL) {
reverse = object at misc$reverse
linkfunctions = object at misc$link
all.eargs = object at misc$earg
- B = cfit = coefvlm(object, matrix=TRUE)
+ B = cfit = coefvlm(object, matrix = TRUE)
ppp = nrow(B)
hdot = lpmat = kronecker(predict(object), matrix(1, ppp, 1))
resmat = cbind(hdot, 1)
- for(jlocal in 1:M) {
- Cump = eta2theta(lpmat[,jlocal], link = linkfunctions[jlocal],
- earg = all.eargs[[jlocal]])
- hdot[,jlocal] = dtheta.deta(Cump, link = linkfunctions[jlocal],
- earg = all.eargs[[jlocal]])
+ for (jlocal in 1:M) {
+ Cump = eta2theta(lpmat[,jlocal],
+ link = linkfunctions[jlocal],
+ earg = all.eargs[[jlocal]])
+ hdot[, jlocal] = dtheta.deta(Cump,
+ link = linkfunctions[jlocal],
+ earg = all.eargs[[jlocal]])
}
- resmat[,1] = ifelse(reverse, -1, 1) * hdot[,1] * cfit[,1]
+ resmat[, 1] = ifelse(reverse, -1, 1) * hdot[, 1] * cfit[, 1]
if (M > 1) {
- resmat[,2:M] = ifelse(reverse, -1, 1) *
- (hdot[,(2:M) ] * cfit[,(2:M) ] -
- hdot[,(2:M)-1] * cfit[,(2:M)-1])
+ for (jlocal in 2:M)
+ resmat[, jlocal] = ifelse(reverse, -1, 1) *
+ (hdot[, jlocal ] * cfit[, jlocal ] -
+ hdot[, jlocal - 1] * cfit[, jlocal - 1])
+
}
- resmat[,M+1] = ifelse(reverse, 1, -1) * hdot[,M] * cfit[,M]
+ resmat[, M+1] = ifelse(reverse, 1, -1) * hdot[, M] * cfit[, M]
temp1 = array(resmat, c(ppp, nnn, M+1),
- dimnames=list(dimnames(B)[[1]], dimnames(fitted(object))[[1]],
- dimnames(fitted(object))[[2]]))
- temp1 = aperm(temp1, c(1,3,2)) # ppp x (M+1) x nnn
+ dimnames = list(dimnames(B)[[1]],
+ dimnames(fitted(object))[[1]],
+ dimnames(fitted(object))[[2]]))
+ temp1 = aperm(temp1, c(1, 3, 2)) # ppp x (M+1) x nnn
if (is.null(ii)) {
- return(temp1)
+ return(temp1)
} else
if (is.numeric(ii) && (length(ii) == 1)) {
- return(temp1[,,ii])
+ return(temp1[,,ii])
} else {
- return(temp1[,,ii])
+ return(temp1[,,ii])
}
}
}
@@ -2017,8 +2028,8 @@ prplot = function(object,
use.y = cbind((object at preplot[[1]])$y)
Constant = attr(object at preplot, "Constant")
if (is.numeric(Constant) && length(Constant) == ncol(use.y))
- use.y = use.y + matrix(Constant, nrow(use.y), ncol(use.y), byrow=TRUE)
- for(ii in 1:MM) {
+ use.y = use.y + matrix(Constant, nrow(use.y), ncol(use.y), byrow = TRUE)
+ for (ii in 1:MM) {
use.y[,ii] = eta2theta(use.y[,ii], link=object at misc$link[[ii]],
earg=object at misc$earg[[ii]])
}
@@ -2045,8 +2056,8 @@ prplot = function(object,
- prplot.control = function(xlab=NULL, ylab="Probability", main=NULL,
- xlim=NULL, ylim=NULL,
+ prplot.control = function(xlab = NULL, ylab="Probability", main = NULL,
+ xlim = NULL, ylim = NULL,
lty=par()$lty,
col=par()$col,
rcol=par()$col,
diff --git a/R/family.censored.R b/R/family.censored.R
index de0dc37..230b721 100644
--- a/R/family.censored.R
+++ b/R/family.censored.R
@@ -72,7 +72,7 @@
if (!length(etastart))
etastart = theta2eta(init.mu, link = .link, earg = .earg)
}), list( .link = link, .earg = earg, .imu = imu))),
- inverse = eval(substitute(function(eta, extra = NULL) {
+ linkinv = eval(substitute(function(eta, extra = NULL) {
mu = eta2theta(eta, link = .link, earg = .earg)
mu
}, list( .link = link, .earg = earg ))),
@@ -81,7 +81,7 @@
misc$link = c("mu" = .link)
misc$earg = list("mu" = .earg)
}), list( .link = link, .earg = earg ))),
- link = eval(substitute(function(mu, extra = NULL) {
+ linkfun = eval(substitute(function(mu, extra = NULL) {
theta2eta(mu, link = .link, earg = .earg)
}, list( .link = link, .earg = earg ))),
loglikelihood = function(mu, y, w, residuals = FALSE, eta,
@@ -232,7 +232,7 @@ if (FALSE)
#if(any(extra$rightcensored & extra$leftcensored))
# stop("some observations are both right and left censored!")
}), list( .location=location, .link = link ))),
- inverse = eval(substitute(function(eta, extra = NULL)
+ linkinv = eval(substitute(function(eta, extra = NULL)
extra$location + 1 / eta2theta(eta, .link),
list( .link = link ) )),
last = eval(substitute(expression({
@@ -356,7 +356,7 @@ if (FALSE)
}), list( .lmu = lmu, .lsd = lsd,
.emu = emu, .esd = esd,
.imethod = imethod ))),
- inverse = eval(substitute( function(eta, extra = NULL) {
+ linkinv = eval(substitute( function(eta, extra = NULL) {
eta2theta(eta[, 1], .lmu, earg = .emu)
}, list( .lmu = lmu, .emu = emu ))),
last = eval(substitute(expression({
@@ -506,7 +506,7 @@ if (FALSE)
etastart = theta2eta(a.init, .lscale, earg = .escale )
}
}), list( .lscale = lscale, .escale = escale ))),
- inverse = eval(substitute(function(eta, extra = NULL) {
+ linkinv = eval(substitute(function(eta, extra = NULL) {
Scale = eta2theta(eta, .lscale, earg = .escale )
Scale * sqrt(pi/2)
}, list( .lscale = lscale, .escale = escale ))),
@@ -627,7 +627,7 @@ if (FALSE)
.escale = escale, .eshape = eshape,
.iscale = iscale, .ishape = ishape,
.imethod = imethod ) )),
- inverse = eval(substitute(function(eta, extra = NULL) {
+ linkinv = eval(substitute(function(eta, extra = NULL) {
shape = eta2theta(eta[,1], .lshape, earg = .eshape )
Scale = eta2theta(eta[,2], .lscale, earg = .escale )
Scale * gamma(1 + 1 / shape)
diff --git a/R/family.circular.R b/R/family.circular.R
index e92bb25..bb0e294 100644
--- a/R/family.circular.R
+++ b/R/family.circular.R
@@ -38,12 +38,14 @@ pcard = function(q, mu, rho) {
ans
}
+
+
qcard = function(p, mu, rho, tolerance=1.0e-7, maxits=500) {
if (!is.Numeric(mu) || any(mu < 0) || any(mu > 2*pi))
stop("'mu' must be between 0 and 2*pi inclusive")
if (!is.Numeric(rho) || max(abs(rho) > 0.5))
stop("'rho' must be between -0.5 and 0.5 inclusive")
- if (!is.Numeric(p, positive=TRUE) || any(p > 1))
+ if (!is.Numeric(p, positive = TRUE) || any(p > 1))
stop("'p' must be between 0 and 1")
nn = max(length(p), length(mu), length(rho))
p = rep(p, len=nn)
@@ -58,7 +60,7 @@ qcard = function(p, mu, rho, tolerance=1.0e-7, maxits=500) {
2*pi*p) / (1 + 2 * rho * cos(oldans - mu))
index = (ans <= 0) | (ans > 2*pi)
if (any(index)) {
- ans[index] = runif(sum(index), 0, 2*pi)
+ ans[index] = runif (sum(index), 0, 2*pi)
}
if (max(abs(ans - oldans)) < tolerance) break;
if (its == maxits) {warning("did not converge"); break}
@@ -67,66 +69,69 @@ qcard = function(p, mu, rho, tolerance=1.0e-7, maxits=500) {
ans
}
+
+
rcard = function(n, mu, rho, ...) {
if (!is.Numeric(mu) || any(mu < 0) || any(mu > 2*pi))
stop("'mu' must be between 0 and 2*pi inclusive")
if (!is.Numeric(rho) || max(abs(rho) > 0.5))
stop("'rho' must be between -0.5 and 0.5 inclusive")
- if (!is.Numeric(n, positive=TRUE, integer=TRUE, allow=1))
+ if (!is.Numeric(n, positive = TRUE, integer = TRUE, allow=1))
stop("'n' must be a single positive integer")
mu = rep(mu, len=n)
rho = rep(rho, len=n)
- qcard(runif(n), mu=mu, rho=rho, ...)
+ qcard(runif (n), mu=mu, rho=rho, ...)
}
-cardioid.control <- function(save.weight=TRUE, ...)
+
+cardioid.control <- function(save.weight = TRUE, ...)
{
list(save.weight=save.weight)
}
- cardioid = function(lmu="elogit", lrho="elogit",
- emu=if(lmu=="elogit") list(min=0, max=2*pi) else list(),
- erho=if(lmu=="elogit") list(min=-0.5, max=0.5) else list(),
- imu=NULL, irho=0.3,
- nsimEIM=100, zero=NULL)
+ cardioid = function(lmu = "elogit", lrho = "elogit",
+ emu = if (lmu == "elogit") list(min=0, max=2*pi) else list(),
+ erho = if (lmu == "elogit") list(min=-0.5, max=0.5) else list(),
+ imu = NULL, irho=0.3,
+ nsimEIM=100, zero = NULL)
{
if (mode(lmu) != "character" && mode(lmu) != "name")
lmu = as.character(substitute(lmu))
if (mode(lrho) != "character" && mode(lrho) != "name")
lrho = as.character(substitute(lrho))
- if (length(imu) && (!is.Numeric(imu, positive=TRUE) || any(imu > 2*pi)))
+ if (length(imu) && (!is.Numeric(imu, positive = TRUE) || any(imu > 2*pi)))
stop("bad input for argument 'imu'")
if (!is.Numeric(irho) || max(abs(irho)) > 0.5)
stop("bad input for argument 'irho'")
if (!is.list(emu)) emu = list()
if (!is.list(erho)) erho = list()
- if (!is.Numeric(nsimEIM, allow=1, integ=TRUE) || nsimEIM <= 50)
+ if (!is.Numeric(nsimEIM, allow=1, integ = TRUE) || nsimEIM <= 50)
stop("'nsimEIM' should be an integer greater than 50")
new("vglmff",
- blurb=c("Cardioid distribution\n\n",
+ blurb = c("Cardioid distribution\n\n",
"Links: ",
- namesof("mu", lmu, earg= emu), ", ",
- namesof("rho", lrho, earg= erho, tag=FALSE), "\n",
+ namesof("mu", lmu, earg = emu), ", ",
+ namesof("rho", lrho, earg = erho, tag = FALSE), "\n",
"Mean: ",
"pi + (rho/pi) *",
"((2*pi-mu)*sin(2*pi-mu)+cos(2*pi-mu)-mu*sin(mu)-cos(mu))"),
- constraints=eval(substitute(expression({
+ constraints = eval(substitute(expression({
constraints = cm.zero.vgam(constraints, x, .zero, M)
- }), list( .zero=zero ))),
- initialize=eval(substitute(expression({
+ }), list( .zero = zero ))),
+ initialize = eval(substitute(expression({
if (ncol(y <- cbind(y)) != 1)
stop("the response must be a vector or one-column matrix")
if (any((y <= 0) | (y >=2*pi)))
stop("the response must be in (0,2*pi)")
predictors.names = c(
- namesof("mu", .lmu, earg= .emu, tag=FALSE),
- namesof("rho", .lrho, earg= .erho, tag=FALSE))
+ namesof("mu", .lmu, earg = .emu, tag = FALSE),
+ namesof("rho", .lrho, earg = .erho, tag = FALSE))
if (!length(etastart)) {
- rho.init = rep(if(length(.irho)) .irho else 0.3, length=n)
+ rho.init = rep(if (length(.irho)) .irho else 0.3, length=n)
cardioid.Loglikfun = function(mu, y, x, w, extraargs) {
rho = extraargs$irho
@@ -135,54 +140,54 @@ cardioid.control <- function(save.weight=TRUE, ...)
mu.grid = seq(0.1, 6.0, len=19)
mu.init = if (length( .imu )) .imu else
getMaxMin(mu.grid, objfun=cardioid.Loglikfun, y=y, x=x, w=w,
- extraargs=list(irho = rho.init))
+ extraargs = list(irho = rho.init))
mu.init = rep(mu.init, length=length(y))
- etastart = cbind(theta2eta(mu.init, .lmu, earg= .emu),
- theta2eta(rho.init, .lrho, earg= .erho))
+ etastart = cbind(theta2eta(mu.init, .lmu, earg = .emu),
+ theta2eta(rho.init, .lrho, earg = .erho))
}
- }), list( .lmu=lmu, .lrho=lrho,
- .imu=imu, .irho=irho,
- .emu=emu, .erho=erho ))),
- inverse=eval(substitute(function(eta, extra=NULL){
- mu = eta2theta(eta[,1], link= .lmu, earg= .emu)
- rho = eta2theta(eta[,2], link= .lrho, earg= .erho)
+ }), list( .lmu = lmu, .lrho = lrho,
+ .imu = imu, .irho = irho,
+ .emu = emu, .erho = erho ))),
+ linkinv = eval(substitute(function(eta, extra = NULL){
+ mu = eta2theta(eta[,1], link= .lmu, earg = .emu)
+ rho = eta2theta(eta[,2], link= .lrho, earg = .erho)
pi + (rho/pi) *
((2*pi-mu)*sin(2*pi-mu) + cos(2*pi-mu) - mu*sin(mu) - cos(mu))
- }, list( .lmu=lmu, .lrho=lrho,
- .emu=emu, .erho=erho ))),
- last=eval(substitute(expression({
- misc$link = c("mu"= .lmu, "rho"= .lrho)
+ }, list( .lmu = lmu, .lrho = lrho,
+ .emu = emu, .erho = erho ))),
+ last = eval(substitute(expression({
+ misc$link = c("mu"= .lmu, "rho"= .lrho)
misc$earg = list("mu"= .emu, "rho"= .erho)
misc$expected = TRUE
misc$nsimEIM = .nsimEIM
- }), list( .lmu=lmu, .lrho=lrho,
- .emu=emu, .erho=erho, .nsimEIM=nsimEIM ))),
+ }), list( .lmu = lmu, .lrho = lrho,
+ .emu = emu, .erho = erho, .nsimEIM = nsimEIM ))),
loglikelihood=eval(substitute(
- function(mu,y,w,residuals=FALSE,eta,extra=NULL) {
- mu = eta2theta(eta[,1], link= .lmu, earg= .emu)
- rho = eta2theta(eta[,2], link= .lrho, earg= .erho)
+ function(mu, y, w, residuals = FALSE, eta, extra = NULL) {
+ mu = eta2theta(eta[,1], link= .lmu, earg = .emu)
+ rho = eta2theta(eta[,2], link= .lrho, earg = .erho)
if (residuals) stop("loglikelihood residuals not ",
"implemented yet") else {
- sum(w * dcard(x=y, mu=mu, rho=rho, log=TRUE))
+ sum(w * dcard(x=y, mu=mu, rho=rho, log = TRUE))
}
- }, list( .lmu=lmu, .lrho=lrho,
- .emu=emu, .erho=erho ))),
+ }, list( .lmu = lmu, .lrho=lrho,
+ .emu = emu, .erho=erho ))),
vfamily=c("cardioid"),
deriv=eval(substitute(expression({
- mu = eta2theta(eta[,1], link= .lmu, earg= .emu)
- rho = eta2theta(eta[,2], link= .lrho, earg= .erho)
- dmu.deta = dtheta.deta(mu, link= .lmu, earg= .emu)
- drho.deta = dtheta.deta(rho, link= .lrho, earg= .erho)
+ mu = eta2theta(eta[,1], link= .lmu, earg = .emu)
+ rho = eta2theta(eta[,2], link= .lrho, earg = .erho)
+ dmu.deta = dtheta.deta(mu, link= .lmu, earg = .emu)
+ drho.deta = dtheta.deta(rho, link= .lrho, earg = .erho)
dl.dmu = 2 * rho * sin(y-mu) / (1 + 2 * rho * cos(y-mu))
dl.drho = 2 * cos(y-mu) / (1 + 2 * rho * cos(y-mu))
c(w) * cbind(dl.dmu * dmu.deta,
dl.drho * drho.deta)
- }), list( .lmu=lmu, .lrho=lrho,
- .emu=emu, .erho=erho, .nsimEIM=nsimEIM ))),
+ }), list( .lmu = lmu, .lrho=lrho,
+ .emu = emu, .erho=erho, .nsimEIM=nsimEIM ))),
weight = eval(substitute(expression({
run.varcov = 0
- ind1 = iam(NA, NA, M=M, both=TRUE, diag=TRUE)
- index0 = iam(NA, NA, M=M, both=TRUE, diag=TRUE)
+ ind1 = iam(NA, NA, M = M, both = TRUE, diag = TRUE)
+ index0 = iam(NA, NA, M = M, both = TRUE, diag = TRUE)
for(ii in 1:( .nsimEIM )) {
ysim = rcard(n, mu=mu, rho=rho)
dl.dmu = 2 * rho * sin(ysim-mu) / (1 + 2 * rho * cos(ysim-mu))
@@ -194,50 +199,50 @@ cardioid.control <- function(save.weight=TRUE, ...)
}
wz = if (intercept.only)
matrix(colMeans(run.varcov),
- n, ncol(run.varcov), byrow=TRUE) else run.varcov
+ n, ncol(run.varcov), byrow = TRUE) else run.varcov
dtheta.detas = cbind(dmu.deta, drho.deta)
wz = wz * dtheta.detas[,index0$row] * dtheta.detas[,index0$col]
c(w) * wz
- }), list( .lmu=lmu, .lrho=lrho,
- .emu=emu, .erho=erho, .nsimEIM=nsimEIM ))))
+ }), list( .lmu = lmu, .lrho = lrho,
+ .emu = emu, .erho = erho, .nsimEIM = nsimEIM ))))
}
- vonmises = function(llocation="elogit",
- lscale="loge",
- elocation=if(llocation=="elogit") list(min=0, max=2*pi)
- else list(),
- escale=list(),
- ilocation=NULL, iscale=NULL,
- imethod=1, zero=NULL) {
+ vonmises = function(llocation = "elogit",
+ lscale = "loge",
+ elocation = if (llocation == "elogit") list(min = 0, max = 2*pi)
+ else list(),
+ escale = list(),
+ ilocation = NULL, iscale = NULL,
+ imethod=1, zero = NULL) {
if (mode(llocation) != "character" && mode(llocation) != "name")
llocation = as.character(substitute(llocation))
if (mode(lscale) != "character" && mode(lscale) != "name")
lscale = as.character(substitute(lscale))
- if (!is.Numeric(imethod, allow=1, integ=TRUE, posit=TRUE) ||
+ if (!is.Numeric(imethod, allow=1, integ = TRUE, posit = TRUE) ||
imethod > 2) stop("argument 'imethod' must be 1 or 2")
- if (length(zero) && !is.Numeric(zero, integer=TRUE, posit=TRUE))
+ if (length(zero) && !is.Numeric(zero, integer = TRUE, posit = TRUE))
stop("bad input for argument 'zero'")
if (!is.list(escale)) escale = list()
new("vglmff",
- blurb=c("Von Mises distribution\n\n",
+ blurb = c("Von Mises distribution\n\n",
"Links: ",
- namesof("location", llocation, earg= elocation), ", ",
- namesof("scale", lscale, earg=escale),
+ namesof("location", llocation, earg = elocation), ", ",
+ namesof("scale", lscale, earg =escale),
"\n", "\n",
"Mean: location"),
- constraints=eval(substitute(expression({
+ constraints = eval(substitute(expression({
constraints = cm.zero.vgam(constraints, x, .zero, M)
- }), list( .zero=zero ))),
- initialize=eval(substitute(expression({
+ }), list( .zero = zero ))),
+ initialize = eval(substitute(expression({
if (ncol(cbind(y)) != 1)
stop("response must be a vector or a one-column matrix")
predictors.names =
- c(namesof("location", .llocation, earg= .elocation, tag=FALSE),
- namesof("scale", .lscale, earg=.escale, tag=FALSE))
+ c(namesof("location", .llocation, earg = .elocation, tag = FALSE),
+ namesof("scale", .lscale, earg =.escale, tag = FALSE))
if (!length(etastart)) {
if ( .imethod == 1) {
location.init = mean(y)
@@ -251,54 +256,54 @@ cardioid.control <- function(save.weight=TRUE, ...)
rep(location.init, len=n)
scale.init= if (length(.iscale)) rep(.iscale,len=n) else rep(1,len=n)
etastart = cbind(
- theta2eta(location.init, .llocation, earg= .elocation),
- theta2eta(scale.init, .lscale, earg= .escale))
+ theta2eta(location.init, .llocation, earg = .elocation),
+ theta2eta(scale.init, .lscale, earg = .escale))
}
y = y %% (2*pi) # Coerce after initial values have been computed
- }), list( .imethod=imethod, .ilocation=ilocation,
- .escale=escale, .iscale=iscale,
- .lscale=lscale, .llocation=llocation, .elocation=elocation ))),
- inverse=eval(substitute(function(eta, extra=NULL) {
- eta2theta(eta[,1], .llocation, earg= .elocation) %% (2*pi)
- }, list( .escale=escale, .lscale=lscale,
- .llocation=llocation, .elocation=elocation ))),
- last=eval(substitute(expression({
- misc$link = c(location= .llocation, scale= .lscale)
- misc$earg = list(location= .elocation, scale= .escale )
- }), list( .escale=escale, .lscale=lscale,
- .llocation=llocation, .elocation=elocation ))),
- loglikelihood=eval(substitute(
- function(mu,y,w,residuals= FALSE,eta, extra=NULL) {
- location = eta2theta(eta[,1], .llocation, earg= .elocation)
- Scale = eta2theta(eta[,2], .lscale, earg= .escale)
+ }), list( .imethod = imethod, .ilocation = ilocation,
+ .escale = escale, .iscale = iscale,
+ .lscale = lscale, .llocation = llocation, .elocation = elocation ))),
+ linkinv = eval(substitute(function(eta, extra = NULL) {
+ eta2theta(eta[,1], .llocation, earg = .elocation) %% (2*pi)
+ }, list( .escale = escale, .lscale = lscale,
+ .llocation = llocation, .elocation = elocation ))),
+ last = eval(substitute(expression({
+ misc$link = c(location = .llocation, scale = .lscale)
+ misc$earg = list(location = .elocation, scale = .escale )
+ }), list( .llocation = llocation, .lscale = lscale,
+ .elocation = elocation, .escale = escale ))),
+ loglikelihood = eval(substitute(
+ function(mu,y,w,residuals= FALSE,eta, extra = NULL) {
+ location = eta2theta(eta[,1], .llocation, earg = .elocation)
+ Scale = eta2theta(eta[,2], .lscale, earg = .escale)
if (residuals) stop("loglikelihood residuals not ",
"implemented yet") else
sum(w * (Scale * cos(y - location) -
- log(mbesselI0(x=Scale ))))
- }, list( .escale=escale, .lscale=lscale,
- .llocation=llocation, .elocation=elocation ))),
- vfamily=c("vonmises"),
- deriv=eval(substitute(expression({
- location = eta2theta(eta[,1], .llocation, earg= .elocation)
- Scale = eta2theta(eta[,2], .lscale, earg= .escale)
+ log(mbesselI0(x = Scale ))))
+ }, list( .escale = escale, .lscale = lscale,
+ .llocation = llocation, .elocation = elocation ))),
+ vfamily = c("vonmises"),
+ deriv = eval(substitute(expression({
+ location = eta2theta(eta[,1], .llocation, earg = .elocation)
+ Scale = eta2theta(eta[,2], .lscale, earg = .escale)
tmp6 = mbesselI0(x=Scale, deriv=2)
dl.dlocation = Scale * sin(y - location)
- dlocation.deta = dtheta.deta(location, .llocation, earg= .elocation)
+ dlocation.deta = dtheta.deta(location, .llocation, earg = .elocation)
dl.dscale = cos(y - location) - tmp6[,2] / tmp6[,1]
- dscale.deta = dtheta.deta(Scale, .lscale, earg= .escale)
+ dscale.deta = dtheta.deta(Scale, .lscale, earg = .escale)
c(w) * cbind(dl.dlocation * dlocation.deta,
dl.dscale * dscale.deta)
- }), list( .escale=escale, .lscale=lscale,
- .llocation=llocation, .elocation=elocation ))),
- weight=eval(substitute(expression({
+ }), list( .escale = escale, .lscale = lscale,
+ .llocation = llocation, .elocation = elocation ))),
+ weight = eval(substitute(expression({
d2l.location2 = Scale * tmp6[,2] / tmp6[,1]
d2l.dscale2 = tmp6[,3] / tmp6[,1] - (tmp6[,2] / tmp6[,1])^2
wz = matrix(as.numeric(NA), nrow=n, ncol=2) # diagonal
wz[,iam(1,1,M)] = d2l.location2 * dlocation.deta^2
wz[,iam(2,2,M)] = d2l.dscale2 * dscale.deta^2
c(w) * wz
- }), list( .escale=escale, .lscale=lscale,
- .llocation=llocation, .elocation=elocation ))))
+ }), list( .escale = escale, .lscale = lscale,
+ .llocation = llocation, .elocation = elocation ))))
}
diff --git a/R/family.exp.R b/R/family.exp.R
index 94ae44f..6f00bdd 100644
--- a/R/family.exp.R
+++ b/R/family.exp.R
@@ -404,7 +404,7 @@ rkoenker <- function(n, location = 0, scale = 1) {
.ilocat = ilocat, .iscale = iscale,
.elocat = elocat, .escale = escale,
.imethod = imethod ))),
- inverse = eval(substitute(function(eta, extra = NULL){
+ linkinv = eval(substitute(function(eta, extra = NULL){
Perce <- .percentile
locat <- eta2theta(eta[, 1], link = .llocat, earg = .elocat)
Scale <- eta2theta(eta[, 2], link = .lscale, earg = .escale)
diff --git a/R/family.extremes.R b/R/family.extremes.R
index fc0c620..bbc4d2d 100644
--- a/R/family.extremes.R
+++ b/R/family.extremes.R
@@ -273,7 +273,7 @@ qgev <- function(p, location = 0, scale = 1, shape = 0) {
.percentiles = percentiles,
.tolshape0 = tolshape0,
.imethod = imethod, .giveWarning= giveWarning ))),
- inverse = eval(substitute(function(eta, extra = NULL) {
+ linkinv = eval(substitute(function(eta, extra = NULL) {
loc = eta2theta(eta[, 1], .llocation, earg = .elocation)
sigma = eta2theta(eta[, 2], .lscale, earg = .escale)
xi = eta2theta(eta[,3], .lshape, earg = .eshape)
@@ -609,7 +609,7 @@ dgammadx <- function(x, deriv.arg=1) {
.imethod = imethod,
.giveWarning= giveWarning,
.iscale = iscale, .ishape = ishape, .gshape = gshape ))),
- inverse = eval(substitute(function(eta, extra = NULL) {
+ linkinv = eval(substitute(function(eta, extra = NULL) {
loc <- eta2theta(eta[, 1], .llocation, earg = .elocation)
sigma <- eta2theta(eta[, 2], .lscale, earg = .escale)
xi <- eta2theta(eta[,3], .lshape, earg = .eshape)
@@ -848,7 +848,7 @@ pgumbel <- function(q, location = 0, scale = 1) {
}), list( .llocation = llocation, .lscale = lscale, .iscale = iscale,
.elocation = elocation, .escale = escale,
.R=R, .mpv=mpv, .percentiles = percentiles ))),
- inverse = eval(substitute(function(eta, extra = NULL) {
+ linkinv = eval(substitute(function(eta, extra = NULL) {
loc = eta2theta(eta[, 1], .llocation, earg = .elocation)
sigma = eta2theta(eta[, 2], .lscale, earg = .escale ) # sigma
Percentiles = extra$percentiles
@@ -1167,7 +1167,7 @@ qgpd <- function(p, location = 0, scale = 1, shape = 0) {
.iscale = iscale, .ishape = ishape,
.escale = escale, .eshape = eshape,
.imethod = imethod ))),
- inverse = eval(substitute(function(eta, extra = NULL) {
+ linkinv = eval(substitute(function(eta, extra = NULL) {
sigma = eta2theta(eta[, 1], .lscale, earg = .escale )
Shape = eta2theta(eta[, 2], .lshape, earg = .eshape )
cent = .percentiles
@@ -1435,7 +1435,7 @@ setMethod("guplot", "vlm",
}), list( .llocation = llocation, .lscale = lscale, .iscale = iscale,
.elocation=elocation, .escale = escale,
.R=R, .mpv=mpv, .percentiles = percentiles ))),
- inverse = eval(substitute( function(eta, extra = NULL) {
+ linkinv = eval(substitute( function(eta, extra = NULL) {
loc = eta2theta(eta[, 1], .llocation, earg = .elocation)
sigma = eta2theta(eta[, 2], .lscale, earg = .escale )
EulerM = -digamma(1)
@@ -1570,7 +1570,7 @@ setMethod("guplot", "vlm",
}), list( .lscale = lscale, .iscale = iscale,
.llocation = llocation,
.elocation = elocation, .escale = escale ))),
- inverse = eval(substitute( function(eta, extra = NULL) {
+ linkinv = eval(substitute( function(eta, extra = NULL) {
loc = eta2theta(eta[, 1], .llocation)
sc = eta2theta(eta[, 2], .lscale)
EulerM = -digamma(1)
@@ -1838,7 +1838,7 @@ frechet2.control <- function(save.weight = TRUE, ...)
.escale = escale, .eshape = eshape,
.iscale = iscale, .ishape = ishape,
.location = location ))),
- inverse = eval(substitute(function(eta, extra = NULL) {
+ linkinv = eval(substitute(function(eta, extra = NULL) {
loc = extra$location
Scale = eta2theta(eta[, 1], .lscale, earg = .escale )
shape = eta2theta(eta[, 2], .lshape, earg = .eshape )
@@ -2067,7 +2067,7 @@ if (FALSE)
.ediffr = ediffr, .escale = escale, .eshape = eshape,
.iscale = iscale, .ishape = ishape,
.ilocation = ilocation, .anchor = anchor ))),
- inverse = eval(substitute(function(eta, extra = NULL) {
+ linkinv = eval(substitute(function(eta, extra = NULL) {
loctn = extra$LHSanchor -
eta2theta(eta[, 1], .ldiffr, earg = .ediffr)
Scale = eta2theta(eta[, 2], .lscale, earg = .escale )
@@ -2194,7 +2194,7 @@ recnormal1.control <- function(save.weight = TRUE, ...)
}
recnormal1 <- function(lmean = "identity", lsd = "loge",
- imean = NULL, isd = NULL, imethod = 1, zero = NULL)
+ imean = NULL, isd = NULL, imethod = 1, zero = NULL)
{
if (mode(lmean) != "character" && mode(lmean) != "name")
@@ -2217,9 +2217,11 @@ recnormal1.control <- function(save.weight = TRUE, ...)
}), list( .zero = zero ))),
initialize = eval(substitute(expression({
predictors.names = c(namesof("mean", .lmean, tag = FALSE),
- namesof("sd", .lsd, tag = FALSE))
+ namesof("sd", .lsd, tag = FALSE))
+
if (ncol(y <- cbind(y)) != 1)
stop("response must be a vector or a one-column matrix")
+
if (any(diff(y) <= 0))
stop("response must have increasingly larger and larger values")
if (any(w != 1))
@@ -2228,16 +2230,16 @@ recnormal1.control <- function(save.weight = TRUE, ...)
mean.init = if (length( .imean)) rep( .imean, len = n) else {
if (.lmean == "loge") pmax(1/1024, min(y)) else min(y)}
sd.init = if (length( .isd)) rep( .isd, len = n) else {
- if (.imethod == 1) 1*(sd(y)) else
- if (.imethod == 2) 5*(sd(y)) else
- .5*(sd(y))
+ if (.imethod == 1) 1*(sd(c(y))) else
+ if (.imethod == 2) 5*(sd(c(y))) else
+ .5*(sd(c(y)))
}
etastart = cbind(theta2eta(rep(mean.init, len = n), .lmean),
theta2eta(rep(sd.init, len = n), .lsd))
}
}), list( .lmean = lmean, .lsd = lsd, .imean = imean, .isd = isd,
.imethod = imethod ))),
- inverse = eval(substitute(function(eta, extra = NULL) {
+ linkinv = eval(substitute(function(eta, extra = NULL) {
eta2theta(eta[, 1], .lmean)
}, list( .lmean = lmean ))),
last = eval(substitute(expression({
@@ -2332,7 +2334,7 @@ recexp1.control <- function(save.weight = TRUE, ...)
etastart = cbind(theta2eta(rep(rate.init, len = n), .lrate))
}
}), list( .lrate = lrate, .irate = irate, .imethod = imethod ))),
- inverse = eval(substitute(function(eta, extra = NULL) {
+ linkinv = eval(substitute(function(eta, extra = NULL) {
eta2theta(eta, .lrate)
}, list( .lrate = lrate ))),
last = eval(substitute(expression({
@@ -2425,7 +2427,7 @@ recexp1.control <- function(save.weight = TRUE, ...)
}), list( .link = link, .earg = earg, .ostatistic = ostatistic,
.dimension = dimension, .imethod = imethod,
.idensity = idensity ))),
- inverse = eval(substitute(function(eta, extra = NULL) {
+ linkinv = eval(substitute(function(eta, extra = NULL) {
density = eta2theta(eta, .link, earg = .earg)
if ( .dimension == 2) {
myratio = exp(lgamma( .ostatistic +0.5) - lgamma( .ostatistic ))
diff --git a/R/family.genetic.R b/R/family.genetic.R
index 8fcd87b..c590f8f 100644
--- a/R/family.genetic.R
+++ b/R/family.genetic.R
@@ -64,7 +64,7 @@
}
}), list( .link = link, .ip1 = ip1, .ip2 = ip2, .iF = iF,
.earg = earg ))),
- inverse = eval(substitute(function(eta, extra = NULL) {
+ linkinv = eval(substitute(function(eta, extra = NULL) {
p1 = eta2theta(eta[,1], link = .link, earg = .earg)
p2 = eta2theta(eta[,2], link = .link, earg = .earg)
f = eta2theta(eta[,3], link = .link, earg = .earg)
@@ -162,7 +162,7 @@
mustart <- NULL # Since etastart has been computed.
}
}), list( .link = link, .ipA=ipA, .iF = iF, .earg = earg ))),
- inverse = eval(substitute(function(eta, extra = NULL) {
+ linkinv = eval(substitute(function(eta, extra = NULL) {
pA = eta2theta(eta[,1], link = .link, earg = .earg)
f = eta2theta(eta[,2], link = "identity", earg = list())
cbind(AA = pA^2+pA*(1-pA)*f,
@@ -173,7 +173,7 @@
misc$link = c(pA = .link, f = "identity")
misc$earg = list(pA = .earg, f = list() )
}), list( .link = link, .earg = earg ))),
- link = eval(substitute(function(mu, extra = NULL) {
+ linkfun = eval(substitute(function(mu, extra = NULL) {
pA = sqrt(mu[,1] - mu[,2]/2)
f = 1 - mu[,2] / (2*pA*(1-pA))
cbind(theta2eta(pA, .link, earg = .earg),
@@ -249,7 +249,7 @@
etastart = theta2eta(p.init, .link, earg = .earg)
}
}), list( .link = link, .init.p=init.p, .earg = earg ))),
- inverse = eval(substitute(function(eta,extra = NULL) {
+ linkinv = eval(substitute(function(eta,extra = NULL) {
p = eta2theta(eta, link = .link, earg = .earg)
cbind("AB" = (2+(1-p)^2),
"Ab" = (1-(1-p)^2),
@@ -260,7 +260,7 @@
misc$link = c(p = .link)
misc$earg = list(p= .earg )
}), list( .link = link, .earg = earg ) )),
- link = eval(substitute(function(mu, extra = NULL) {
+ linkfun = eval(substitute(function(mu, extra = NULL) {
p = 1 - 2 * sqrt(mu[,4])
theta2eta(p, .link, earg = .earg)
}, list( .link = link, .earg = earg ) )),
@@ -327,7 +327,7 @@
theta2eta(p2, .link, earg = .earg))
}
}), list( .link = link, .ip1 = ip1, .ip2 = ip2, .earg = earg ))),
- inverse = eval(substitute(function(eta, extra = NULL) {
+ linkinv = eval(substitute(function(eta, extra = NULL) {
p1 = eta2theta(eta[,1], link = .link, earg = .earg)
p2 = eta2theta(eta[,2], link = .link, earg = .earg)
qq = 1-p1-p2
@@ -342,7 +342,7 @@
misc$link = c(p1= .link, p2= .link)
misc$earg = list(p1= .earg, p2= .earg )
}), list( .link = link, .earg = earg ))),
- link = eval(substitute(function(mu, extra = NULL) {
+ linkfun = eval(substitute(function(mu, extra = NULL) {
p1 = sqrt(mu[,1])
p2 = sqrt(mu[,3])
qq = 1 - p1 - p2
@@ -426,7 +426,7 @@
theta2eta(nS, .link, earg = .earg))
}
}), list( .link = link, .imS = imS, .ims = ims, .inS = inS, .earg = earg ))),
- inverse = eval(substitute(function(eta, extra = NULL) {
+ linkinv = eval(substitute(function(eta, extra = NULL) {
mS = eta2theta(eta[,1], link = .link, earg = .earg)
ms = eta2theta(eta[,2], link = .link, earg = .earg)
nS = eta2theta(eta[,3], link = .link, earg = .earg)
@@ -442,7 +442,7 @@
misc$link = c(mS = .link, ms = .link, nS = .link)
misc$earg = list(mS = .earg, ms = .earg, nS = .earg )
}), list( .link = link, .earg = earg ))),
- link = eval(substitute(function(mu, extra = NULL) {
+ linkfun = eval(substitute(function(mu, extra = NULL) {
ms = sqrt(mu[,2])
ns = sqrt(mu[,6])
nS = c(-ns + sqrt(ns^2 + mu[,5]))
@@ -528,7 +528,7 @@
theta2eta(pB, .link, earg = .earg))
}
}), list( .link = link, .ipO = ipO, .ipA = ipA, .earg = earg ))),
- inverse = eval(substitute(function(eta, extra = NULL) {
+ linkinv = eval(substitute(function(eta, extra = NULL) {
pA = eta2theta(eta[,1], link = .link, earg = .earg)
pB = eta2theta(eta[,2], link = .link, earg = .earg)
pO = abs(1 - pA - pB)
@@ -541,7 +541,7 @@
misc$link = c(pA = .link, pB = .link)
misc$earg = list(pA = .earg, pB = .earg )
}), list( .link = link, .earg = earg ))),
- link = eval(substitute(function(mu, extra = NULL) {
+ linkfun = eval(substitute(function(mu, extra = NULL) {
pO = sqrt(mu[,4])
p1 = ( (1-pO)+sqrt((1-pO)^2 + 2*mu[,3]) )/2
p2 = ( (1-pO)-sqrt((1-pO)^2 + 2*mu[,3]) )/2
@@ -624,7 +624,7 @@
etastart = cbind(theta2eta(p, .link, earg = .earg))
}
}), list( .link = link, .init.p=init.p, .earg = earg ))),
- inverse = eval(substitute(function(eta,extra = NULL) {
+ linkinv = eval(substitute(function(eta,extra = NULL) {
p = eta2theta(eta, link = .link, earg = .earg)
pp4 = p * p / 4
cbind(AB = 0.5 + pp4,
@@ -636,7 +636,7 @@
misc$link = c(p = .link)
misc$earg = list(p= .earg )
}), list( .link = link, .earg = earg ))),
- link = eval(substitute(function(mu, extra = NULL) {
+ linkfun = eval(substitute(function(mu, extra = NULL) {
p = sqrt(4* mu[,4])
theta2eta(p, .link, earg = .earg)
}, list( .link = link, .earg = earg ))),
@@ -695,7 +695,7 @@
etastart = cbind(theta2eta(pA, .link, earg = .earg))
}
}), list( .link = link, .init.pA=init.pA, .earg = earg ))),
- inverse = eval(substitute(function(eta,extra = NULL) {
+ linkinv = eval(substitute(function(eta,extra = NULL) {
pA = eta2theta(eta, link = .link, earg = .earg)
pp = pA*pA
cbind(AA = pp,
@@ -706,7 +706,7 @@
misc$link = c("pA" = .link)
misc$earg = list("pA" = .earg )
}), list( .link = link, .earg = earg ))),
- link = eval(substitute(function(mu, extra = NULL) {
+ linkfun = eval(substitute(function(mu, extra = NULL) {
pA = sqrt(mu[,1])
theta2eta(pA, .link, earg = .earg)
}, list( .link = link, .earg = earg ))),
diff --git a/R/family.glmgam.R b/R/family.glmgam.R
index a0fb87c..5de8a0a 100644
--- a/R/family.glmgam.R
+++ b/R/family.glmgam.R
@@ -20,195 +20,229 @@
{
- estimated.dispersion <- dispersion == 0
- if (mode(link )!= "character" && mode(link )!= "name")
- link <- as.character(substitute(link))
- if (!is.list(earg)) earg = list()
-
- new("vglmff",
- blurb = if (mv) c("Multivariate binomial model\n\n",
- "Link: ", namesof("mu[,j]", link, earg = earg), "\n",
- "Variance: mu[,j]*(1-mu[,j])") else
- c("Binomial model\n\n",
- "Link: ", namesof("mu", link, earg = earg), "\n",
- "Variance: mu*(1-mu)"),
- constraints = eval(substitute(expression({
- constraints <- cm.vgam(matrix(1, M, 1), x, .parallel, constraints)
- constraints <- cm.zero.vgam(constraints, x, .zero, M)
- }), list( .parallel = parallel, .zero = zero ))),
- deviance = function(mu, y, w, residuals = FALSE, eta, extra = NULL) {
- Deviance.categorical.data.vgam(mu=cbind(mu,1-mu), y=cbind(y,1-y),
- w=w, residuals = residuals,
- eta=eta, extra=extra)
- },
- infos = eval(substitute(function(...) {
- list(Musual = 1,
- zero = .zero)
- }, list( .zero = zero ))),
- initialize = eval(substitute(expression({
- assign("CQO.FastAlgorithm",
- ( .link == "logit" || .link == "cloglog"),
- envir = VGAM:::VGAMenv)
- assign("modelno", if ( .link == "logit") 1 else
- if ( .link == "cloglog") 4 else NULL,
- envir = VGAM:::VGAMenv)
- if ( .mv ) {
- y = as.matrix(y)
- M = ncol(y)
- if (!all(y == 0 | y == 1))
- stop("response must contain 0's and 1's only")
- dn2 = if (is.matrix(y)) dimnames(y)[[2]] else NULL
- dn2 = if (length(dn2)) {
- paste("E[", dn2, "]", sep = "")
- } else {
- paste("mu", 1:M, sep = "")
- }
- predictors.names = namesof(if (M > 1) dn2 else
- "mu", .link, earg = .earg, short = TRUE)
- if (!length(mustart) && !length(etastart))
- mustart = (0.5 + w * y) / (1 + w)
+ estimated.dispersion <- dispersion == 0
+ if (mode(link )!= "character" && mode(link )!= "name")
+ link <- as.character(substitute(link))
+ if (!is.list(earg)) earg = list()
+
+ ans =
+ new("vglmff",
+ blurb = if (mv) c("Multivariate binomial model\n\n",
+ "Link: ", namesof("mu[,j]", link, earg = earg), "\n",
+ "Variance: mu[,j]*(1-mu[,j])") else
+ c("Binomial model\n\n",
+ "Link: ", namesof("mu", link, earg = earg), "\n",
+ "Variance: mu*(1-mu)"),
+ constraints = eval(substitute(expression({
+ constraints <- cm.vgam(matrix(1, M, 1), x, .parallel, constraints)
+ constraints <- cm.zero.vgam(constraints, x, .zero, M)
+ }), list( .parallel = parallel, .zero = zero ))),
+ infos = eval(substitute(function(...) {
+ list(Musual = 1,
+ zero = .zero)
+ }, list( .zero = zero ))),
+ initialize = eval(substitute(expression({
+ assign("CQO.FastAlgorithm",
+ ( .link == "logit" || .link == "cloglog"),
+ envir = VGAM:::VGAMenv)
+ assign("modelno", if ( .link == "logit") 1 else
+ if ( .link == "cloglog") 4 else NULL,
+ envir = VGAM:::VGAMenv)
+
+
+
+
+ if ( .mv ) {
+ y = as.matrix(y)
+ M = ncol(y)
+ if (!all(y == 0 | y == 1))
+ stop("response must contain 0's and 1's only")
+ dn2 = if (is.matrix(y)) dimnames(y)[[2]] else NULL
+ dn2 = if (length(dn2)) {
+ paste("E[", dn2, "]", sep = "")
} else {
+ paste("mu", 1:M, sep = "")
+ }
+ predictors.names = namesof(if (M > 1) dn2 else
+ "mu", .link, earg = .earg, short = TRUE)
- if (!all(w == 1))
- extra$orig.w = w
+ if (!length(mustart) && !length(etastart))
+ mustart = matrix(colMeans(y), nrow = nrow(y), ncol = ncol(y),
+ byrow = TRUE)
+ if (!all(w == 1))
+ extra$orig.w = w
- NCOL = function (x) if (is.array(x) && length(dim(x)) > 1 ||
- is.data.frame(x)) ncol(x) else as.integer(1)
- if (NCOL(y) == 1) {
- if (is.factor(y)) y = (y != levels(y)[1])
- nvec = rep(1, n)
- y[w == 0] <- 0
- if (!all(y == 0 || y == 1))
- stop("response values 'y' must be 0 or 1")
- if (!length(mustart) && !length(etastart))
- mustart = (0.5 + w * y) / (1 + w)
+ extra$mv = TRUE
+ } else {
- no.successes = y
- if (min(y) < 0)
- stop("Negative data not allowed!")
- if (any(abs(no.successes - round(no.successes)) > 1.0e-8))
- stop("Number of successes must be integer-valued")
- } else if (NCOL(y) == 2) {
- if (min(y) < 0)
- stop("Negative data not allowed!")
- if (any(abs(y - round(y)) > 1.0e-8))
- stop("Count data must be integer-valued")
- y = round(y)
- nvec = y[,1] + y[,2]
- y = ifelse(nvec > 0, y[,1] / nvec, 0)
- w = w * nvec
- if (!length(mustart) && !length(etastart))
- mustart = (0.5 + nvec * y) / (1 + nvec)
- } else {
- stop("for the binomialff family, response 'y' must be a ",
- "vector of 0 and 1's\n",
- "or a factor (first level = fail, other levels = success),\n",
- "or a 2-column matrix where col 1 is the no. of ",
- "successes and col 2 is the no. of failures")
- }
- predictors.names = namesof("mu", .link, earg = .earg, short = TRUE)
- }
- }), list( .link = link, .mv = mv, .earg = earg ))),
- inverse = eval(substitute(function(eta, extra = NULL) {
- mu = eta2theta(eta, link = .link, earg = .earg)
- mu
- }, list( .link = link, .earg = earg ))),
- last = eval(substitute(expression({
- if (exists("CQO.FastAlgorithm", envir = VGAM:::VGAMenv))
- rm("CQO.FastAlgorithm", envir = VGAM:::VGAMenv)
- if (exists("modelno", envir = VGAM:::VGAMenv))
- rm("modelno", envir = VGAM:::VGAMenv)
- dpar <- .dispersion
- if (!dpar) {
- temp87 = (y-mu)^2 * wz / (dtheta.deta(mu, link = .link,
- earg = .earg )^2) # w cancel
- if (.mv && ! .onedpar) {
- dpar = rep(as.numeric(NA), len = M)
- temp87 = cbind(temp87)
- nrow.mu = if (is.matrix(mu)) nrow(mu) else length(mu)
- for(ii in 1:M)
- dpar[ii] = sum(temp87[,ii]) / (nrow.mu - ncol(x))
- if (is.matrix(y) && length(dimnames(y)[[2]]) == length(dpar))
- names(dpar) = dimnames(y)[[2]]
- } else
- dpar = sum(temp87) / (length(mu) - ncol(x))
- }
- misc$mv = .mv
- misc$dispersion <- dpar
- misc$default.dispersion <- 1
- misc$estimated.dispersion <- .estimated.dispersion
- misc$link = rep( .link, length = M)
- names(misc$link) = if (M > 1) dn2 else "mu"
+ if (!all(w == 1))
+ extra$orig.w = w
- misc$earg = vector("list", M)
- names(misc$earg) = names(misc$link)
- for(ii in 1:M) misc$earg[[ii]] = .earg
- misc$expected = TRUE
- }), list( .dispersion = dispersion,
- .estimated.dispersion = estimated.dispersion,
- .onedpar = onedpar, .mv = mv,
- .link = link, .earg = earg ))),
- link = eval(substitute(function(mu, extra = NULL)
- theta2eta(mu, .link, earg = .earg )
- , list( .link = link, .earg = earg ))),
- loglikelihood =
- function(mu, y, w, residuals = FALSE, eta, extra = NULL) {
- if (residuals) w * (y / mu - (1-y) / (1-mu)) else {
+ NCOL = function (x) if (is.array(x) && length(dim(x)) > 1 ||
+ is.data.frame(x)) ncol(x) else as.integer(1)
+ if (NCOL(y) == 1) {
+ if (is.factor(y)) y = (y != levels(y)[1])
+ nvec = rep(1, n)
+ y[w == 0] <- 0
+ if (!all(y == 0 || y == 1))
+ stop("response values 'y' must be 0 or 1")
+ if (!length(mustart) && !length(etastart))
+ mustart = (0.5 + w * y) / (1 + w)
- ycounts = if (is.numeric(extra$orig.w)) y * w / extra$orig.w else
+
+ no.successes = y
+ if (min(y) < 0)
+ stop("Negative data not allowed!")
+ if (any(abs(no.successes - round(no.successes)) > 1.0e-8))
+ stop("Number of successes must be integer-valued")
+ } else if (NCOL(y) == 2) {
+ if (min(y) < 0)
+ stop("Negative data not allowed!")
+ if (any(abs(y - round(y)) > 1.0e-8))
+ stop("Count data must be integer-valued")
+ y = round(y)
+ nvec = y[,1] + y[,2]
+ y = ifelse(nvec > 0, y[,1] / nvec, 0)
+ w = w * nvec
+ if (!length(mustart) && !length(etastart))
+ mustart = (0.5 + nvec * y) / (1 + nvec)
+ } else {
+ stop("for the binomialff family, response 'y' must be a ",
+ "vector of 0 and 1's\n",
+ "or a factor (first level = fail, other levels = success),\n",
+ "or a 2-column matrix where col 1 is the no. of ",
+ "successes and col 2 is the no. of failures")
+ }
+ predictors.names = namesof("mu", .link, earg = .earg, short = TRUE)
+ }
+ }), list( .link = link, .mv = mv, .earg = earg ))),
+
+ linkinv = eval(substitute(function(eta, extra = NULL) {
+ mu = eta2theta(eta, link = .link, earg = .earg)
+ mu
+ }, list( .link = link, .earg = earg ))),
+
+ last = eval(substitute(expression({
+ if (exists("CQO.FastAlgorithm", envir = VGAM:::VGAMenv))
+ rm("CQO.FastAlgorithm", envir = VGAM:::VGAMenv)
+ if (exists("modelno", envir = VGAM:::VGAMenv))
+ rm("modelno", envir = VGAM:::VGAMenv)
+
+ dpar <- .dispersion
+ if (!dpar) {
+ temp87 = (y-mu)^2 * wz / (dtheta.deta(mu, link = .link,
+ earg = .earg )^2) # w cancel
+ if (.mv && ! .onedpar) {
+ dpar = rep(as.numeric(NA), len = M)
+ temp87 = cbind(temp87)
+ nrow.mu = if (is.matrix(mu)) nrow(mu) else length(mu)
+ for(ii in 1:M)
+ dpar[ii] = sum(temp87[,ii]) / (nrow.mu - ncol(x))
+ if (is.matrix(y) && length(dimnames(y)[[2]]) == length(dpar))
+ names(dpar) = dimnames(y)[[2]]
+ } else
+ dpar = sum(temp87) / (length(mu) - ncol(x))
+ }
+ misc$mv = .mv
+ misc$dispersion <- dpar
+ misc$default.dispersion <- 1
+ misc$estimated.dispersion <- .estimated.dispersion
+ misc$link = rep( .link, length = M)
+ names(misc$link) = if (M > 1) dn2 else "mu"
+
+ misc$earg = vector("list", M)
+ names(misc$earg) = names(misc$link)
+ for(ii in 1:M) misc$earg[[ii]] = .earg
+
+ misc$expected = TRUE
+ }), list( .dispersion = dispersion,
+ .estimated.dispersion = estimated.dispersion,
+ .onedpar = onedpar, .mv = mv,
+ .link = link, .earg = earg ))),
+
+ linkfun = eval(substitute(function(mu, extra = NULL)
+ theta2eta(mu, .link, earg = .earg )
+ , list( .link = link, .earg = earg ))),
+
+ loglikelihood = eval(substitute(
+ function(mu, y, w, residuals = FALSE, eta, extra = NULL) {
+ if (residuals) {
+ w * (y / mu - (1-y) / (1-mu))
+ } else {
+
+ ycounts = if (is.numeric(extra$orig.w)) y * w / extra$orig.w else
y * w # Convert proportions to counts
- nvec = if (is.numeric(extra$orig.w)) round(w / extra$orig.w) else
+ nvec = if (is.numeric(extra$orig.w)) round(w / extra$orig.w) else
round(w)
- smallno = 1.0e6 * .Machine$double.eps
- smallno = sqrt(.Machine$double.eps)
- if (max(abs(ycounts - round(ycounts))) > smallno)
- warning("converting 'ycounts' to integer in @loglikelihood")
- ycounts = round(ycounts)
+ smallno = 1.0e6 * .Machine$double.eps
+ smallno = sqrt(.Machine$double.eps)
+ if (max(abs(ycounts - round(ycounts))) > smallno)
+ warning("converting 'ycounts' to integer in @loglikelihood")
+ ycounts = round(ycounts)
+ if ( .mv ) {
+ sum((ycounts * log(mu) +
+ (1 - ycounts) * log1p(-mu)) * w)
+ } else {
sum((if (is.numeric(extra$orig.w)) extra$orig.w else 1) *
- dbinom(x = ycounts, size = nvec, prob = mu,
- log = TRUE))
+ dbinom(x = ycounts, size = nvec, prob = mu, log = TRUE))
}
- },
- vfamily = c("binomialff", "vcategorical"),
- deriv = eval(substitute(expression({
- if ( .link == "logit") {
- w * (y - mu)
- } else if ( .link == "cloglog") {
- mu.use = mu
- smallno = 100 * .Machine$double.eps
- mu.use[mu.use < smallno] = smallno
- mu.use[mu.use > 1.0 - smallno] = 1.0 - smallno
- -w * (y - mu) * log1p(-mu.use) / mu.use
- } else
- w * dtheta.deta(mu, link = .link, earg = .earg ) *
- (y / mu - 1.0) / (1.0 - mu)
- }), list( .link = link, .earg = earg ))),
- weight = eval(substitute(expression({
- tmp100 = mu * (1.0 - mu)
+ }
+ }, list( .mv = mv ))),
+
+ vfamily = c("binomialff", "vcategorical"),
+
+ deriv = eval(substitute(expression({
+ if ( .link == "logit") {
+ w * (y - mu)
+ } else if ( .link == "cloglog") {
+ mu.use = mu
+ smallno = 100 * .Machine$double.eps
+ mu.use[mu.use < smallno] = smallno
+ mu.use[mu.use > 1.0 - smallno] = 1.0 - smallno
+ -w * (y - mu) * log1p(-mu.use) / mu.use
+ } else
+ w * dtheta.deta(mu, link = .link, earg = .earg ) *
+ (y / mu - 1.0) / (1.0 - mu)
+ }), list( .link = link, .earg = earg ))),
- tmp200 = if ( .link == "logit") {
- cbind(w * tmp100)
- } else if ( .link == "cloglog") {
- cbind(w * (1.0 - mu.use) * (log1p(-mu.use))^2 / mu.use)
- } else {
- cbind(w * dtheta.deta(mu, link = .link, earg = .earg)^2 / tmp100)
- }
- for(ii in 1:M) {
- index500 = !is.finite(tmp200[, ii]) |
- (abs(tmp200[, ii]) < .Machine$double.eps)
- if (any(index500)) { # Diagonal 0's are bad
- tmp200[index500, ii] = .Machine$double.eps
- }
+ weight = eval(substitute(expression({
+ tmp100 = mu * (1.0 - mu)
+
+ tmp200 = if ( .link == "logit") {
+ cbind(w * tmp100)
+ } else if ( .link == "cloglog") {
+ cbind(w * (1.0 - mu.use) * (log1p(-mu.use))^2 / mu.use)
+ } else {
+ cbind(w * dtheta.deta(mu, link = .link, earg = .earg)^2 / tmp100)
+ }
+ for(ii in 1:M) {
+ index500 = !is.finite(tmp200[, ii]) |
+ (abs(tmp200[, ii]) < .Machine$double.eps)
+ if (any(index500)) { # Diagonal 0's are bad
+ tmp200[index500, ii] = .Machine$double.eps
}
- tmp200
- }), list( .link = link, .earg = earg ))))
+ }
+ tmp200
+ }), list( .link = link, .earg = earg ))))
+
+
+
+ if (!mv)
+ ans at deviance =
+ function(mu, y, w, residuals = FALSE, eta, extra = NULL) {
+ Deviance.categorical.data.vgam(mu = cbind(mu, 1-mu), y = cbind(y, 1-y),
+ w = w, residuals = residuals,
+ eta = eta, extra = extra)
+ }
+
+ ans
}
@@ -244,7 +278,7 @@
if (!length(etastart))
etastart <- theta2eta(mustart, link = .link, earg=.earg)
}), list( .link = link, .earg = earg ))),
- inverse = eval(substitute(function(eta, extra = NULL) {
+ linkinv = eval(substitute(function(eta, extra = NULL) {
eta2theta(eta, link = .link, earg=.earg)
}, list( .link = link, .earg = earg ))),
last = eval(substitute(expression({
@@ -276,7 +310,7 @@
}), list( .dispersion = dispersion, .earg = earg,
.estimated.dispersion = estimated.dispersion,
.link = link ))),
- link = eval(substitute(function(mu, extra = NULL) {
+ linkfun = eval(substitute(function(mu, extra = NULL) {
theta2eta(mu, link = .link, earg=.earg)
}, list( .link = link, .earg = earg ))),
vfamily = "gammaff",
@@ -321,7 +355,7 @@
if (!length(etastart))
etastart <- theta2eta(mu, link = .link)
}), list( .link = link ))),
- inverse = eval(substitute(function(eta, extra = NULL) {
+ linkinv = eval(substitute(function(eta, extra = NULL) {
eta2theta(eta, link = .link)
}, list( .link = link ))),
last = eval(substitute(expression({
@@ -338,7 +372,7 @@
}), list( .dispersion = dispersion,
.estimated.dispersion = estimated.dispersion,
.link = link ))),
- link = eval(substitute(function(mu, extra = NULL) {
+ linkfun = eval(substitute(function(mu, extra = NULL) {
theta2eta(mu, link = .link)
}, list( .link = link ))),
vfamily = "inverse.gaussianff",
@@ -489,7 +523,7 @@ rinv.gaussian = function(n, mu, lambda) {
.emu = emu, .elambda = elambda,
.sinit = shrinkage.init,
.imethod = imethod, .ilambda = ilambda ))),
- inverse = eval(substitute(function(eta, extra = NULL) {
+ linkinv = eval(substitute(function(eta, extra = NULL) {
eta2theta(eta[,1], link = .lmu, earg = .emu)
}, list( .lmu = lmu, .emu = emu, .elambda = elambda ))),
last = eval(substitute(expression({
@@ -601,7 +635,7 @@ rinv.gaussian = function(n, mu, lambda) {
}
}), list( .link = link, .estimated.dispersion = estimated.dispersion,
.imethod = imethod, .imu = imu, .earg = earg ))),
- inverse = eval(substitute(function(eta, extra = NULL) {
+ linkinv = eval(substitute(function(eta, extra = NULL) {
mu = eta2theta(eta, link = .link, earg = .earg)
mu
}, list( .link = link, .earg = earg ))),
@@ -637,7 +671,7 @@ rinv.gaussian = function(n, mu, lambda) {
}), list( .dispersion = dispersion, .imethod=imethod,
.estimated.dispersion = estimated.dispersion,
.onedpar = onedpar, .link = link, .earg = earg ))),
- link = eval(substitute( function(mu, extra = NULL) {
+ linkfun = eval(substitute( function(mu, extra = NULL) {
theta2eta(mu, link = .link, earg = .earg)
}, list( .link = link, .earg = earg ))),
loglikelihood = function(mu, y, w, residuals = FALSE, eta, extra = NULL) {
@@ -742,7 +776,7 @@ poissonqn.control <- function(save.weight=TRUE, ...)
etastart <- theta2eta(mu, link = .link, earg = .earg)
}), list( .link = link, .estimated.dispersion = estimated.dispersion,
.earg = earg ))),
- inverse = eval(substitute(function(eta, extra = NULL) {
+ linkinv = eval(substitute(function(eta, extra = NULL) {
eta2theta(eta, link = .link, earg = .earg)
}, list( .link = link,
.earg = earg ))),
@@ -776,10 +810,10 @@ poissonqn.control <- function(save.weight=TRUE, ...)
.earg = earg,
.estimated.dispersion = estimated.dispersion,
.onedpar = onedpar, .link = link ))),
- link = eval(substitute(function(mu, extra = NULL) {
+ linkfun = eval(substitute(function(mu, extra = NULL) {
theta2eta(mu, link = .link, earg = .earg)
}, list( .link = link,
- .earg = earg ))),
+ .earg = earg ))),
loglikelihood = function(mu, y, w, residuals = FALSE, eta, extra = NULL) {
if (residuals) w*(y/mu - 1) else {
sum(w * dpois(x=y, lambda=mu, log = TRUE))
@@ -813,8 +847,8 @@ poissonqn.control <- function(save.weight=TRUE, ...)
wznew = cbind(matrix(w, n, M), matrix(0, n, dimm(M)-M))
} else {
wzold = wznew
- wznew = qnupdate(w=w, wzold=wzold, dderiv=(derivold-derivnew),
- deta=etanew-etaold, M=M,
+ wznew = qnupdate(w = w, wzold=wzold, dderiv=(derivold-derivnew),
+ deta = etanew-etaold, M=M,
trace=trace) # weights incorporated in args
}
} else if ( .wwts == "expected") {
@@ -889,7 +923,7 @@ poissonqn.control <- function(save.weight=TRUE, ...)
}), list( .lmean = lmean, .emean = emean,
.ldispersion = ldispersion, .edispersion = edispersion,
.idispersion = idispersion ))),
- inverse = eval(substitute(function(eta, extra = NULL) {
+ linkinv = eval(substitute(function(eta, extra = NULL) {
eta2theta(eta[,1], link = .lmean, earg = .emean)
}, list( .lmean = lmean, .emean = emean,
.ldispersion = ldispersion, .edispersion = edispersion ))),
@@ -1021,7 +1055,7 @@ poissonqn.control <- function(save.weight=TRUE, ...)
}), list( .lmean = lmean, .emean = emean,
.ldispersion = ldispersion, .edispersion = edispersion,
.idispersion = idispersion ))),
- inverse = eval(substitute(function(eta, extra = NULL) {
+ linkinv = eval(substitute(function(eta, extra = NULL) {
eta2theta(eta[,1], link = .lmean, earg = .emean)
}, list( .lmean = lmean, .emean = emean,
.ldispersion = ldispersion, .edispersion = edispersion ))),
@@ -1155,7 +1189,7 @@ poissonqn.control <- function(save.weight=TRUE, ...)
predictors.names = namesof("mu", .link, earg = .earg, short = TRUE)
predictors.names = rep(predictors.names, len = M)
}), list( .link = link, .earg = earg, .mvar = mvar ))),
- inverse = eval(substitute(function(eta, extra = NULL) {
+ linkinv = eval(substitute(function(eta, extra = NULL) {
mu = eta2theta(eta, link = .link, earg = .earg)
mu[cbind(1:extra$n, extra$index9)]
}, list( .link = link, .earg = earg ))),
@@ -1169,7 +1203,7 @@ poissonqn.control <- function(save.weight=TRUE, ...)
misc$expected = TRUE
}), list( .link = link, .earg = earg ))),
- link = eval(substitute(function(mu, extra = NULL) {
+ linkfun = eval(substitute(function(mu, extra = NULL) {
temp = theta2eta(mu, .link, earg = .earg )
matrix(temp, extra$n, extra$M)
}, list( .link = link, .earg = earg ))),
@@ -1307,7 +1341,7 @@ mypool = function(x, index) {
extra$index9 = temp9
predictors.names = namesof("mu", .link, earg = .earg, short = TRUE)
}), list( .link = link, .earg = earg, .mvar = mvar ))),
- inverse = eval(substitute(function(eta, extra = NULL) {
+ linkinv = eval(substitute(function(eta, extra = NULL) {
denominator = exp(eta)
numerator = mypool(denominator, extra$mvar)
numerator / denominator
@@ -1357,7 +1391,6 @@ mypool = function(x, index) {
parallel = TRUE)
{
- print("hi 20110222")
if (!is.logical(parallel) ||
length(parallel) != 1 ||
@@ -1382,9 +1415,9 @@ mypool = function(x, index) {
"\n",
"Variance: mu*(1-mu)"),
deviance = function(mu, y, w, residuals = FALSE, eta, extra = NULL) {
- Deviance.categorical.data.vgam(mu=cbind(mu, 1-mu), y=cbind(y, 1-y),
- w=w, residuals = residuals,
- eta=eta, extra=extra)
+ Deviance.categorical.data.vgam(mu = cbind(mu, 1-mu), y=cbind(y, 1-y),
+ w = w, residuals = residuals,
+ eta = eta, extra = extra)
},
infos = eval(substitute(function(...) {
list(Musual = 2,
@@ -1468,10 +1501,8 @@ mypool = function(x, index) {
c(namesof("mu.1", .link, earg = .earg, short = TRUE),
namesof("mu.2", .link, earg = .earg, short = TRUE))
}
- print("head(etastart) b 20110221")
- print( head(etastart) )
}), list( .link = link, .mv = mv, .earg = earg ))),
- inverse = eval(substitute(function(eta, extra = NULL) {
+ linkinv = eval(substitute(function(eta, extra = NULL) {
Mdiv2 = ncol(eta) / 2
index1 = 2*(1:Mdiv2) - 1
mu = eta2theta(eta[, index1],
@@ -1491,7 +1522,7 @@ mypool = function(x, index) {
misc$expected = TRUE
}), list( .link = link, .mv = mv, .earg = earg,
.parallel = parallel ))),
- link = eval(substitute(function(mu, extra = NULL) {
+ linkfun = eval(substitute(function(mu, extra = NULL) {
usualanswer = theta2eta(mu, .link, earg = .earg )
kronecker(usualanswer, matrix(1, 1, 2))
}, list( .link = link, .earg = earg ))),
diff --git a/R/family.loglin.R b/R/family.loglin.R
index 6f8ad2c..d1ed8dd 100644
--- a/R/family.loglin.R
+++ b/R/family.loglin.R
@@ -36,7 +36,7 @@ loglinb2 <- function(exchangeable = FALSE, zero = NULL)
stop("some combinations of the response not realized")
}
}),
- inverse = function(eta, extra = NULL) {
+ linkinv = function(eta, extra = NULL) {
u1 <- eta[,1]
u2 <- eta[,2]
u12 <- eta[,3]
@@ -48,9 +48,9 @@ loglinb2 <- function(exchangeable = FALSE, zero = NULL)
},
last = expression({
misc$link = c("u1" = "identity", "u2" = "identity", "u12" = "identity")
- misc$earg = list(u1=list(), u2=list(), u12=list())
+ misc$earg = list(u1 = list(), u2 = list(), u12 = list())
}),
- link = function(mu, extra = NULL) {
+ linkfun = function(mu, extra = NULL) {
u0 <- log(mu[,1])
u2 <- log(mu[,2]) - u0
u1 <- log(mu[,3]) - u0
@@ -67,7 +67,7 @@ loglinb2 <- function(exchangeable = FALSE, zero = NULL)
stop("loglikelihood residuals not implemented yet") else
sum(w*(u0 + u1*y[,1] + u2*y[,2] + u12*y[,1]*y[,2]))
},
- vfamily=c("loglinb2"),
+ vfamily = c("loglinb2"),
deriv = expression({
u1 <- eta[,1]
u2 <- eta[,2]
@@ -156,7 +156,7 @@ loglinb3 <- function(exchangeable = FALSE, zero = NULL)
stop("some combinations of the response not realized")
}
}),
- inverse= function(eta, extra = NULL) {
+ linkinv= function(eta, extra = NULL) {
eval(extra$my.expression)
cbind("000" = 1,
"001" = exp(u3),
@@ -168,12 +168,12 @@ loglinb3 <- function(exchangeable = FALSE, zero = NULL)
"111" = exp(u1+u2+u3+u12+u13+u23)) / denom
},
last = expression({
- misc$link = rep("identity", length=M)
+ misc$link = rep("identity", length = M)
names(misc$link) = predictors.names
- misc$earg = list(u1=list(), u2=list(), u3=list(),
- u12=list(), u13=list(), u23=list())
+ misc$earg = list(u1 = list(), u2 = list(), u3 = list(),
+ u12 = list(), u13 = list(), u23 = list())
}),
- link = function(mu, extra = NULL) {
+ linkfun = function(mu, extra = NULL) {
u0 <- log(mu[,1])
u3 <- log(mu[,2]) - u0
u2 <- log(mu[,3]) - u0
@@ -191,7 +191,7 @@ loglinb3 <- function(exchangeable = FALSE, zero = NULL)
sum(w*(u0 + u1*y[,1] + u2*y[,2] + u3*y[,3] +u12*y[,1]*y[,2] +
u13*y[,1]*y[,3] + u23*y[,2]*y[,3]))
},
- vfamily=c("loglinb3"),
+ vfamily = c("loglinb3"),
deriv = expression({
eval(extra$my.expression)
eval(extra$deriv.expression)
diff --git a/R/family.mixture.R b/R/family.mixture.R
index d454847..72789d8 100644
--- a/R/family.mixture.R
+++ b/R/family.mixture.R
@@ -8,22 +8,22 @@
-mix2normal1.control <- function(trace=TRUE, ...)
+mix2normal1.control <- function(trace = TRUE, ...)
{
list(trace=trace)
}
-mix2normal1 = function(lphi="logit",
- lmu="identity",
- lsd="loge",
- ephi=list(), emu1=list(), emu2=list(),
- esd1=list(), esd2=list(),
- iphi=0.5, imu1=NULL, imu2=NULL, isd1=NULL, isd2=NULL,
+mix2normal1 = function(lphi = "logit",
+ lmu = "identity",
+ lsd = "loge",
+ ephi = list(), emu1 = list(), emu2 = list(),
+ esd1 = list(), esd2 = list(),
+ iphi=0.5, imu1 = NULL, imu2 = NULL, isd1 = NULL, isd2 = NULL,
qmu=c(0.2, 0.8),
- equalsd=TRUE,
- nsimEIM=100,
- zero=1)
+ equalsd = TRUE,
+ nsimEIM = 100,
+ zero = 1)
{
if (mode(lphi) != "character" && mode(lphi) != "name")
lphi = as.character(substitute(lphi))
@@ -31,17 +31,17 @@ mix2normal1 = function(lphi="logit",
lmu = as.character(substitute(lmu))
if (mode(lsd) != "character" && mode(lsd) != "name")
lsd = as.character(substitute(lsd))
- if (!is.Numeric(qmu, allow=2, positive=TRUE) || any(qmu >= 1))
+ if (!is.Numeric(qmu, allow=2, positive = TRUE) || any(qmu >= 1))
stop("bad input for argument 'qmu'")
- if (length(iphi) && (!is.Numeric(iphi, allow=1, positive=TRUE) || iphi>= 1))
+ if (length(iphi) && (!is.Numeric(iphi, allow = 1, positive = TRUE) || iphi>= 1))
stop("bad input for argument 'iphi'")
if (length(imu1) && !is.Numeric(imu1))
stop("bad input for argument 'imu1'")
if (length(imu2) && !is.Numeric(imu2))
stop("bad input for argument 'imu2'")
- if (length(isd1) && !is.Numeric(isd1, positive=TRUE))
+ if (length(isd1) && !is.Numeric(isd1, positive = TRUE))
stop("bad input for argument 'isd1'")
- if (length(isd2) && !is.Numeric(isd2, positive=TRUE))
+ if (length(isd2) && !is.Numeric(isd2, positive = TRUE))
stop("bad input for argument 'isd2'")
if (!is.list(ephi)) ephi = list()
if (!is.list(emu1)) emu1 = list()
@@ -50,33 +50,33 @@ mix2normal1 = function(lphi="logit",
if (!is.list(esd2)) esd2 = list()
if (!is.logical(equalsd) || length(equalsd) != 1)
stop("bad input for argument 'equalsd'")
- if (!is.Numeric(nsimEIM, allow=1, integ=TRUE) || nsimEIM <= 10)
+ if (!is.Numeric(nsimEIM, allow = 1, integ = TRUE) || nsimEIM <= 10)
stop("'nsimEIM' should be an integer greater than 10")
new("vglmff",
- blurb=c("Mixture of two univariate normals\n\n",
+ blurb = c("Mixture of two univariate normals\n\n",
"Links: ",
- namesof("phi", lphi, earg= ephi, tag=FALSE), ", ",
- namesof("mu1", lmu, earg= emu1, tag=FALSE), ", ",
- namesof("sd1", lsd, earg= esd1, tag=FALSE), ", ",
- namesof("mu2", lmu, earg= emu2, tag=FALSE), ", ",
- namesof("sd2", lsd, earg= esd2, tag=FALSE), "\n",
+ namesof("phi", lphi, earg = ephi, tag = FALSE), ", ",
+ namesof("mu1", lmu, earg = emu1, tag = FALSE), ", ",
+ namesof("sd1", lsd, earg = esd1, tag = FALSE), ", ",
+ namesof("mu2", lmu, earg = emu2, tag = FALSE), ", ",
+ namesof("sd2", lsd, earg = esd2, tag = FALSE), "\n",
"Mean: phi*mu1 + (1-phi)*mu2\n",
"Variance: phi*sd1^2 + (1-phi)*sd2^2 + phi*(1-phi)*(mu1-mu2)^2"),
- constraints=eval(substitute(expression({
+ constraints = eval(substitute(expression({
constraints = cm.vgam(rbind(diag(4), c(0,0,1,0)), x, .equalsd,
- constraints, int=TRUE)
+ constraints, int = TRUE)
constraints = cm.zero.vgam(constraints, x, .zero, M)
}), list(.zero=zero, .equalsd=equalsd))),
- initialize=eval(substitute(expression({
+ initialize = eval(substitute(expression({
if (ncol(y <- cbind(y)) != 1)
stop("the response must be a vector or one-column matrix")
predictors.names = c(
- namesof("phi", .lphi, tag=FALSE),
- namesof("mu1", .lmu, earg= .emu1, tag=FALSE),
- namesof("sd1", .lsd, earg= .esd1, tag=FALSE),
- namesof("mu2", .lmu, earg= .emu2, tag=FALSE),
- namesof("sd2", .lsd, earg= .esd2, tag=FALSE))
+ namesof("phi", .lphi, tag = FALSE),
+ namesof("mu1", .lmu, earg = .emu1, tag = FALSE),
+ namesof("sd1", .lsd, earg = .esd1, tag = FALSE),
+ namesof("mu2", .lmu, earg = .emu2, tag = FALSE),
+ namesof("sd2", .lsd, earg = .esd2, tag = FALSE))
if (!length(etastart)) {
qy = quantile(y, prob= .qmu)
init.phi = rep(if(length(.iphi)) .iphi else 0.5, length=n)
@@ -92,26 +92,26 @@ mix2normal1 = function(lphi="logit",
if ( .equalsd ) {
init.sd1 = init.sd2 = (init.sd1 + init.sd2)/2
if (!all.equal( .esd1, .esd2 ))
- stop("'esd1' and 'esd2' must be equal if equalsd=TRUE")
+ stop("'esd1' and 'esd2' must be equal if equalsd = TRUE")
}
- etastart = cbind(theta2eta(init.phi, .lphi, earg= .ephi),
- theta2eta(init.mu1, .lmu, earg= .emu1),
- theta2eta(init.sd1, .lsd, earg= .esd1),
- theta2eta(init.mu2, .lmu, earg= .emu2),
- theta2eta(init.sd2, .lsd, earg= .esd2))
+ etastart = cbind(theta2eta(init.phi, .lphi, earg = .ephi),
+ theta2eta(init.mu1, .lmu, earg = .emu1),
+ theta2eta(init.sd1, .lsd, earg = .esd1),
+ theta2eta(init.mu2, .lmu, earg = .emu2),
+ theta2eta(init.sd2, .lsd, earg = .esd2))
}
}), list(.lphi=lphi, .lmu=lmu, .iphi=iphi, .imu1=imu1, .imu2=imu2,
.ephi=ephi, .emu1=emu1, .emu2=emu2, .esd1=esd1, .esd2=esd2,
.equalsd=equalsd,
.lsd=lsd, .isd1=isd1, .isd2=isd2, .qmu=qmu))),
- inverse=eval(substitute(function(eta, extra=NULL){
- phi = eta2theta(eta[,1], link= .lphi, earg= .ephi)
- mu1 = eta2theta(eta[,2], link= .lmu, earg= .emu1)
- mu2 = eta2theta(eta[,4], link= .lmu, earg= .emu2)
+ linkinv = eval(substitute(function(eta, extra = NULL){
+ phi = eta2theta(eta[,1], link = .lphi, earg = .ephi)
+ mu1 = eta2theta(eta[,2], link = .lmu, earg = .emu1)
+ mu2 = eta2theta(eta[,4], link = .lmu, earg = .emu2)
phi*mu1 + (1-phi)*mu2
}, list(.lphi=lphi, .lmu=lmu,
.ephi=ephi, .emu1=emu1, .emu2=emu2, .esd1=esd1, .esd2=esd2 ))),
- last=eval(substitute(expression({
+ last = eval(substitute(expression({
misc$link = c("phi"= .lphi, "mu1"= .lmu,
"sd1"= .lsd, "mu2"= .lmu, "sd2"= .lsd)
misc$earg = list("phi"= .ephi, "mu1"= .emu1,
@@ -122,13 +122,13 @@ mix2normal1 = function(lphi="logit",
}), list(.lphi=lphi, .lmu=lmu, .lsd=lsd, .equalsd=equalsd,
.ephi=ephi, .emu1=emu1, .emu2=emu2, .esd1=esd1, .esd2=esd2,
.nsimEIM=nsimEIM ))),
- loglikelihood=eval(substitute(
- function(mu,y,w,residuals=FALSE,eta,extra=NULL) {
- phi = eta2theta(eta[,1], link= .lphi, earg= .ephi)
- mu1 = eta2theta(eta[,2], link= .lmu, earg= .emu1)
- sd1 = eta2theta(eta[,3], link= .lsd, earg= .esd1)
- mu2 = eta2theta(eta[,4], link= .lmu, earg= .emu2)
- sd2 = eta2theta(eta[,5], link= .lsd, earg= .esd2)
+ loglikelihood = eval(substitute(
+ function(mu,y,w,residuals = FALSE,eta,extra = NULL) {
+ phi = eta2theta(eta[,1], link = .lphi, earg = .ephi)
+ mu1 = eta2theta(eta[,2], link = .lmu, earg = .emu1)
+ sd1 = eta2theta(eta[,3], link = .lsd, earg = .esd1)
+ mu2 = eta2theta(eta[,4], link = .lmu, earg = .emu2)
+ sd2 = eta2theta(eta[,5], link = .lsd, earg = .esd2)
f1 = dnorm(y, mean=mu1, sd=sd1)
f2 = dnorm(y, mean=mu2, sd=sd2)
if (residuals) stop("loglikelihood residuals not ",
@@ -137,18 +137,18 @@ mix2normal1 = function(lphi="logit",
}, list(.lphi=lphi, .lmu=lmu,
.ephi=ephi, .emu1=emu1, .emu2=emu2, .esd1=esd1, .esd2=esd2,
.lsd=lsd ))),
- vfamily=c("mix2normal1"),
- deriv=eval(substitute(expression({
- phi = eta2theta(eta[,1], link= .lphi, earg= .ephi)
- mu1 = eta2theta(eta[,2], link= .lmu, earg= .emu1)
- sd1 = eta2theta(eta[,3], link= .lsd, earg= .esd1)
- mu2 = eta2theta(eta[,4], link= .lmu, earg= .emu2)
- sd2 = eta2theta(eta[,5], link= .lsd, earg= .esd2)
- dphi.deta = dtheta.deta(phi, link= .lphi, earg= .ephi)
- dmu1.deta = dtheta.deta(mu1, link= .lmu, earg= .emu1)
- dmu2.deta = dtheta.deta(mu2, link= .lmu, earg= .emu2)
- dsd1.deta = dtheta.deta(sd1, link= .lsd, earg= .esd1)
- dsd2.deta = dtheta.deta(sd2, link= .lsd, earg= .esd2)
+ vfamily = c("mix2normal1"),
+ deriv = eval(substitute(expression({
+ phi = eta2theta(eta[,1], link = .lphi, earg = .ephi)
+ mu1 = eta2theta(eta[,2], link = .lmu, earg = .emu1)
+ sd1 = eta2theta(eta[,3], link = .lsd, earg = .esd1)
+ mu2 = eta2theta(eta[,4], link = .lmu, earg = .emu2)
+ sd2 = eta2theta(eta[,5], link = .lsd, earg = .esd2)
+ dphi.deta = dtheta.deta(phi, link = .lphi, earg = .ephi)
+ dmu1.deta = dtheta.deta(mu1, link = .lmu, earg = .emu1)
+ dmu2.deta = dtheta.deta(mu2, link = .lmu, earg = .emu2)
+ dsd1.deta = dtheta.deta(sd1, link = .lsd, earg = .esd1)
+ dsd2.deta = dtheta.deta(sd2, link = .lsd, earg = .esd2)
f1 = dnorm(y, mean=mu1, sd=sd1)
f2 = dnorm(y, mean=mu2, sd=sd2)
pdf = phi*f1 + (1-phi)*f2
@@ -193,14 +193,14 @@ mix2normal1 = function(lphi="logit",
run.mean = ((ii-1) * run.mean + temp3) / ii
}
wz = if (intercept.only)
- matrix(colMeans(run.mean), n, dimm(M), byrow=TRUE) else run.mean
+ matrix(colMeans(run.mean), n, dimm(M), byrow = TRUE) else run.mean
dtheta.detas = cbind(dphi.deta,
dmu1.deta,
dsd1.deta,
dmu2.deta,
dsd2.deta)
- index0 = iam(NA, NA, M=M, both=TRUE, diag=TRUE)
+ index0 = iam(NA, NA, M = M, both = TRUE, diag = TRUE)
wz = wz * dtheta.detas[,index0$row] * dtheta.detas[,index0$col]
c(w) * wz
}), list(.lphi=lphi, .lmu=lmu, .nsimEIM=nsimEIM ))))
@@ -209,24 +209,24 @@ mix2normal1 = function(lphi="logit",
-mix2poisson.control <- function(trace=TRUE, ...)
+mix2poisson.control <- function(trace = TRUE, ...)
{
list(trace=trace)
}
-mix2poisson = function(lphi="logit", llambda="loge",
- ephi=list(), el1=list(), el2=list(),
- iphi=0.5, il1=NULL, il2=NULL,
- qmu=c(0.2, 0.8), nsimEIM=100, zero=1)
+mix2poisson = function(lphi = "logit", llambda = "loge",
+ ephi = list(), el1 = list(), el2 = list(),
+ iphi=0.5, il1 = NULL, il2 = NULL,
+ qmu=c(0.2, 0.8), nsimEIM = 100, zero = 1)
{
if (mode(lphi) != "character" && mode(lphi) != "name")
lphi = as.character(substitute(lphi))
if (mode(llambda) != "character" && mode(llambda) != "name")
llambda = as.character(substitute(llambda))
- if (!is.Numeric(qmu, allow=2, positive=TRUE) || any(qmu >= 1))
+ if (!is.Numeric(qmu, allow=2, positive = TRUE) || any(qmu >= 1))
stop("bad input for argument 'qmu'")
- if (length(iphi) && (!is.Numeric(iphi, allow=1, positive=TRUE) || iphi>= 1))
+ if (length(iphi) && (!is.Numeric(iphi, allow = 1, positive = TRUE) || iphi>= 1))
stop("bad input for argument 'iphi'")
if (length(il1) && !is.Numeric(il1))
stop("bad input for argument 'il1'")
@@ -235,57 +235,57 @@ mix2poisson = function(lphi="logit", llambda="loge",
if (!is.list(ephi)) ephi = list()
if (!is.list(el1)) el1 = list()
if (!is.list(el2)) el2 = list()
- if (!is.Numeric(nsimEIM, allow=1, integ=TRUE) || nsimEIM <= 10)
+ if (!is.Numeric(nsimEIM, allow = 1, integ = TRUE) || nsimEIM <= 10)
stop("'nsimEIM' should be an integer greater than 10")
new("vglmff",
- blurb=c("Mixture of two Poisson distributions\n\n",
+ blurb = c("Mixture of two Poisson distributions\n\n",
"Links: ",
- namesof("phi",lphi, earg= ephi), ", ",
- namesof("lambda1", llambda, earg= el1, tag=FALSE), ", ",
- namesof("lambda2", llambda, earg= el2, tag=FALSE), "\n",
+ namesof("phi",lphi, earg = ephi), ", ",
+ namesof("lambda1", llambda, earg = el1, tag = FALSE), ", ",
+ namesof("lambda2", llambda, earg = el2, tag = FALSE), "\n",
"Mean: phi*lambda1 + (1-phi)*lambda2"),
- constraints=eval(substitute(expression({
+ constraints = eval(substitute(expression({
constraints = cm.zero.vgam(constraints, x, .zero, M)
}), list(.zero=zero ))),
- initialize=eval(substitute(expression({
+ initialize = eval(substitute(expression({
if (ncol(y <- cbind(y)) != 1)
stop("the response must be a vector or one-column matrix")
- predictors.names = c(namesof("phi", .lphi, earg= .ephi, tag=FALSE),
- namesof("lambda1", .llambda, earg= .el1, tag=FALSE),
- namesof("lambda2", .llambda, earg= .el2, tag=FALSE))
+ predictors.names = c(namesof("phi", .lphi, earg = .ephi, tag = FALSE),
+ namesof("lambda1", .llambda, earg = .el1, tag = FALSE),
+ namesof("lambda2", .llambda, earg = .el2, tag = FALSE))
if (!length(etastart)) {
qy = quantile(y, prob= .qmu)
init.phi = rep(if(length(.iphi)) .iphi else 0.5, length=n)
init.lambda1 = rep(if(length(.il1)) .il1 else qy[1], length=n)
init.lambda2 = rep(if(length(.il2)) .il2 else qy[2], length=n)
if (!length(etastart))
- etastart = cbind(theta2eta(init.phi, .lphi, earg= .ephi),
- theta2eta(init.lambda1, .llambda, earg= .el1),
- theta2eta(init.lambda2, .llambda, earg= .el2))
+ etastart = cbind(theta2eta(init.phi, .lphi, earg = .ephi),
+ theta2eta(init.lambda1, .llambda, earg = .el1),
+ theta2eta(init.lambda2, .llambda, earg = .el2))
}
}), list(.lphi=lphi, .llambda=llambda, .iphi=iphi, .il1=il1, .il2=il2,
.ephi=ephi, .el1=el1, .el2=el2,
.qmu=qmu))),
- inverse=eval(substitute(function(eta, extra=NULL){
- phi = eta2theta(eta[,1], link= .lphi, earg= .ephi)
- lambda1 = eta2theta(eta[,2], link= .llambda, earg= .el1)
- lambda2 = eta2theta(eta[,3], link= .llambda, earg= .el2)
+ linkinv = eval(substitute(function(eta, extra = NULL){
+ phi = eta2theta(eta[,1], link = .lphi, earg = .ephi)
+ lambda1 = eta2theta(eta[,2], link = .llambda, earg = .el1)
+ lambda2 = eta2theta(eta[,3], link = .llambda, earg = .el2)
phi*lambda1 + (1-phi)*lambda2
}, list(.lphi=lphi, .llambda=llambda,
.ephi=ephi, .el1=el1, .el2=el2 ))),
- last=eval(substitute(expression({
+ last = eval(substitute(expression({
misc$link = c("phi"= .lphi, "lambda1"= .llambda, "lambda2"= .llambda)
misc$earg = list("phi"= .ephi, "lambda1"= .el1, "lambda2"= .el2)
misc$expected = TRUE
misc$nsimEIM = .nsimEIM
}), list(.lphi=lphi, .llambda=llambda,
.ephi=ephi, .el1=el1, .el2=el2, .nsimEIM=nsimEIM ))),
- loglikelihood=eval(substitute(
- function(mu,y,w,residuals=FALSE,eta,extra=NULL) {
- phi = eta2theta(eta[,1], link= .lphi, earg= .ephi)
- lambda1 = eta2theta(eta[,2], link= .llambda, earg= .el1)
- lambda2 = eta2theta(eta[,3], link= .llambda, earg= .el2)
+ loglikelihood = eval(substitute(
+ function(mu,y,w,residuals = FALSE,eta,extra = NULL) {
+ phi = eta2theta(eta[,1], link = .lphi, earg = .ephi)
+ lambda1 = eta2theta(eta[,2], link = .llambda, earg = .el1)
+ lambda2 = eta2theta(eta[,3], link = .llambda, earg = .el2)
f1 = dpois(y, lam=lambda1)
f2 = dpois(y, lam=lambda2)
if (residuals) stop("loglikelihood residuals not ",
@@ -293,14 +293,14 @@ mix2poisson = function(lphi="logit", llambda="loge",
sum(w * log(phi*f1 + (1-phi)*f2))
}, list(.lphi=lphi, .llambda=llambda,
.ephi=ephi, .el1=el1, .el2=el2 ))),
- vfamily=c("mix2poisson"),
- deriv=eval(substitute(expression({
- phi = eta2theta(eta[,1], link= .lphi, earg= .ephi)
- lambda1 = eta2theta(eta[,2], link= .llambda, earg= .el1)
- lambda2 = eta2theta(eta[,3], link= .llambda, earg= .el2)
- dphi.deta = dtheta.deta(phi, link= .lphi, earg= .ephi)
- dlambda1.deta = dtheta.deta(lambda1, link= .llambda, earg= .el1)
- dlambda2.deta = dtheta.deta(lambda2, link= .llambda, earg= .el2)
+ vfamily = c("mix2poisson"),
+ deriv = eval(substitute(expression({
+ phi = eta2theta(eta[,1], link = .lphi, earg = .ephi)
+ lambda1 = eta2theta(eta[,2], link = .llambda, earg = .el1)
+ lambda2 = eta2theta(eta[,3], link = .llambda, earg = .el2)
+ dphi.deta = dtheta.deta(phi, link = .lphi, earg = .ephi)
+ dlambda1.deta = dtheta.deta(lambda1, link = .llambda, earg = .el1)
+ dlambda2.deta = dtheta.deta(lambda2, link = .llambda, earg = .el2)
f1 = dpois(x=y, lam=lambda1)
f2 = dpois(x=y, lam=lambda2)
pdf = phi*f1 + (1-phi)*f2
@@ -351,10 +351,10 @@ mix2poisson = function(lphi="logit", llambda="loge",
run.mean = ((ii-1) * run.mean + temp3) / ii
}
wz = if (intercept.only)
- matrix(colMeans(run.mean), n, dimm(M), byrow=TRUE) else run.mean
+ matrix(colMeans(run.mean), n, dimm(M), byrow = TRUE) else run.mean
dtheta.detas = cbind(dphi.deta, dlambda1.deta, dlambda2.deta)
- index0 = iam(NA, NA, M=M, both=TRUE, diag=TRUE)
+ index0 = iam(NA, NA, M = M, both = TRUE, diag = TRUE)
wz = wz * dtheta.detas[,index0$row] * dtheta.detas[,index0$col]
c(w) * wz
}), list(.lphi=lphi, .llambda=llambda,
@@ -365,97 +365,101 @@ mix2poisson = function(lphi="logit", llambda="loge",
-mix2exp.control <- function(trace=TRUE, ...)
-{
- list(trace=trace)
+mix2exp.control <- function(trace = TRUE, ...) {
+ list(trace = trace)
}
-mix2exp = function(lphi="logit", llambda="loge",
- ephi=list(), el1=list(), el2=list(),
- iphi=0.5, il1=NULL, il2=NULL,
- qmu=c(0.8, 0.2), nsimEIM=100, zero=1)
+mix2exp = function(lphi = "logit", llambda = "loge",
+ ephi = list(), el1 = list(), el2 = list(),
+ iphi=0.5, il1 = NULL, il2 = NULL,
+ qmu=c(0.8, 0.2), nsimEIM = 100, zero = 1)
{
if (mode(lphi) != "character" && mode(lphi) != "name")
lphi = as.character(substitute(lphi))
if (mode(llambda) != "character" && mode(llambda) != "name")
llambda = as.character(substitute(llambda))
- if (!is.Numeric(qmu, allow=2, positive=TRUE) || any(qmu >= 1))
+ if (!is.Numeric(qmu, allow=2, positive = TRUE) || any(qmu >= 1))
stop("bad input for argument 'qmu'")
- if (length(iphi) && (!is.Numeric(iphi, allow=1, positive=TRUE) || iphi>= 1))
+ if (length(iphi) && (!is.Numeric(iphi, allow = 1, positive = TRUE) ||
+ iphi >= 1))
stop("bad input for argument 'iphi'")
if (length(il1) && !is.Numeric(il1))
stop("bad input for argument 'il1'")
if (length(il2) && !is.Numeric(il2))
stop("bad input for argument 'il2'")
+
if (!is.list(ephi)) ephi = list()
if (!is.list(el1)) el1 = list()
if (!is.list(el2)) el2 = list()
- if (!is.Numeric(nsimEIM, allow=1, integ=TRUE) || nsimEIM <= 10)
+
+ if (!is.Numeric(nsimEIM, allow = 1, integ = TRUE) || nsimEIM <= 10)
stop("'nsimEIM' should be an integer greater than 10")
new("vglmff",
- blurb=c("Mixture of two univariate exponentials\n\n",
+ blurb = c("Mixture of two univariate exponentials\n\n",
"Links: ",
- namesof("phi", lphi, earg= ephi), ", ",
- namesof("lambda1", llambda, earg= el1, tag=FALSE), ", ",
- namesof("lambda2", llambda, earg= el2, tag=FALSE), "\n",
+ namesof("phi", lphi, earg = ephi), ", ",
+ namesof("lambda1", llambda, earg = el1, tag = FALSE), ", ",
+ namesof("lambda2", llambda, earg = el2, tag = FALSE), "\n",
"Mean: phi/lambda1 + (1-phi)/lambda2\n"),
- constraints=eval(substitute(expression({
+ constraints = eval(substitute(expression({
constraints = cm.zero.vgam(constraints, x, .zero, M)
}), list(.zero=zero ))),
- initialize=eval(substitute(expression({
+ initialize = eval(substitute(expression({
if (ncol(y <- cbind(y)) != 1)
stop("the response must be a vector or one-column matrix")
- predictors.names = c(namesof("phi", .lphi, earg= .ephi, tag=FALSE),
- namesof("lambda1", .llambda, earg= .el1,tag=FALSE),
- namesof("lambda2", .llambda, earg= .el2,tag=FALSE))
+ predictors.names = c(namesof("phi", .lphi, earg = .ephi, tag = FALSE),
+ namesof("lambda1", .llambda, earg = .el1,tag = FALSE),
+ namesof("lambda2", .llambda, earg = .el2,tag = FALSE))
if (!length(etastart)) {
qy = quantile(y, prob= .qmu)
init.phi = rep(if(length(.iphi)) .iphi else 0.5, length=n)
init.lambda1 = rep(if(length(.il1)) .il1 else 1/qy[1], length=n)
init.lambda2 = rep(if(length(.il2)) .il2 else 1/qy[2], length=n)
if (!length(etastart))
- etastart = cbind(theta2eta(init.phi, .lphi, earg= .ephi),
- theta2eta(init.lambda1, .llambda, earg= .el1),
- theta2eta(init.lambda2, .llambda, earg= .el2))
+ etastart = cbind(theta2eta(init.phi, .lphi, earg = .ephi),
+ theta2eta(init.lambda1, .llambda, earg = .el1),
+ theta2eta(init.lambda2, .llambda, earg = .el2))
}
}), list(.lphi=lphi, .llambda=llambda, .iphi=iphi, .il1=il1, .il2=il2,
.ephi=ephi, .el1=el1, .el2=el2,
.qmu=qmu))),
- inverse=eval(substitute(function(eta, extra=NULL){
- phi = eta2theta(eta[,1], link= .lphi, earg= .ephi)
- lambda1 = eta2theta(eta[,2], link= .llambda, earg= .el1)
- lambda2 = eta2theta(eta[,3], link= .llambda, earg= .el2)
+ linkinv = eval(substitute(function(eta, extra = NULL){
+ phi = eta2theta(eta[,1], link = .lphi, earg = .ephi)
+ lambda1 = eta2theta(eta[,2], link = .llambda, earg = .el1)
+ lambda2 = eta2theta(eta[,3], link = .llambda, earg = .el2)
phi/lambda1 + (1-phi)/lambda2
}, list(.lphi=lphi, .llambda=llambda,
.ephi=ephi, .el1=el1, .el2=el2 ))),
- last=eval(substitute(expression({
- misc$link = c("phi"= .lphi, "lambda1"= .llambda, "lambda2"= .llambda)
- misc$earg = list("phi"= .ephi, "lambda1"= .el1, "lambda2"= .el2)
+ last = eval(substitute(expression({
+ misc$link =
+ c("phi" = .lphi, "lambda1" = .llambda, "lambda2" = .llambda)
+ misc$earg =
+ list("phi" = .ephi, "lambda1" = .el1, "lambda2" = .el2)
misc$expected = TRUE
misc$nsimEIM = .nsimEIM
}), list(.lphi=lphi, .llambda=llambda, .nsimEIM=nsimEIM,
.ephi=ephi, .el1=el1, .el2=el2 ))),
- loglikelihood=eval(substitute(
- function(mu,y,w,residuals=FALSE,eta,extra=NULL) {
- phi = eta2theta(eta[,1], link= .lphi, earg= .ephi)
- lambda1 = eta2theta(eta[,2], link= .llambda, earg= .el1)
- lambda2 = eta2theta(eta[,3], link= .llambda, earg= .el2)
+ loglikelihood = eval(substitute(
+ function(mu,y,w,residuals = FALSE,eta,extra = NULL) {
+ phi = eta2theta(eta[,1], link = .lphi, earg = .ephi)
+ lambda1 = eta2theta(eta[,2], link = .llambda, earg = .el1)
+ lambda2 = eta2theta(eta[,3], link = .llambda, earg = .el2)
f1 = dexp(y, rate=lambda1)
f2 = dexp(y, rate=lambda2)
if (residuals) stop("loglikelihood residuals not ",
"implemented yet") else
sum(w * log(phi*f1 + (1-phi)*f2))
- }, list(.lphi=lphi, .llambda=llambda,
- .ephi=ephi, .el1=el1, .el2=el2 ))),
- vfamily=c("mix2exp"),
- deriv=eval(substitute(expression({
- phi = eta2theta(eta[,1], link= .lphi, earg= .ephi)
- lambda1 = eta2theta(eta[,2], link= .llambda, earg= .el1)
- lambda2 = eta2theta(eta[,3], link= .llambda, earg= .el2)
- dphi.deta = dtheta.deta(phi, link= .lphi, earg= .ephi)
- dlambda1.deta = dtheta.deta(lambda1, link= .llambda, earg= .el1)
- dlambda2.deta = dtheta.deta(lambda2, link= .llambda, earg= .el2)
+ }, list(.lphi = lphi, .llambda = llambda,
+ .ephi = ephi, .el1 = el1, .el2 = el2 ))),
+ vfamily = c("mix2exp"),
+ deriv = eval(substitute(expression({
+ phi = eta2theta(eta[,1], link = .lphi, earg = .ephi)
+ lambda1 = eta2theta(eta[,2], link = .llambda, earg = .el1)
+ lambda2 = eta2theta(eta[,3], link = .llambda, earg = .el2)
+ dphi.deta = dtheta.deta(phi, link = .lphi, earg = .ephi)
+ dlambda1.deta = dtheta.deta(lambda1, link = .llambda, earg = .el1)
+ dlambda2.deta = dtheta.deta(lambda2, link = .llambda, earg = .el2)
f1 = dexp(x=y, rate=lambda1)
f2 = dexp(x=y, rate=lambda2)
pdf = phi*f1 + (1-phi)*f2
@@ -503,10 +507,10 @@ mix2exp = function(lphi="logit", llambda="loge",
run.mean = ((ii-1) * run.mean + temp3) / ii
}
wz = if (intercept.only)
- matrix(colMeans(run.mean), n, dimm(M), byrow=TRUE) else run.mean
+ matrix(colMeans(run.mean), n, dimm(M), byrow = TRUE) else run.mean
dtheta.detas = cbind(dphi.deta, dlambda1.deta, dlambda2.deta)
- index0 = iam(NA, NA, M=M, both=TRUE, diag=TRUE)
+ index0 = iam(NA, NA, M = M, both = TRUE, diag = TRUE)
wz = wz * dtheta.detas[,index0$row] * dtheta.detas[,index0$col]
c(w) * wz
}), list(.lphi=lphi, .llambda=llambda,
diff --git a/R/family.nonlinear.R b/R/family.nonlinear.R
index f503c7f..21f897e 100644
--- a/R/family.nonlinear.R
+++ b/R/family.nonlinear.R
@@ -109,7 +109,7 @@ micmen <- function(rpar = 0.001, divisor = 10,
if (!is.logical(oim) || length(oim) != 1)
stop("argument 'oim' must be single logical")
- stopifnot(nsimEIM > 10, length(nsimEIM)==1, nsimEIM==round(nsimEIM))
+ stopifnot(nsimEIM > 10, length(nsimEIM) == 1, nsimEIM==round(nsimEIM))
if (!is.Numeric(imethod, allow = 1, integ = TRUE, posit = TRUE) ||
imethod > 3)
@@ -153,7 +153,7 @@ micmen <- function(rpar = 0.001, divisor = 10,
stop("regressor not found or is not a vector. Use the ",
"'form2' argument without an intercept")
Xm2 <- as.vector(Xm2) # Make sure
- extra$Xm2 <- Xm2 # Needed for @inverse
+ extra$Xm2 <- Xm2 # Needed for @linkinv
predictors.names <-
c(namesof("theta1", .link1, earg = .earg1, tag = FALSE),
@@ -198,7 +198,7 @@ micmen <- function(rpar = 0.001, divisor = 10,
.init2 = init2, .link2 = link2, .earg2 = earg2,
.imethod = imethod,
.prob.x = prob.x ))),
- inverse = eval(substitute(function(eta, extra = NULL) {
+ linkinv = eval(substitute(function(eta, extra = NULL) {
theta1 <- eta2theta(eta[,1], .link1, earg = .earg1)
theta2 <- eta2theta(eta[,2], .link2, earg = .earg2)
theta1 * extra$Xm2 / (theta2 + extra$Xm2)
@@ -379,7 +379,7 @@ skira.control <- function(save.weight = TRUE, ...)
if (!is.list(earg2))
earg2 = list()
- stopifnot(nsimEIM > 10, length(nsimEIM)==1, nsimEIM==round(nsimEIM))
+ stopifnot(nsimEIM > 10, length(nsimEIM) == 1, nsimEIM == round(nsimEIM))
new("vglmff",
blurb = c("Shinozaki-Kira regression model\n",
@@ -495,7 +495,7 @@ skira.control <- function(save.weight = TRUE, ...)
.smallno = smallno, .prob.x = prob.x,
.nsimEIM = nsimEIM,
.imethod = imethod ))),
- inverse = eval(substitute(function(eta, extra = NULL) {
+ linkinv = eval(substitute(function(eta, extra = NULL) {
theta1 <- eta2theta(eta[, 1], .link1, earg = .earg1)
theta2 <- eta2theta(eta[, 2], .link2, earg = .earg2)
1 / (theta1 + theta2 * extra$Xm2)
diff --git a/R/family.normal.R b/R/family.normal.R
index d91a39c..2304f11 100644
--- a/R/family.normal.R
+++ b/R/family.normal.R
@@ -80,7 +80,7 @@ VGAM.weights.function = function(w, M, n) {
if (!length(etastart))
etastart = 0 * y
}), list( .parallel = parallel, .zero = zero ))),
- inverse = function(eta, extra = NULL) eta,
+ linkinv = function(eta, extra = NULL) eta,
last = eval(substitute(expression({
dy = dimnames(y)
if (!is.null(dy[[2]]))
@@ -142,7 +142,7 @@ VGAM.weights.function = function(w, M, n) {
}
}
},
- link = function(mu, extra = NULL) mu,
+ linkfun = function(mu, extra = NULL) mu,
vfamily = "gaussianff",
deriv=expression({
wz = VGAM.weights.function(w = w, M = M, n = n)
@@ -178,6 +178,7 @@ dposnorm = function(x, mean = 0, sd = 1, log = FALSE) {
}
}
+
pposnorm = function(q, mean = 0, sd = 1) {
L = max(length(q), length(mean), length(sd))
q = rep(q, len = L); mean = rep(mean, len = L); sd = rep(sd, len = L);
@@ -185,6 +186,7 @@ pposnorm = function(q, mean = 0, sd = 1) {
pnorm(0, mean = mean, sd = sd)) / pnorm(q = mean/sd))
}
+
qposnorm = function(p, mean = 0, sd = 1) {
if (!is.Numeric(p, posit = TRUE) || max(p) >= 1)
stop("bad input for argument 'p'")
@@ -192,6 +194,7 @@ qposnorm = function(p, mean = 0, sd = 1) {
mean = mean, sd = sd)
}
+
rposnorm = function(n, mean = 0, sd = 1) {
if (!is.Numeric(n, integ = TRUE, posit = TRUE))
stop("bad input for argument 'n'")
@@ -245,22 +248,27 @@ rposnorm = function(n, mean = 0, sd = 1) {
initialize = eval(substitute(expression({
if (ncol(y <- cbind(y)) != 1)
stop("response must be a vector or a one-column matrix")
+
if (min(y) <= 0)
stop("response must be positive")
+
predictors.names =
c(namesof("mean", .lmean, earg = .emean, tag = FALSE),
namesof("sd", .lsd, earg = .esd, tag = FALSE))
+
if (!length(etastart)) {
init.me = if (length( .imean)) rep( .imean, len = n) else NULL
init.sd = if (length( .isd )) rep( .isd , len = n) else NULL
- if (!length(init.me)) init.me = rep(quantile(y, probs=0.40), len = n)
- if (!length(init.sd)) init.sd = rep(sd(y)*1.2, len = n)
+ if (!length(init.me))
+ init.me = rep(quantile(y, probs=0.40), len = n)
+ if (!length(init.sd))
+ init.sd = rep(sd(c(y)) * 1.2, len = n)
etastart = cbind(theta2eta(init.me, .lmean, earg = .emean),
theta2eta(init.sd, .lsd, earg = .esd))
}
}), list( .lmean = lmean, .lsd = lsd, .imean = imean, .isd = isd,
.emean = emean, .esd = esd ))),
- inverse = eval(substitute(function(eta, extra = NULL) {
+ linkinv = eval(substitute(function(eta, extra = NULL) {
mymu = eta2theta(eta[,1], .lmean, earg = .emean)
mysd = eta2theta(eta[,2], .lsd, earg = .esd)
mymu + mysd * dnorm(-mymu/mysd) / pnorm(mymu/mysd)
@@ -549,7 +557,7 @@ rtikuv = function(n, d, mean = 0, sigma = 1, Smallno=1.0e-6) {
}
}),list( .lmean = lmean, .lsigma=lsigma, .isigma=isigma, .d=d,
.emean = emean, .esigma=esigma ))),
- inverse = eval(substitute(function(eta, extra = NULL) {
+ linkinv = eval(substitute(function(eta, extra = NULL) {
eta2theta(eta[,1], .lmean, earg = .emean)
}, list( .lmean = lmean,
.emean = emean, .esigma=esigma ))),
@@ -744,7 +752,7 @@ rfnorm = function(n, mean = 0, sd = 1, a1 = 1, a2=1) {
}), list( .lmean = lmean, .lsd = lsd, .emean = emean, .esd = esd,
.imean = imean, .isd = isd, .a1 = a1, .a2 = a2,
.imethod = imethod ))),
- inverse = eval(substitute(function(eta, extra = NULL) {
+ linkinv = eval(substitute(function(eta, extra = NULL) {
mymu = eta2theta(eta[,1], .lmean, earg = .emean)
mysd = eta2theta(eta[,2], .lsd, earg = .esd)
mytheta = mymu/mysd
@@ -876,7 +884,7 @@ lqnorm = function(qpower = 2, link = "identity", earg = list(),
}
}), list( .imethod = imethod, .imu = imu,
.sinit = shrinkage.init, .link = link, .earg = earg ))),
- inverse = eval(substitute(function(eta, extra = NULL) {
+ linkinv = eval(substitute(function(eta, extra = NULL) {
mu = eta2theta(eta, link = .link, earg = .earg)
mu
}, list( .link = link, .earg = earg ))),
@@ -893,7 +901,7 @@ lqnorm = function(qpower = 2, link = "identity", earg = list(),
}), list( .qpower = qpower,
.link = link, .earg = earg,
.imethod = imethod ))),
- link = eval(substitute(function(mu, extra = NULL) {
+ linkfun = eval(substitute(function(mu, extra = NULL) {
theta2eta(mu, link = .link, earg = .earg)
}, list( .link = link, .earg = earg ))),
vfamily = "lqnorm",
@@ -1175,7 +1183,7 @@ tobit.control <- function(save.weight = TRUE, ...)
.emu = emu, .esd = esd,
.imu = imu, .isd = isd,
.imethod = imethod ))),
- inverse = eval(substitute( function(eta, extra = NULL) {
+ linkinv = eval(substitute( function(eta, extra = NULL) {
Musual = 2
ncoly = ncol(eta) / Musual
mum = eta2theta(eta[,Musual*(1:ncoly)-1, drop=FALSE], .lmu, earg = .emu)
@@ -1451,13 +1459,14 @@ tobit.control <- function(save.weight = TRUE, ...)
zero = -2)
{
+
lsdev <- lsd
esdev <- esd
if (mode(lmean) != "character" && mode(lmean) != "name")
- lmean <- as.character(substitute(lmean))
+ lmean <- as.character(substitute(lmean))
if (mode(lsdev) != "character" && mode(lsdev) != "name")
- lsdev <- as.character(substitute(lsdev))
+ lsdev <- as.character(substitute(lsdev))
if (length(zero) &&
!is.Numeric(zero, integer = TRUE))
stop("bad input for argument 'zero'")
@@ -1484,8 +1493,10 @@ tobit.control <- function(save.weight = TRUE, ...)
zero = .zero)
}, list( .zero = zero ))),
initialize = eval(substitute(expression({
+ orig.y <- y
y <- cbind(y)
+
ncoly <- ncol(y)
Musual <- 2
extra$ncoly <- ncoly
@@ -1493,42 +1504,73 @@ tobit.control <- function(save.weight = TRUE, ...)
M <- Musual * ncoly
+
+ if (length(attr(orig.y, "Prior.Weights"))) {
+ if (any(c(w) != 1))
+ warning("replacing the 'weights' argument by the 'Prior.Weights'",
+ "attribute of the response (probably due to Qvar()")
+
+
+ w = attr(orig.y, "Prior.Weights")
+
+
+ extra$attributes.y = attributes(orig.y)
+
+ } else {
+ w <- cbind(w)
+ if (ncol(w) < ncoly)
+ w <- matrix(w, n, ncoly)
+ if (ncol(w) > ncoly)
+ stop("currently the 'weights' argument must have no more ",
+ "than the number of columns of the response")
+ }
+
+
+
mynames1 <- paste("mean", if (ncoly > 1) 1:ncoly else "", sep = "")
mynames2 <- paste("sd", if (ncoly > 1) 1:ncoly else "", sep = "")
predictors.names <-
c(namesof(mynames1, .lmean, earg = .emean, tag = FALSE),
namesof(mynames2, .lsdev, earg = .esdev, tag = FALSE))
- predictors.names <- predictors.names[interleave.VGAM(M, M = ncoly)]
+ predictors.names <- predictors.names[interleave.VGAM(M, M = Musual)]
+ extra$predictors.names <- predictors.names
+
if (!length(etastart)) {
sdev.init <- mean.init <- matrix(0, n, ncoly)
for (jay in 1:ncoly) {
- jfit <- lm.wfit(x = x, y = y[, jay], w = w)
+ jfit <- lm.wfit(x = x, y = y[, jay], w = w[, jay])
mean.init[, jay] <- if ( .lmean == "loge")
pmax(1/1024, y[, jay]) else
if( .imethod == 1) median(y[, jay]) else
- if( .imethod == 2) weighted.mean(y[, jay], w = w) else
+ if( .imethod == 2) weighted.mean(y[, jay], w = w[, jay]) else
mean(jfit$fitted)
sdev.init[, jay] <-
if( .imethod == 1)
- sqrt( sum(w * (y[, jay] - mean.init[, jay])^2) / sum(w) ) else
+ sqrt( sum(w * (y[, jay] - mean.init[, jay])^2) / sum(w[, jay]) ) else
if( .imethod == 2) {
if (jfit$df.resid > 0)
- sqrt( sum(w * jfit$resid^2) / jfit$df.resid ) else
- sqrt( sum(w * jfit$resid^2) / sum(w) )
+ sqrt( sum(w[, jay] * jfit$resid^2) / jfit$df.resid ) else
+ sqrt( sum(w[, jay] * jfit$resid^2) / sum(w[, jay]) )
} else {
- sqrt( sum(w * abs(y[, jay] - mean.init[, jay])) / sum(w) )
+ sqrt( sum(w[, jay] * abs(y[, jay] -
+ mean.init[, jay])) / sum(w[, jay]) )
}
+ if (any(sdev.init[, jay] <= sqrt(.Machine$double.eps) ))
+ sdev.init[, jay] <- 1.01
+
}
etastart <- cbind(theta2eta(mean.init, .lmean, earg = .emean),
theta2eta(sdev.init, .lsdev, earg = .esdev))
etastart <- etastart[, interleave.VGAM(ncol(etastart), M = Musual)]
+
+ colnames(etastart) <- predictors.names
}
}), list( .lmean = lmean, .lsdev = lsdev,
.emean = emean, .esdev = esdev,
.imethod = imethod ))),
- inverse = eval(substitute(function(eta, extra = NULL) {
+ linkinv = eval(substitute(function(eta, extra = NULL) {
ncoly <- extra$ncoly
eta2theta(eta[, 2*(1:ncoly) - 1], .lmean, earg = .emean)
}, list( .lmean = lmean, .emean = emean, .esdev = esdev ))),
@@ -1536,15 +1578,19 @@ tobit.control <- function(save.weight = TRUE, ...)
Musual <- extra$Musual
misc$link <- c(rep( .lmean, length = ncoly),
rep( .lsdev, length = ncoly))
+ misc$link <- misc$link[interleave.VGAM(Musual * ncoly, M = Musual)]
temp.names <- c(mynames1, mynames2)
temp.names <- temp.names[interleave.VGAM(Musual * ncoly, M = Musual)]
names(misc$link) <- temp.names
+
+
misc$earg <- vector("list", Musual * ncoly)
names(misc$earg) <- temp.names
for(ii in 1:ncoly) {
misc$earg[[Musual*ii-1]] <- .emean
misc$earg[[Musual*ii ]] <- .esdev
}
+ names(misc$earg) <- temp.names
misc$Musual <- Musual
misc$expected <- TRUE
@@ -1637,7 +1683,7 @@ tobit.control <- function(save.weight = TRUE, ...)
}
}), list( .lmeanlog = lmeanlog, .lsdlog = lsdlog,
.emeanlog = emeanlog, .esdlog = esdlog ))),
- inverse = eval(substitute(function(eta, extra = NULL) {
+ linkinv = eval(substitute(function(eta, extra = NULL) {
mulog = eta2theta(eta[,1], .lmeanlog, earg = .emeanlog)
sdlog = eta2theta(eta[,2], .lsdlog, earg = .esdlog)
exp(mulog + 0.5 * sdlog^2)
@@ -1753,7 +1799,7 @@ tobit.control <- function(save.weight = TRUE, ...)
}), list( .lmeanlog = lmeanlog, .lsdlog = lsdlog,
.emeanlog = emeanlog, .esdlog = esdlog,
.delta = delta, .powers.try = powers.try ))),
- inverse = eval(substitute(function(eta, extra = NULL) {
+ linkinv = eval(substitute(function(eta, extra = NULL) {
mymu = eta2theta(eta[,1], .lmeanlog, earg = .emeanlog)
sdlog = eta2theta(eta[,2], .lsdlog, earg = .esdlog)
lambda = eta2theta(eta[,3], "identity", earg = list())
@@ -1894,7 +1940,7 @@ rsnorm = function(n, location = 0, scale = 1, shape=0) {
etastart = matrix(init.shape, n, ncol(y))
}
}), list( .lshape = lshape, .earg = earg, .ishape = ishape ))),
- inverse = eval(substitute(function(eta, extra = NULL) {
+ linkinv = eval(substitute(function(eta, extra = NULL) {
alpha = eta2theta(eta, .lshape, earg = .earg)
alpha * sqrt(2/(pi * (1+alpha^2 )))
}, list( .earg = earg, .lshape = lshape ))),
@@ -1904,7 +1950,7 @@ rsnorm = function(n, location = 0, scale = 1, shape=0) {
misc$nsimEIM = .nsimEIM
misc$expected = (length( .nsimEIM ) > 0)
}), list( .earg = earg, .lshape = lshape, .nsimEIM = nsimEIM ))),
- link = eval(substitute(function(mu, extra = NULL) {
+ linkfun = eval(substitute(function(mu, extra = NULL) {
alpha = mu / sqrt(2/pi - mu^2)
theta2eta(alpha, .lshape, earg = .earg)
}, list( .earg = earg, .lshape = lshape ))),
diff --git a/R/family.others.R b/R/family.others.R
index 3f0533e..e16df94 100644
--- a/R/family.others.R
+++ b/R/family.others.R
@@ -178,7 +178,7 @@ rexppois <- function(n, lambda, betave = 1) {
.ilambda = ilambda, .ibetave = ibetave,
.elambda = elambda, .ebetave = ebetave))),
- inverse = eval(substitute(function(eta, extra = NULL) {
+ linkinv = eval(substitute(function(eta, extra = NULL) {
lambda = eta2theta(eta[, 1], .llambda , earg = .elambda )
betave = eta2theta(eta[, 2], .lbetave , earg = .ebetave )
@@ -430,7 +430,7 @@ genrayleigh.control <- function(save.weight = TRUE, ...)
.iscale = iscale, .ishape = ishape,
.escale = escale, .eshape = eshape))),
- inverse = eval(substitute(function(eta, extra = NULL) {
+ linkinv = eval(substitute(function(eta, extra = NULL) {
shape = eta2theta(eta[, 1], .lshape , earg = .eshape )
Scale = eta2theta(eta[, 2], .lscale , earg = .escale )
# zz yet to do: Find expression for mean
@@ -729,7 +729,7 @@ expgeometric.control <- function(save.weight = TRUE, ...)
.iscale = iscale, .ishape = ishape,
.escale = escale, .eshape = eshape))),
- inverse = eval(substitute(function(eta, extra = NULL) {
+ linkinv = eval(substitute(function(eta, extra = NULL) {
Scale = eta2theta(eta[, 1], .lscale , earg = .escale )
shape = eta2theta(eta[, 2], .lshape , earg = .eshape )
@@ -1050,7 +1050,7 @@ explogarithmic.control <- function(save.weight = TRUE, ...)
.iscale = iscale, .ishape = ishape,
.escale = escale, .eshape = eshape))),
- inverse = eval(substitute(function(eta, extra = NULL) {
+ linkinv = eval(substitute(function(eta, extra = NULL) {
Scale = eta2theta(eta[, 1], .lscale , earg = .escale )
shape = eta2theta(eta[, 2], .lshape , earg = .eshape )
@@ -1376,7 +1376,7 @@ if (FALSE)
.ilocat = ilocat, .iscale = iscale, .ishape = ishape,
.imethod = imethod) )),
- inverse = eval(substitute(function(eta, extra = NULL) {
+ linkinv = eval(substitute(function(eta, extra = NULL) {
locat = eta2theta(eta[, 1], .llocat, earg = .elocat )
scale = eta2theta(eta[, 2], .lscale, earg = .escale )
shape = eta2theta(eta[, 3], .lshape, earg = .eshape )
@@ -1701,7 +1701,7 @@ tpnff <- function(llocation = "identity", lscale = "loge",
}), list( .llocat = llocation, .lscale = lscale,
.elocat = elocation, .escale = escale,
.method.init=method.init ))),
- inverse = eval(substitute(function(eta, extra = NULL) {
+ linkinv = eval(substitute(function(eta, extra = NULL) {
eta2theta(eta[,1], .llocat, earg = .elocat)
}, list( .llocat = llocation,
.elocat = elocation, .escale = escale ))),
@@ -1849,7 +1849,7 @@ tpnff3 <- function(llocation = "identity", elocation = list(),
.elocat = elocation, .escale = escale, .eskewpar = eskewpar,
.method.init=method.init ))),
- inverse = eval(substitute(function(eta, extra = NULL) {
+ linkinv = eval(substitute(function(eta, extra = NULL) {
eta2theta(eta[,1], .llocat, earg = .elocat)
}, list( .llocat = llocation,
.elocat = elocation, .escale = escale ))),
diff --git a/R/family.positive.R b/R/family.positive.R
index ae30ba5..317d27a 100644
--- a/R/family.positive.R
+++ b/R/family.positive.R
@@ -224,7 +224,7 @@ dhuggins91 = function(x, prob, prob0 = prob, log = FALSE) {
mustart = NULL
}), list( .link = link, .earg = earg, .iprob = iprob ))),
- inverse = eval(substitute(function(eta, extra = NULL) {
+ linkinv = eval(substitute(function(eta, extra = NULL) {
Musual = 2
Mdiv2 = ncol(eta) / Musual
index1 = Musual * (1:Mdiv2) - 1
@@ -559,7 +559,7 @@ rposnegbin = function(n, size, prob = NULL, munb = NULL) {
.emunb = emunb, .esize = esize,
.sinit = shrinkage.init,
.imethod = imethod ))),
- inverse = eval(substitute(function(eta, extra = NULL) {
+ linkinv = eval(substitute(function(eta, extra = NULL) {
NOS = ncol(eta) / 2
munb = eta2theta(eta[,2*(1:NOS)-1, drop = FALSE],
.lmunb, earg = .emunb )
@@ -768,7 +768,7 @@ rpospois = function(n, lambda) {
etastart <- theta2eta(lambda.init, .link, earg = .earg)
}), list( .link = link, .earg = earg,
.ilambda = ilambda, .imethod = imethod ))),
- inverse = eval(substitute(function(eta, extra = NULL) {
+ linkinv = eval(substitute(function(eta, extra = NULL) {
lambda <- eta2theta(eta, .link, earg = .earg )
-lambda / expm1(-lambda)
}, list( .link = link, .earg = earg ))),
@@ -958,7 +958,7 @@ dposbinom = function(x, size, prob, log = FALSE) {
}
mustart = NULL
}), list( .link = link, .earg = earg, .mv = mv ))),
- inverse = eval(substitute(function(eta, extra = NULL) {
+ linkinv = eval(substitute(function(eta, extra = NULL) {
w = extra$w
mymu = eta2theta(eta, .link, earg = .earg )
nvec = if ( .mv ) {
@@ -1047,3 +1047,181 @@ dposbinom = function(x, size, prob, log = FALSE) {
+
+
+ rasch = function(lability = "identity", eability = list(),
+ ldifficulty = "identity", edifficulty = list(),
+ iability = NULL,
+ idifficulty = NULL,
+ parallel = TRUE) {
+
+
+
+ labil = lability
+ eabil = eability
+ ldiff = ldifficulty
+ ediff = edifficulty
+
+
+ if (mode(labil) != "character" && mode(labil) != "name")
+ labil = as.character(substitute(labil))
+ if (!is.list(eabil)) eabil = list()
+ if (!is.list(ediff)) ediff = list()
+
+
+ if (length(iability))
+ if (!is.Numeric(iability))
+ stop("bad input in argument 'iability'")
+ if (length(idifficulty))
+ if (!is.Numeric(idifficulty))
+ stop("bad input in argument 'idifficulty'")
+
+
+ new("vglmff",
+ blurb = c("Rasch model\n\n",
+ "Links: ",
+ namesof("ability", labil, earg = eabil, tag = FALSE), ", ",
+ namesof("difficulty", ldiff, earg = ediff, tag = FALSE),
+ "\n"),
+
+ initialize = eval(substitute(expression({
+ mustart.orig = mustart
+ y = as.matrix(y)
+ extra$ncoly = ncoly = ncol(y)
+ M = n + ncoly # number of ability and number of item parameters
+
+
+ mustart = matrix(apply(y, 2, weighted.mean, w = w),
+ n, ncol(y), byrow = TRUE)
+ mustart[mustart == 0] = 0.05
+ mustart[mustart == 1] = 0.95
+
+ if (ncoly == 1)
+ stop("the response is univariate, therefore use binomialff()")
+
+
+ if (!all(y == 0 | y == 1))
+ stop("response must contain 0s and 1s only")
+ if (any(w <= 0))
+ stop("argument 'weights' must contain positive values only")
+
+
+ dn2 = if (is.matrix(y)) dimnames(y)[[2]] else NULL
+ dn2 = as.character(1:ncoly)
+ dn2 = as.character(1:nrow(y))
+ dn2 = if (length(dn2)) {
+ paste("ability", dn2, sep = "")
+ } else {
+ paste("zz", 1:Mdiv2, sep = "")
+ }
+ dn2 = c(dn2, paste("item", as.character(1:nrow(y)), sep = ""))
+ predictors.names =
+ namesof(dn2, .labil, earg = .eability, short = TRUE)
+
+
+
+
+ if (!length(etastart)) {
+
+ init.abil = runif(n) / (1 + colSums(y) - (1:n))
+ init.diff = -logit(apply(y, 2, weighted.mean, w = w), inverse = TRUE)
+
+ etastart =
+ cbind(matrix(init.abil, n, n), # byrow = TRUE ,
+ matrix(init.diff, n, ncoly, byrow = TRUE))
+
+ }
+ }), list( .labil = labil, .eabil = eabil,
+ .ldiff = ldiff, .ediff = ediff,
+ .iability = iability,
+ .idifficulty = idifficulty ))),
+
+ linkinv = eval(substitute(function(eta, extra = NULL) {
+ myprobs = eta2theta(eta, "logit", earg = list())
+ print("head(myprobs)")
+ print( head(myprobs) )
+ myprobs
+ }, list( .labil = labil, .eabil = eabil,
+ .ldiff = ldiff, .ediff = ediff ))),
+ last = eval(substitute(expression({
+
+ misc$link = c(rep( .labil, length = n),
+ rep( .ldiff, length = ncoly))
+
+ names(misc$link) = dn2
+
+ misc$earg = vector("list", M)
+ names(misc$earg) = names(misc$link)
+ for(ii in 1:n)
+ misc$earg[[ii]] = .eabil
+ for(ii in 1:ncoly)
+ misc$earg[[n + ii]] = .ediff
+
+ misc$expected = TRUE
+ misc$iability = .iability
+ misc$idifficulty = .idifficulty
+
+ }), list( .labil = labil, .eabil = eabil,
+ .ldiff = ldiff, .ediff = ediff,
+ .iability = iability,
+ .idifficulty = idifficulty ))),
+ loglikelihood = eval(substitute(
+ function(mu, y, w, residuals = FALSE, eta, extra = NULL) {
+ if (residuals) stop("loglikelihood residuals ",
+ "not implemented yet") else {
+ sum(w * (y * log(mu) + (1 - y) * log1p(-mu)))
+ }
+ }, list( .labil = labil, .eabil = eabil,
+ .ldiff = ldiff, .ediff = ediff ))),
+ vfamily = c("rasch"),
+ deriv = eval(substitute(expression({
+ print("head(mu)")
+ print( head(mu) )
+ dabil.deta = 1
+ ddiff.deta = 1
+
+ dl.dabil = matrix(colSums(y - mu), n, n)
+ dl.ddiff = -cbind(y - mu)
+
+ deriv.ans = cbind(dl.dabil * dabil.deta,
+ dl.ddiff * ddiff.deta)
+ print("head(deriv.ans)")
+ print( head(deriv.ans) )
+
+ deriv.ans
+ }), list( .labil = labil, .eabil = eabil,
+ .ldiff = ldiff, .ediff = ediff ))),
+
+ weight = eval(substitute(expression({
+
+ wz = matrix(0, n, dimm(M))
+ wz[, 1:M] = sqrt( .Machine$double.eps )
+
+
+ tmp1 = colSums(mu * (1 - mu))
+ for (ii in 1:n)
+ wz[ii, ii] = tmp1[ii]
+
+
+
+ wz[, n + (1:ncoly)] = mu * (1 - mu)
+
+
+ for (ii in 1:n)
+ for (jay in 1:ncoly)
+ wz[ii, iam(ii, jay, M = M)] = -mu[ii, jay] * (1 - mu[ii, jay])
+
+ print("head(wz)")
+ print( head(wz) )
+
+ wz = wz * w
+ wz
+ }), list( .labil = labil, .eabil = eabil ))))
+}
+
+
+
+
+
+
+
diff --git a/R/family.qreg.R b/R/family.qreg.R
index e788a6c..0547c4d 100644
--- a/R/family.qreg.R
+++ b/R/family.qreg.R
@@ -16,6 +16,7 @@
+
lms.bcn.control <-
lms.bcg.control <-
lms.yjn.control <- function(trace = TRUE, ...)
@@ -26,15 +27,15 @@ lms.yjn.control <- function(trace = TRUE, ...)
lms.bcn <- function(percentiles = c(25,50,75),
- zero = c(1,3),
+ zero = c(1, 3),
llambda = "identity",
lmu = "identity",
lsigma = "loge",
- elambda = list(), emu=list(), esigma = list(),
+ elambda = list(), emu = list(), esigma = list(),
dfmu.init=4,
- dfsigma.init=2,
- ilambda=1,
- isigma=NULL, expectiles = FALSE)
+ dfsigma.init = 2,
+ ilambda = 1,
+ isigma = NULL, expectiles = FALSE)
{
if (mode(llambda) != "character" && mode(llambda) != "name")
llambda = as.character(substitute(llambda))
@@ -46,32 +47,32 @@ lms.yjn.control <- function(trace = TRUE, ...)
if (!is.list(emu)) emu = list()
if (!is.list(esigma)) esigma = list()
if (!is.Numeric(ilambda))
- stop("bad input for argument 'ilambda'")
- if (length(isigma) && !is.Numeric(isigma, posit=TRUE))
- stop("bad input for argument 'isigma'")
+ stop("bad input for argument 'ilambda'")
+ if (length(isigma) && !is.Numeric(isigma, posit = TRUE))
+ stop("bad input for argument 'isigma'")
if (length(expectiles) != 1 || !is.logical(expectiles))
- stop("bad input for argument 'expectiles'")
+ stop("bad input for argument 'expectiles'")
new("vglmff",
blurb = c("LMS ", if (expectiles) "Expectile" else "Quantile",
" Regression (Box-Cox transformation to normality)\n",
"Links: ",
- namesof("lambda", link=llambda, earg = elambda), ", ",
- namesof("mu", link=lmu, earg = emu), ", ",
- namesof("sigma", link=lsigma, earg = esigma)),
- constraints=eval(substitute(expression({
+ namesof("lambda", link = llambda, earg = elambda), ", ",
+ namesof("mu", link = lmu, earg = emu), ", ",
+ namesof("sigma", link = lsigma, earg = esigma)),
+ constraints = eval(substitute(expression({
constraints = cm.zero.vgam(constraints, x, .zero, M)
}), list(.zero=zero))),
- initialize=eval(substitute(expression({
+ initialize = eval(substitute(expression({
if (ncol(cbind(y)) != 1)
- stop("response must be a vector or a one-column matrix")
+ stop("response must be a vector or a one-column matrix")
if (any(y<0, na.rm = TRUE))
- stop("negative responses not allowed")
+ stop("negative responses not allowed")
predictors.names =
- c(namesof("lambda", .llambda, earg = .elambda, short= TRUE),
- namesof("mu", .lmu, earg = .emu, short= TRUE),
- namesof("sigma", .lsigma, earg = .esigma, short= TRUE))
+ c(namesof("lambda", .llambda, earg = .elambda, short= TRUE),
+ namesof("mu", .lmu, earg = .emu, short= TRUE),
+ namesof("sigma", .lsigma, earg = .esigma, short= TRUE))
if (!length(etastart)) {
@@ -91,23 +92,24 @@ lms.yjn.control <- function(trace = TRUE, ...)
sqrt(var(myratio))
} else .isigma
- etastart = cbind(theta2eta(lambda.init, .llambda, earg = .elambda),
- theta2eta(fv.init, .lmu, earg = .emu),
- theta2eta(sigma.init, .lsigma, earg = .esigma))
+ etastart =
+ cbind(theta2eta(lambda.init, .llambda, earg = .elambda),
+ theta2eta(fv.init, .lmu, earg = .emu),
+ theta2eta(sigma.init, .lsigma, earg = .esigma))
}
}), list( .llambda = llambda, .lmu = lmu, .lsigma = lsigma,
.elambda = elambda, .emu = emu, .esigma = esigma,
.dfmu.init = dfmu.init,
.dfsigma.init = dfsigma.init,
.ilambda = ilambda, .isigma = isigma ))),
- inverse = eval(substitute(function(eta, extra = NULL) {
+ linkinv = eval(substitute(function(eta, extra = NULL) {
eta[,1] = eta2theta(eta[,1], .llambda, earg = .elambda)
- eta[,2] = eta2theta(eta[,2], .lmu, earg = .emu)
- eta[,3] = eta2theta(eta[,3], .lsigma, earg = .esigma)
+ eta[,2] = eta2theta(eta[,2], .lmu, earg = .emu)
+ eta[,3] = eta2theta(eta[,3], .lsigma, earg = .esigma)
if ( .expectiles ) {
- explot.lms.bcn(percentiles= .percentiles, eta=eta)
+ explot.lms.bcn(percentiles= .percentiles, eta = eta)
} else {
- qtplot.lms.bcn(percentiles= .percentiles, eta=eta)
+ qtplot.lms.bcn(percentiles= .percentiles, eta = eta)
}
}, list( .llambda = llambda, .lmu = lmu, .lsigma = lsigma,
.elambda = elambda, .emu = emu, .esigma = esigma,
@@ -120,22 +122,22 @@ lms.yjn.control <- function(trace = TRUE, ...)
misc$expectiles = .expectiles
if (control$cdf) {
post$cdf = cdf.lms.bcn(y, eta0=matrix(c(lambda,mymu,sigma),
- ncol=3, dimnames=list(dimnames(x)[[1]], NULL)))
+ ncol=3, dimnames = list(dimnames(x)[[1]], NULL)))
}
}), list( .llambda = llambda, .lmu = lmu, .lsigma = lsigma,
.elambda = elambda, .emu = emu, .esigma = esigma,
.percentiles=percentiles, .expectiles = expectiles ))),
- loglikelihood=eval(substitute(
+ loglikelihood = eval(substitute(
function(mu,y, w, residuals= FALSE, eta, extra = NULL) {
lambda = eta2theta(eta[,1], .llambda, earg = .elambda)
- mu = eta2theta(eta[,2], .lmu, earg = .emu)
+ muvec = eta2theta(eta[,2], .lmu, earg = .emu)
sigma = eta2theta(eta[,3], .lsigma, earg = .esigma)
- zedd = ((y/mu)^lambda - 1) / (lambda * sigma)
+ zedd = ((y/muvec)^lambda - 1) / (lambda * sigma)
if (residuals) stop("loglikelihood residuals not ",
"implemented") else {
- use.this = (lambda * log(y / mu) - log(sigma) - log(y) +
+ use.this = (lambda * log(y / muvec) - log(sigma) - log(y) +
dnorm(zedd, log = TRUE))
- use.this[abs(lambda) < 0.001] = (-log(y / mu) - log(sigma) +
+ use.this[abs(lambda) < 0.001] = (-log(y / muvec) - log(sigma) +
dnorm(zedd, log = TRUE))[abs(lambda) < 0.001]
sum(w * use.this)
}
@@ -180,11 +182,11 @@ lms.yjn.control <- function(trace = TRUE, ...)
llambda = "identity",
lmu = "identity",
lsigma = "loge",
- elambda = list(), emu=list(), esigma = list(),
+ elambda = list(), emu = list(), esigma = list(),
dfmu.init=4,
- dfsigma.init=2,
- ilambda=1,
- isigma=NULL)
+ dfsigma.init = 2,
+ ilambda = 1,
+ isigma = NULL)
{
if (mode(llambda) != "character" && mode(llambda) != "name")
llambda = as.character(substitute(llambda))
@@ -196,30 +198,30 @@ lms.yjn.control <- function(trace = TRUE, ...)
if (!is.list(emu)) emu = list()
if (!is.list(esigma)) esigma = list()
if (!is.Numeric(ilambda))
- stop("bad input for argument 'ilambda'")
- if (length(isigma) && !is.Numeric(isigma, posit=TRUE))
- stop("bad input for argument 'isigma'")
+ stop("bad input for argument 'ilambda'")
+ if (length(isigma) && !is.Numeric(isigma, posit = TRUE))
+ stop("bad input for argument 'isigma'")
new("vglmff",
blurb = c("LMS Quantile Regression ",
"(Box-Cox transformation to a Gamma distribution)\n",
"Links: ",
- namesof("lambda", link=llambda, earg = elambda), ", ",
- namesof("mu", link=lmu, earg = emu), ", ",
- namesof("sigma", link=lsigma, earg = esigma)),
- constraints=eval(substitute(expression({
+ namesof("lambda", link = llambda, earg = elambda), ", ",
+ namesof("mu", link = lmu, earg = emu), ", ",
+ namesof("sigma", link = lsigma, earg = esigma)),
+ constraints = eval(substitute(expression({
constraints = cm.zero.vgam(constraints, x, .zero, M)
}), list(.zero=zero))),
- initialize=eval(substitute(expression({
+ initialize = eval(substitute(expression({
if (ncol(cbind(y)) != 1)
- stop("response must be a vector or a one-column matrix")
+ stop("response must be a vector or a one-column matrix")
if (any(y<0, na.rm = TRUE))
- stop("negative responses not allowed")
+ stop("negative responses not allowed")
predictors.names = c(
- namesof("lambda", .llambda, earg = .elambda, short=TRUE),
- namesof("mu", .lmu, earg = .emu, short=TRUE),
- namesof("sigma", .lsigma, earg = .esigma, short=TRUE))
+ namesof("lambda", .llambda, earg = .elambda, short = TRUE),
+ namesof("mu", .lmu, earg = .emu, short = TRUE),
+ namesof("sigma", .lsigma, earg = .esigma, short = TRUE))
if (!length(etastart)) {
@@ -240,20 +242,21 @@ lms.yjn.control <- function(trace = TRUE, ...)
sqrt(var(myratio))
} else .isigma
- etastart = cbind(theta2eta(lambda.init, .llambda, earg = .elambda),
- theta2eta(fv.init, .lmu, earg = .emu),
- theta2eta(sigma.init, .lsigma, earg = .esigma))
+ etastart =
+ cbind(theta2eta(lambda.init, .llambda, earg = .elambda),
+ theta2eta(fv.init, .lmu, earg = .emu),
+ theta2eta(sigma.init, .lsigma, earg = .esigma))
}
}), list( .llambda = llambda, .lmu = lmu, .lsigma = lsigma,
.elambda = elambda, .emu = emu, .esigma = esigma,
.dfmu.init = dfmu.init,
.dfsigma.init = dfsigma.init,
.ilambda = ilambda, .isigma = isigma ))),
- inverse = eval(substitute(function(eta, extra = NULL) {
+ linkinv = eval(substitute(function(eta, extra = NULL) {
eta[,1] = eta2theta(eta[,1], .llambda, earg = .elambda)
- eta[,2] = eta2theta(eta[,2], .lmu, earg = .emu)
- eta[,3] = eta2theta(eta[,3], .lsigma, earg = .esigma)
- qtplot.lms.bcg(percentiles= .percentiles, eta=eta)
+ eta[,2] = eta2theta(eta[,2], .lmu, earg = .emu)
+ eta[,3] = eta2theta(eta[,3], .lsigma, earg = .esigma)
+ qtplot.lms.bcg(percentiles= .percentiles, eta = eta)
}, list( .llambda = llambda, .lmu = lmu, .lsigma = lsigma,
.elambda = elambda, .emu = emu, .esigma = esigma,
.percentiles=percentiles ))),
@@ -264,12 +267,12 @@ lms.yjn.control <- function(trace = TRUE, ...)
misc$true.mu = FALSE # $fitted is not a true mu
if (control$cdf) {
post$cdf = cdf.lms.bcg(y, eta0=matrix(c(lambda,mymu,sigma),
- ncol=3, dimnames=list(dimnames(x)[[1]], NULL)))
+ ncol=3, dimnames = list(dimnames(x)[[1]], NULL)))
}
}), list( .llambda = llambda, .lmu = lmu, .lsigma = lsigma,
.elambda = elambda, .emu = emu, .esigma = esigma,
.percentiles=percentiles ))),
- loglikelihood=eval(substitute(
+ loglikelihood = eval(substitute(
function(mu,y, w, residuals= FALSE, eta, extra = NULL) {
lambda = eta2theta(eta[,1], .llambda, earg = .elambda)
mu = eta2theta(eta[,2], .lmu, earg = .emu)
@@ -285,8 +288,8 @@ lms.yjn.control <- function(trace = TRUE, ...)
vfamily = c("lms.bcg", "lmscreg"),
deriv = eval(substitute(expression({
lambda = eta2theta(eta[,1], .llambda, earg = .elambda)
- mymu = eta2theta(eta[,2], .lmu, earg = .emu)
- sigma = eta2theta(eta[,3], .lsigma, earg = .esigma)
+ mymu = eta2theta(eta[,2], .lmu, earg = .emu)
+ sigma = eta2theta(eta[,3], .lsigma, earg = .esigma)
Gee = (y / mymu)^lambda
theta = 1 / (sigma * lambda)^2
@@ -348,22 +351,22 @@ dyj.dy.yeojohnson = function(y, lambda) {
ifelse(y>0, (1 + y)^(lambda - 1), (1 - y)^(1 - lambda))
}
- yeo.johnson = function(y, lambda, derivative=0,
- epsilon=sqrt(.Machine$double.eps), inverse= FALSE)
+ yeo.johnson = function(y, lambda, derivative = 0,
+ epsilon = sqrt(.Machine$double.eps), inverse= FALSE)
{
- if (!is.Numeric(derivative, allow=1, integ=TRUE) || derivative<0)
- stop("'derivative' must be a non-negative integer")
+ if (!is.Numeric(derivative, allow = 1, integ = TRUE) || derivative<0)
+ stop("argument 'derivative' must be a non-negative integer")
ans = y
- if (!is.Numeric(epsilon, allow=1, posit=TRUE))
- stop("'epsilon' must be a single positive number")
+ if (!is.Numeric(epsilon, allow = 1, posit = TRUE))
+ stop("argument 'epsilon' must be a single positive number")
L = max(length(lambda), length(y))
if (length(y) != L) y = rep(y, len=L)
if (length(lambda) != L) lambda = rep(lambda, len=L) # lambda may be of length 1
if (inverse) {
- if (derivative!=0)
- stop("derivative must 0 when inverse=TRUE")
+ if (derivative != 0)
+ stop("argument 'derivative' must 0 when inverse = TRUE")
if (any(index <- y >= 0 & abs(lambda) > epsilon))
ans[index] = (y[index]*lambda[index] + 1)^(1/lambda[index]) - 1
if (any(index <- y >= 0 & abs(lambda) <= epsilon))
@@ -374,7 +377,7 @@ dyj.dy.yeojohnson = function(y, lambda) {
ans[index] = -expm1(-y[index])
return(ans)
}
- if (derivative==0) {
+ if (derivative == 0) {
if (any(index <- y >= 0 & abs(lambda) > epsilon))
ans[index] = ((y[index]+1)^(lambda[index]) - 1) / lambda[index]
if (any(index <- y >= 0 & abs(lambda) <= epsilon))
@@ -404,12 +407,12 @@ dyj.dy.yeojohnson = function(y, lambda) {
dpsi.dlambda.yjn = function(psi, lambda, mymu, sigma,
- derivative=0, smallno=1.0e-8) {
+ derivative = 0, smallno=1.0e-8) {
- if (!is.Numeric(derivative, allow=1, integ=TRUE) || derivative<0)
- stop("'derivative' must be a non-negative integer")
- if (!is.Numeric(smallno, allow=1, posit=TRUE))
- stop("'smallno' must be a single positive number")
+ if (!is.Numeric(derivative, allow = 1, integ = TRUE) || derivative<0)
+ stop("argument 'derivative' must be a non-negative integer")
+ if (!is.Numeric(smallno, allow = 1, posit = TRUE))
+ stop("argument 'smallno' must be a single positive number")
L = max(length(psi), length(lambda), length(mymu), length(sigma))
if (length(psi) != L) psi = rep(psi, len=L)
@@ -433,11 +436,11 @@ dpsi.dlambda.yjn = function(psi, lambda, mymu, sigma,
pos = (CC & abs(lambda) <= smallno) | (!CC & abs(lambda-2) <= smallno)
if (any(pos))
- answer[pos,1+derivative] = (answer[pos,1]^(1+derivative))/(derivative+1)
+ answer[pos,1+derivative] = (answer[pos,1]^(1+derivative))/(derivative+1)
answer
}
-gh.weight.yjn.11 = function(z, lambda, mymu, sigma, derivmat=NULL) {
+gh.weight.yjn.11 = function(z, lambda, mymu, sigma, derivmat = NULL) {
if (length(derivmat)) {
@@ -446,116 +449,117 @@ gh.weight.yjn.11 = function(z, lambda, mymu, sigma, derivmat=NULL) {
# Long-winded way
psi = mymu + sqrt(2) * sigma * z
(1 / sqrt(pi)) *
- (dpsi.dlambda.yjn(psi, lambda, mymu, sigma, derivative=1)[,2]^2 +
+ (dpsi.dlambda.yjn(psi, lambda, mymu, sigma, derivative = 1)[,2]^2 +
(psi - mymu) *
- dpsi.dlambda.yjn(psi, lambda, mymu, sigma, derivative=2)[,3]) / sigma^2
+ dpsi.dlambda.yjn(psi, lambda, mymu, sigma, derivative = 2)[,3]) / sigma^2
}
}
-gh.weight.yjn.12 = function(z, lambda, mymu, sigma, derivmat=NULL) {
+gh.weight.yjn.12 = function(z, lambda, mymu, sigma, derivmat = NULL) {
if (length(derivmat)) {
(-derivmat[,2]) / (sqrt(pi) * sigma^2)
} else {
psi = mymu + sqrt(2) * sigma * z
- (1 / sqrt(pi)) *
- (- dpsi.dlambda.yjn(psi, lambda, mymu, sigma, derivative=1)[,2]) / sigma^2
+ (1 / sqrt(pi)) * (- dpsi.dlambda.yjn(psi, lambda, mymu, sigma,
+ derivative = 1)[,2]) / sigma^2
}
}
-gh.weight.yjn.13 = function(z, lambda, mymu, sigma, derivmat=NULL) {
+gh.weight.yjn.13 = function(z, lambda, mymu, sigma, derivmat = NULL) {
if (length(derivmat)) {
sqrt(8 / pi) * (-derivmat[,2]) * z / sigma^2
} else {
psi = mymu + sqrt(2) * sigma * z
(1 / sqrt(pi)) *
- (-2 * dpsi.dlambda.yjn(psi, lambda, mymu, sigma, derivative=1)[,2]) *
+ (-2 * dpsi.dlambda.yjn(psi, lambda, mymu, sigma, derivative = 1)[,2]) *
(psi - mymu) / sigma^3
}
}
-glag.weight.yjn.11 = function(z, lambda, mymu, sigma, derivmat=NULL) {
+glag.weight.yjn.11 = function(z, lambda, mymu, sigma, derivmat = NULL) {
- if (length(derivmat)) {
- derivmat[,4] * (derivmat[,2]^2 + sqrt(2) * sigma * z * derivmat[,3])
- } else {
- psi = mymu + sqrt(2) * sigma * z
- discontinuity = -mymu / (sqrt(2) * sigma)
- (1 / (2 * sqrt((z-discontinuity^2)^2 + discontinuity^2))) *
- (1 / sqrt(pi)) *
- (dpsi.dlambda.yjn(psi, lambda, mymu, sigma, derivative=1)[,2]^2 +
- (psi - mymu) *
- dpsi.dlambda.yjn(psi, lambda, mymu, sigma, derivative=2)[,3]) / sigma^2
- }
+ if (length(derivmat)) {
+ derivmat[,4] * (derivmat[,2]^2 + sqrt(2) * sigma * z * derivmat[,3])
+ } else {
+ psi = mymu + sqrt(2) * sigma * z
+ discontinuity = -mymu / (sqrt(2) * sigma)
+ (1 / (2 * sqrt((z-discontinuity^2)^2 + discontinuity^2))) *
+ (1 / sqrt(pi)) *
+ (dpsi.dlambda.yjn(psi, lambda, mymu, sigma, derivative = 1)[,2]^2 +
+ (psi - mymu) *
+ dpsi.dlambda.yjn(psi, lambda, mymu, sigma, derivative = 2)[,3]) / sigma^2
+ }
}
-glag.weight.yjn.12 = function(z, lambda, mymu, sigma, derivmat=NULL) {
- discontinuity = -mymu / (sqrt(2) * sigma)
- if (length(derivmat)) {
- derivmat[,4] * (-derivmat[,2])
- } else {
- psi = mymu + sqrt(2) * sigma * z
- (1 / (2 * sqrt((z-discontinuity^2)^2 + discontinuity^2))) *
- (1 / sqrt(pi)) *
- (- dpsi.dlambda.yjn(psi, lambda, mymu, sigma, derivative=1)[,2]) / sigma^2
- }
+glag.weight.yjn.12 = function(z, lambda, mymu, sigma, derivmat = NULL) {
+ discontinuity = -mymu / (sqrt(2) * sigma)
+ if (length(derivmat)) {
+ derivmat[,4] * (-derivmat[,2])
+ } else {
+ psi = mymu + sqrt(2) * sigma * z
+ (1 / (2 * sqrt((z-discontinuity^2)^2 + discontinuity^2))) *
+ (1 / sqrt(pi)) *
+ (- dpsi.dlambda.yjn(psi, lambda, mymu, sigma, derivative = 1)[,2]) / sigma^2
+ }
}
-glag.weight.yjn.13 = function(z, lambda, mymu, sigma, derivmat=NULL) {
- if (length(derivmat)) {
- derivmat[,4] * (-derivmat[,2]) * sqrt(8) * z
- } else {
- psi = mymu + sqrt(2) * sigma * z
- discontinuity = -mymu / (sqrt(2) * sigma)
- (1 / (2 * sqrt((z-discontinuity^2)^2 + discontinuity^2))) *
- (1 / sqrt(pi)) *
- (-2 * dpsi.dlambda.yjn(psi, lambda, mymu, sigma, derivative=1)[,2]) *
- (psi - mymu) / sigma^3
- }
+glag.weight.yjn.13 = function(z, lambda, mymu, sigma, derivmat = NULL) {
+ if (length(derivmat)) {
+ derivmat[,4] * (-derivmat[,2]) * sqrt(8) * z
+ } else {
+ psi = mymu + sqrt(2) * sigma * z
+ discontinuity = -mymu / (sqrt(2) * sigma)
+ (1 / (2 * sqrt((z-discontinuity^2)^2 + discontinuity^2))) *
+ (1 / sqrt(pi)) *
+ (-2 * dpsi.dlambda.yjn(psi, lambda, mymu, sigma, derivative = 1)[,2]) *
+ (psi - mymu) / sigma^3
+ }
}
-gleg.weight.yjn.11 = function(z, lambda, mymu, sigma, derivmat=NULL) {
+gleg.weight.yjn.11 = function(z, lambda, mymu, sigma, derivmat = NULL) {
- if (length(derivmat)) {
- derivmat[,4] * (derivmat[,2]^2 + sqrt(2) * sigma * z * derivmat[,3])
- } else {
- psi = mymu + sqrt(2) * sigma * z
- (exp(-z^2) / sqrt(pi)) *
- (dpsi.dlambda.yjn(psi, lambda, mymu, sigma, derivative=1)[,2]^2 +
- (psi - mymu) *
- dpsi.dlambda.yjn(psi, lambda, mymu, sigma, derivative=2)[,3]) / sigma^2
- }
+ if (length(derivmat)) {
+ derivmat[,4] * (derivmat[,2]^2 + sqrt(2) * sigma * z * derivmat[,3])
+ } else {
+ psi = mymu + sqrt(2) * sigma * z
+ (exp(-z^2) / sqrt(pi)) *
+ (dpsi.dlambda.yjn(psi, lambda, mymu, sigma, derivative = 1)[,2]^2 +
+ (psi - mymu) *
+ dpsi.dlambda.yjn(psi, lambda, mymu, sigma, derivative = 2)[,3]) / sigma^2
+ }
}
-gleg.weight.yjn.12 = function(z, lambda, mymu, sigma, derivmat=NULL) {
- if (length(derivmat)) {
- derivmat[,4] * (- derivmat[,2])
- } else {
- psi = mymu + sqrt(2) * sigma * z
- (exp(-z^2) / sqrt(pi)) *
- (- dpsi.dlambda.yjn(psi, lambda, mymu, sigma, derivative=1)[,2]) / sigma^2
- }
+gleg.weight.yjn.12 = function(z, lambda, mymu, sigma, derivmat = NULL) {
+ if (length(derivmat)) {
+ derivmat[,4] * (- derivmat[,2])
+ } else {
+ psi = mymu + sqrt(2) * sigma * z
+ (exp(-z^2) / sqrt(pi)) *
+ (- dpsi.dlambda.yjn(psi, lambda, mymu, sigma,
+ derivative = 1)[,2]) / sigma^2
+ }
}
-gleg.weight.yjn.13 = function(z, lambda, mymu, sigma, derivmat=NULL) {
- if (length(derivmat)) {
- derivmat[,4] * (-derivmat[,2]) * sqrt(8) * z
- } else {
- psi = mymu + sqrt(2) * sigma * z
- (exp(-z^2) / sqrt(pi)) *
- (-2 * dpsi.dlambda.yjn(psi, lambda, mymu, sigma, derivative=1)[,2]) *
- (psi - mymu) / sigma^3
- }
+gleg.weight.yjn.13 = function(z, lambda, mymu, sigma, derivmat = NULL) {
+ if (length(derivmat)) {
+ derivmat[,4] * (-derivmat[,2]) * sqrt(8) * z
+ } else {
+ psi = mymu + sqrt(2) * sigma * z
+ (exp(-z^2) / sqrt(pi)) *
+ (-2 * dpsi.dlambda.yjn(psi, lambda, mymu, sigma, derivative = 1)[,2]) *
+ (psi - mymu) / sigma^3
+ }
}
-lms.yjn2.control <- function(save.weight=TRUE, ...)
+lms.yjn2.control <- function(save.weight = TRUE, ...)
{
list(save.weight=save.weight)
}
@@ -565,13 +569,13 @@ lms.yjn2.control <- function(save.weight=TRUE, ...)
llambda = "identity",
lmu = "identity",
lsigma = "loge",
- elambda = list(), emu=list(), esigma = list(),
+ elambda = list(), emu = list(), esigma = list(),
dfmu.init=4,
- dfsigma.init=2,
+ dfsigma.init = 2,
ilambda=1.0,
- isigma=NULL,
- yoffset=NULL,
- nsimEIM=250)
+ isigma = NULL,
+ yoffset = NULL,
+ nsimEIM = 250)
{
if (mode(llambda) != "character" && mode(llambda) != "name")
@@ -584,29 +588,29 @@ lms.yjn2.control <- function(save.weight=TRUE, ...)
if (!is.list(emu)) emu = list()
if (!is.list(esigma)) esigma = list()
if (!is.Numeric(ilambda))
- stop("bad input for argument 'ilambda'")
- if (length(isigma) && !is.Numeric(isigma, posit=TRUE))
- stop("bad input for argument 'isigma'")
+ stop("bad input for argument 'ilambda'")
+ if (length(isigma) && !is.Numeric(isigma, posit = TRUE))
+ stop("bad input for argument 'isigma'")
new("vglmff",
blurb = c("LMS Quantile Regression (Yeo-Johnson transformation",
" to normality)\n",
"Links: ",
- namesof("lambda", link=llambda, earg = elambda),
+ namesof("lambda", link = llambda, earg = elambda),
", ",
- namesof("mu", link=lmu, earg = emu),
+ namesof("mu", link = lmu, earg = emu),
", ",
- namesof("sigma", link=lsigma, earg = esigma)),
- constraints=eval(substitute(expression({
+ namesof("sigma", link = lsigma, earg = esigma)),
+ constraints = eval(substitute(expression({
constraints = cm.zero.vgam(constraints, x, .zero, M)
}), list(.zero=zero))),
- initialize=eval(substitute(expression({
+ initialize = eval(substitute(expression({
if (ncol(cbind(y)) != 1)
- stop("response must be a vector or a one-column matrix")
- predictors.names =
- c(namesof("lambda", .llambda, earg = .elambda, short= TRUE),
- namesof("mu", .lmu, earg = .emu, short= TRUE),
- namesof("sigma", .lsigma, earg = .esigma, short= TRUE))
+ stop("response must be a vector or a one-column matrix")
+ predictors.names =
+ c(namesof("lambda", .llambda, earg = .elambda, short= TRUE),
+ namesof("mu", .lmu, earg = .emu, short= TRUE),
+ namesof("sigma", .lsigma, earg = .esigma, short= TRUE))
y.save = y
yoff = if (is.Numeric( .yoffset)) .yoffset else -median(y)
@@ -623,7 +627,7 @@ lms.yjn2.control <- function(save.weight=TRUE, ...)
y=y.tx, w = w, df = .dfmu.init)
c(predict(fit700, x = x[, min(ncol(x), 2)])$y)
} else {
- rep(weighted.mean(y, w), len=n)
+ rep(weighted.mean(y, w), len = n)
}
sigma.init = if (!is.Numeric(.isigma)) {
@@ -641,8 +645,8 @@ lms.yjn2.control <- function(save.weight=TRUE, ...)
etastart = matrix(0, n, 3)
etastart[,1] = theta2eta(lambda.init, .llambda, earg = .elambda)
- etastart[,2] = theta2eta(fv.init, .lmu, earg = .emu)
- etastart[,3] = theta2eta(sigma.init, .lsigma, earg = .esigma)
+ etastart[,2] = theta2eta(fv.init, .lmu, earg = .emu)
+ etastart[,3] = theta2eta(sigma.init, .lsigma, earg = .esigma)
}
}), list(.llambda = llambda, .lmu = lmu, .lsigma = lsigma,
@@ -652,10 +656,10 @@ lms.yjn2.control <- function(save.weight=TRUE, ...)
.ilambda = ilambda,
.yoffset=yoffset,
.isigma = isigma))),
- inverse = eval(substitute(function(eta, extra = NULL) {
+ linkinv = eval(substitute(function(eta, extra = NULL) {
eta[,1] = eta2theta(eta[,1], .llambda, earg = .elambda)
eta[,3] = eta2theta(eta[,3], .lsigma, earg = .esigma)
- qtplot.lms.yjn(percentiles= .percentiles, eta=eta, yoffset= extra$yoff)
+ qtplot.lms.yjn(percentiles= .percentiles, eta = eta, yoffset= extra$yoff)
}, list(.percentiles=percentiles,
.esigma = esigma, .elambda = elambda,
.llambda = llambda,
@@ -674,13 +678,13 @@ lms.yjn2.control <- function(save.weight=TRUE, ...)
if (control$cdf) {
post$cdf = cdf.lms.yjn(y + misc$yoffset,
eta0=matrix(c(lambda,mymu,sigma),
- ncol=3, dimnames=list(dimnames(x)[[1]], NULL)))
+ ncol=3, dimnames = list(dimnames(x)[[1]], NULL)))
}
}), list(.percentiles=percentiles,
.elambda = elambda, .emu = emu, .esigma = esigma,
.nsimEIM=nsimEIM,
.llambda = llambda, .lmu = lmu, .lsigma = lsigma ))),
- loglikelihood=eval(substitute(
+ loglikelihood = eval(substitute(
function(mu,y, w, residuals= FALSE, eta, extra = NULL) {
lambda = eta2theta(eta[,1], .llambda, earg = .elambda)
mu = eta2theta(eta[,2], .lmu, earg = .emu)
@@ -703,7 +707,7 @@ lms.yjn2.control <- function(save.weight=TRUE, ...)
dsigma.deta = dtheta.deta(sigma, link = .lsigma, earg = .esigma)
psi = yeo.johnson(y, lambda)
- d1 = yeo.johnson(y, lambda, deriv=1)
+ d1 = yeo.johnson(y, lambda, deriv = 1)
AA = (psi - mymu) / sigma
dl.dlambda = -AA * d1 /sigma + sign(y) * log1p(abs(y))
dl.dmu = AA / sigma
@@ -721,7 +725,7 @@ lms.yjn2.control <- function(save.weight=TRUE, ...)
for(ii in 1:( .nsimEIM )) {
psi = rnorm(n, mymu, sigma)
ysim = yeo.johnson(y=psi, lam=lambda, inv = TRUE)
- d1 = yeo.johnson(ysim, lambda, deriv=1)
+ d1 = yeo.johnson(ysim, lambda, deriv = 1)
AA = (psi - mymu) / sigma
dl.dlambda = -AA * d1 /sigma + sign(ysim) * log1p(abs(ysim))
dl.dmu = AA / sigma
@@ -753,12 +757,12 @@ lms.yjn2.control <- function(save.weight=TRUE, ...)
lsigma = "loge",
elambda = list(), esigma = list(),
dfmu.init=4,
- dfsigma.init=2,
+ dfsigma.init = 2,
ilambda=1.0,
- isigma=NULL,
+ isigma = NULL,
rule = c(10,5),
- yoffset=NULL,
- diagW=FALSE, iters.diagW=6)
+ yoffset = NULL,
+ diagW = FALSE, iters.diagW=6)
{
@@ -772,21 +776,21 @@ lms.yjn2.control <- function(save.weight=TRUE, ...)
rule = rule[1] # Number of points (common) for all the quadrature schemes
if (rule != 5 && rule != 10)
- stop("only rule=5 or 10 is supported")
+ stop("only rule=5 or 10 is supported")
new("vglmff",
blurb = c("LMS Quantile Regression ",
"(Yeo-Johnson transformation to normality)\n",
"Links: ",
- namesof("lambda", link=llambda, earg = elambda),
+ namesof("lambda", link = llambda, earg = elambda),
", mu, ",
- namesof("sigma", link=lsigma, earg = esigma)),
- constraints=eval(substitute(expression({
+ namesof("sigma", link = lsigma, earg = esigma)),
+ constraints = eval(substitute(expression({
constraints = cm.zero.vgam(constraints, x, .zero, M)
}), list(.zero=zero))),
- initialize=eval(substitute(expression({
+ initialize = eval(substitute(expression({
if (ncol(cbind(y)) != 1)
- stop("response must be a vector or a one-column matrix")
+ stop("response must be a vector or a one-column matrix")
predictors.names =
c(namesof("lambda", .llambda, earg = .elambda, short= TRUE),
"mu",
@@ -807,7 +811,7 @@ lms.yjn2.control <- function(save.weight=TRUE, ...)
y = y.tx, w = w, df = .dfmu.init)
fv.init = c(predict(fit700, x = x[, min(ncol(x), 2)])$y)
} else {
- fv.init = rep(weighted.mean(y, w), len=n)
+ fv.init = rep(weighted.mean(y, w), len = n)
}
sigma.init = if (!is.Numeric(.isigma)) {
@@ -823,9 +827,10 @@ lms.yjn2.control <- function(save.weight=TRUE, ...)
} else
.isigma
- etastart = cbind(theta2eta(lambda.init,.llambda, earg = .elambda),
- fv.init,
- theta2eta(sigma.init, .lsigma, earg = .esigma))
+ etastart =
+ cbind(theta2eta(lambda.init,.llambda, earg = .elambda),
+ fv.init,
+ theta2eta(sigma.init, .lsigma, earg = .esigma))
}
}), list(.lsigma = lsigma,
@@ -836,10 +841,10 @@ lms.yjn2.control <- function(save.weight=TRUE, ...)
.ilambda = ilambda,
.yoffset=yoffset,
.isigma = isigma))),
- inverse = eval(substitute(function(eta, extra = NULL) {
+ linkinv = eval(substitute(function(eta, extra = NULL) {
eta[,1] = eta2theta(eta[,1], .llambda, earg = .elambda)
eta[,3] = eta2theta(eta[,3], .lsigma, earg = .esigma)
- qtplot.lms.yjn(percentiles= .percentiles, eta=eta, yoffset= extra$yoff)
+ qtplot.lms.yjn(percentiles= .percentiles, eta = eta, yoffset= extra$yoff)
}, list(.percentiles=percentiles,
.esigma = esigma, .elambda = elambda,
.llambda = llambda,
@@ -856,13 +861,13 @@ lms.yjn2.control <- function(save.weight=TRUE, ...)
if (control$cdf) {
post$cdf = cdf.lms.yjn(y + misc$yoffset,
eta0=matrix(c(lambda,mymu,sigma),
- ncol=3, dimnames=list(dimnames(x)[[1]], NULL)))
+ ncol=3, dimnames = list(dimnames(x)[[1]], NULL)))
}
}), list(.percentiles=percentiles,
.esigma = esigma, .elambda = elambda,
.llambda = llambda,
.lsigma = lsigma))),
- loglikelihood=eval(substitute(
+ loglikelihood = eval(substitute(
function(mu,y, w, residuals= FALSE, eta, extra = NULL) {
lambda = eta2theta(eta[,1], .llambda, earg = .elambda)
mu = eta[,2]
@@ -881,7 +886,7 @@ lms.yjn2.control <- function(save.weight=TRUE, ...)
sigma = eta2theta(eta[,3], .lsigma, earg = .esigma)
psi = yeo.johnson(y, lambda)
- d1 = yeo.johnson(y, lambda, deriv=1)
+ d1 = yeo.johnson(y, lambda, deriv = 1)
AA = (psi - mymu) / sigma
dl.dlambda = -AA * d1 /sigma + sign(y) * log1p(abs(y))
@@ -960,7 +965,7 @@ lms.yjn2.control <- function(save.weight=TRUE, ...)
temp1 = AA * gleg.wts[kk]
abscissae = (UU+LL)/2 + AA * gleg.abs[kk]
psi = mymu + sqrt(2) * sigma * abscissae
- temp9 = dpsi.dlambda.yjn(psi, lambda, mymu, sigma, derivative=2)
+ temp9 = dpsi.dlambda.yjn(psi, lambda, mymu, sigma, derivative = 2)
temp9 = cbind(temp9, exp(-abscissae^2) / (sqrt(pi) * sigma^2))
wz[,iam(1,1,M)] = wz[,iam(1,1,M)] + temp1 *
@@ -988,7 +993,7 @@ lms.yjn2.control <- function(save.weight=TRUE, ...)
abscissae = sign(-discontinuity) * sgh.abs[kk]
psi = mymu + sqrt(2) * sigma * abscissae # abscissae = z
- temp9 = dpsi.dlambda.yjn(psi, lambda, mymu, sigma, derivative=2)
+ temp9 = dpsi.dlambda.yjn(psi, lambda, mymu, sigma, derivative = 2)
wz[,iam(1,1,M)] = wz[,iam(1,1,M)] + sgh.wts[kk] *
gh.weight.yjn.11(abscissae, lambda, mymu, sigma, temp9)
wz[,iam(1,2,M)] = wz[,iam(1,2,M)] + sgh.wts[kk] *
@@ -1001,7 +1006,7 @@ lms.yjn2.control <- function(save.weight=TRUE, ...)
for(kk in 1:length(glag.wts)) {
abscissae = sign(discontinuity) * sqrt(glag.abs[kk]) + discontinuity^2
psi = mymu + sqrt(2) * sigma * abscissae
- temp9 = dpsi.dlambda.yjn(psi, lambda, mymu, sigma, derivative=2)
+ temp9 = dpsi.dlambda.yjn(psi, lambda, mymu, sigma, derivative = 2)
temp9 = cbind(temp9,
1 / (2 * sqrt((abscissae-discontinuity^2)^2 + discontinuity^2) *
sqrt(pi) * sigma^2))
@@ -1034,7 +1039,7 @@ lms.yjn2.control <- function(save.weight=TRUE, ...)
-lmscreg.control <- function(cdf = TRUE, at.arg=NULL, x0=NULL, ...)
+lmscreg.control <- function(cdf = TRUE, at.arg = NULL, x0 = NULL, ...)
{
if (!is.logical(cdf)) {
@@ -1085,98 +1090,109 @@ amlnormal.deviance = function(mu, y, w, residuals = FALSE, eta, extra = NULL) {
{
- if (!is.Numeric(w.aml, posit=TRUE))
- stop("'w.aml' must be a vector of positive values")
- if (!is.Numeric(imethod, allow=1, integ=TRUE, posit=TRUE) ||
- imethod > 3) stop("argument 'imethod' must be 1, 2 or 3")
- if (mode(lexpectile) != "character" && mode(lexpectile) != "name")
- lexpectile = as.character(substitute(lexpectile))
- if (!is.list(eexpectile)) eexpectile = list()
- if (length(iexpectile) && !is.Numeric(iexpectile))
- stop("bad input for argument 'iexpectile'")
+ if (!is.Numeric(w.aml, posit = TRUE))
+ stop("argument 'w.aml' must be a vector of positive values")
+ if (!is.Numeric(imethod, allow = 1, integ = TRUE, posit = TRUE) ||
+ imethod > 3)
+ stop("argument 'imethod' must be 1, 2 or 3")
- new("vglmff",
- blurb = c("Asymmetric least squares quantile regression\n\n",
- "Links: ",
- namesof("expectile", link=lexpectile, earg = eexpectile)),
- constraints=eval(substitute(expression({
- constraints = cm.vgam(matrix(1,M,1), x, .parallel, constraints)
- }), list( .parallel=parallel ))),
- deviance= function(mu, y, w, residuals = FALSE, eta, extra = NULL) {
- amlnormal.deviance(mu=mu, y = y, w = w, residuals=residuals,
- eta=eta, extra=extra)
- },
- initialize=eval(substitute(expression({
- extra$w.aml = .w.aml
- if (ncol(y <- cbind(y)) != 1)
- stop("response must be a vector or a one-column matrix")
- extra$M = M = length(extra$w.aml) # Recycle if necessary
- extra$n = n
- extra$y.names = y.names =
- paste("w.aml = ", round(extra$w.aml, dig = .digw), sep = "")
- predictors.names = c(namesof(
- paste("expectile(",y.names,")", sep = ""), .lexpectile,
- earg = .eexpectile, tag = FALSE))
+ if (mode(lexpectile) != "character" && mode(lexpectile) != "name")
+ lexpectile = as.character(substitute(lexpectile))
- if (!length(etastart)) {
- mean.init = if ( .imethod == 1)
- rep(median(y), length=n) else
- if ( .imethod == 2)
- rep(weighted.mean(y, w), length=n) else {
- junk = if (is.R()) lm.wfit(x=x, y = y, w=w) else
- lm.wfit(x=x, y = y, w = w, method = "qr")
- junk$fitted
- }
- if (length( .iexpectile))
- mean.init = matrix( .iexpectile, n, M, byrow = TRUE)
- etastart = matrix(theta2eta(mean.init, .lexpectile,
- earg = .eexpectile), n, M)
- }
- }), list( .lexpectile=lexpectile, .eexpectile=eexpectile,
- .iexpectile=iexpectile,
- .imethod = imethod, .digw = digw, .w.aml = w.aml ))),
- inverse = eval(substitute(function(eta, extra = NULL) {
- ans = eta = as.matrix(eta)
- for(ii in 1:ncol(eta))
- ans[,ii] = eta2theta(eta[,ii], .lexpectile, earg = .eexpectile)
- dimnames(ans) = list(dimnames(eta)[[1]], extra$y.names)
- ans
- }, list( .lexpectile=lexpectile, .eexpectile=eexpectile ))),
- last = eval(substitute(expression({
- misc$link = rep(.lexpectile, length = M)
- names(misc$link) = extra$y.names
- misc$earg = vector("list", M)
- names(misc$earg) = names(misc$link)
- misc$parallel = .parallel
- misc$expected = TRUE
- extra$percentile = numeric(M)
- for(ii in 1:M) {
- use.w = if (M > 1 && ncol(cbind(w)) == M) w[, ii] else w
- extra$percentile[ii] = 100 * weighted.mean(myresid[,ii] <= 0, use.w)
- }
- names(extra$percentile) = names(misc$link)
+ if (!is.list(eexpectile)) eexpectile = list()
- extra$individual = TRUE
- if (!(M > 1 && ncol(cbind(w)) == M)) {
- extra$deviance = amlnormal.deviance(mu=mu, y = y, w = w,
- residuals=FALSE, eta=eta, extra=extra)
- names(extra$deviance) = extra$y.names
- }
- }), list( .lexpectile=lexpectile, .eexpectile=eexpectile,
- .parallel=parallel ))),
- vfamily = c("amlnormal"),
- deriv = eval(substitute(expression({
- mymu = eta2theta(eta, .lexpectile, earg = .eexpectile)
- dexpectile.deta = dtheta.deta(mymu, .lexpectile, earg = .eexpectile)
- myresid = matrix(y,extra$n,extra$M) - cbind(mu)
- wor1 = Wr2(myresid, w= matrix(extra$w.aml, extra$n, extra$M,
- byrow = TRUE))
- w * myresid * wor1 * dexpectile.deta
- }), list( .lexpectile=lexpectile, .eexpectile=eexpectile ))),
- weight = eval(substitute(expression({
- wz = w * wor1 * dexpectile.deta^2
- wz
- }), list( .lexpectile=lexpectile, .eexpectile=eexpectile ))))
+ if (length(iexpectile) && !is.Numeric(iexpectile))
+ stop("bad input for argument 'iexpectile'")
+
+ new("vglmff",
+ blurb = c("Asymmetric least squares quantile regression\n\n",
+ "Links: ",
+ namesof("expectile", link = lexpectile, earg = eexpectile)),
+ constraints = eval(substitute(expression({
+ constraints = cm.vgam(matrix(1,M,1), x, .parallel, constraints)
+ }), list( .parallel = parallel ))),
+ deviance = function(mu, y, w, residuals = FALSE, eta, extra = NULL) {
+ amlnormal.deviance(mu = mu, y = y, w = w, residuals = residuals,
+ eta = eta, extra = extra)
+ },
+ initialize = eval(substitute(expression({
+ extra$w.aml = .w.aml
+ if (ncol(y <- cbind(y)) != 1)
+ stop("response must be a vector or a one-column matrix")
+
+ extra$M = M = length(extra$w.aml) # Recycle if necessary
+ extra$n = n
+ extra$y.names = y.names =
+ paste("w.aml = ", round(extra$w.aml, dig = .digw), sep = "")
+
+ predictors.names = c(namesof(
+ paste("expectile(",y.names,")", sep = ""), .lexpectile,
+ earg = .eexpectile, tag = FALSE))
+
+ if (!length(etastart)) {
+ mean.init = if ( .imethod == 1)
+ rep(median(y), length = n) else
+ if ( .imethod == 2)
+ rep(weighted.mean(y, w), length = n) else {
+ junk = lm.wfit(x = x, y = y, w = w)
+ junk$fitted
+ }
+ if (length( .iexpectile))
+ mean.init = matrix( .iexpectile, n, M, byrow = TRUE)
+ etastart =
+ matrix(theta2eta(mean.init, .lexpectile,
+ earg = .eexpectile), n, M)
+ }
+ }), list( .lexpectile = lexpectile, .eexpectile = eexpectile,
+ .iexpectile = iexpectile,
+ .imethod = imethod, .digw = digw, .w.aml = w.aml ))),
+ linkinv = eval(substitute(function(eta, extra = NULL) {
+ ans = eta = as.matrix(eta)
+ for(ii in 1:ncol(eta))
+ ans[,ii] = eta2theta(eta[,ii], .lexpectile, earg = .eexpectile)
+ dimnames(ans) = list(dimnames(eta)[[1]], extra$y.names)
+ ans
+ }, list( .lexpectile = lexpectile, .eexpectile = eexpectile ))),
+ last = eval(substitute(expression({
+ misc$link = rep(.lexpectile, length = M)
+ names(misc$link) = extra$y.names
+ misc$earg = vector("list", M)
+ names(misc$earg) = names(misc$link)
+
+ misc$parallel = .parallel
+ misc$expected = TRUE
+ extra$percentile = numeric(M)
+
+ for(ii in 1:M) {
+ use.w = if (M > 1 && ncol(cbind(w)) == M) w[, ii] else w
+ extra$percentile[ii] = 100 *
+ weighted.mean(myresid[,ii] <= 0, use.w)
+ }
+ names(extra$percentile) = names(misc$link)
+
+ extra$individual = TRUE
+ if (!(M > 1 && ncol(cbind(w)) == M)) {
+ extra$deviance = amlnormal.deviance(mu = mu, y = y, w = w,
+ residuals = FALSE, eta = eta, extra = extra)
+ names(extra$deviance) = extra$y.names
+ }
+ }), list( .lexpectile = lexpectile,
+ .eexpectile = eexpectile, .parallel = parallel ))),
+ vfamily = c("amlnormal"),
+ deriv = eval(substitute(expression({
+ mymu = eta2theta(eta, .lexpectile, earg = .eexpectile)
+ dexpectile.deta = dtheta.deta(mymu, .lexpectile, earg = .eexpectile)
+ myresid = matrix(y,extra$n,extra$M) - cbind(mu)
+ wor1 = Wr2(myresid, w = matrix(extra$w.aml, extra$n, extra$M,
+ byrow = TRUE))
+ c(w) * myresid * wor1 * dexpectile.deta
+ }), list( .lexpectile = lexpectile,
+ .eexpectile = eexpectile ))),
+ weight = eval(substitute(expression({
+ wz = c(w) * wor1 * dexpectile.deta^2
+ wz
+ }), list( .lexpectile = lexpectile,
+ .eexpectile = eexpectile ))))
}
@@ -1215,7 +1231,7 @@ amlpoisson.deviance = function(mu, y, w, residuals = FALSE, eta, extra = NULL) {
amlpoisson <- function(w.aml = 1, parallel = FALSE, imethod = 1,
digw = 4, link = "loge", earg = list())
{
- if (!is.Numeric(w.aml, posit=TRUE))
+ if (!is.Numeric(w.aml, posit = TRUE))
stop("'w.aml' must be a vector of positive values")
if (mode(link)!= "character" && mode(link)!= "name")
link = as.character(substitute(link))
@@ -1225,14 +1241,14 @@ amlpoisson.deviance = function(mu, y, w, residuals = FALSE, eta, extra = NULL) {
blurb = c("Poisson expectile regression by",
" asymmetric maximum likelihood estimation\n\n",
"Link: ", namesof("expectile", link, earg = earg)),
- constraints=eval(substitute(expression({
+ constraints = eval(substitute(expression({
constraints = cm.vgam(matrix(1,M,1), x, .parallel, constraints)
- }), list( .parallel=parallel ))),
- deviance= function(mu, y, w, residuals = FALSE, eta, extra = NULL) {
- amlpoisson.deviance(mu=mu, y = y, w = w, residuals=residuals,
- eta=eta, extra=extra)
+ }), list( .parallel = parallel ))),
+ deviance = function(mu, y, w, residuals = FALSE, eta, extra = NULL) {
+ amlpoisson.deviance(mu = mu, y = y, w = w, residuals = residuals,
+ eta = eta, extra = extra)
},
- initialize=eval(substitute(expression({
+ initialize = eval(substitute(expression({
extra$w.aml = .w.aml
if (ncol(y <- cbind(y)) != 1)
stop("response must be a vector or a one-column matrix")
@@ -1246,18 +1262,18 @@ amlpoisson.deviance = function(mu, y, w, residuals = FALSE, eta, extra = NULL) {
if (!length(etastart)) {
mean.init = if ( .imethod == 2)
- rep(median(y), length=n) else
+ rep(median(y), length = n) else
if ( .imethod == 1)
- rep(weighted.mean(y, w), length=n) else {
- junk = if (is.R()) lm.wfit(x=x, y = y, w=w) else
- lm.wfit(x=x, y = y, w = w, method = "qr")
+ rep(weighted.mean(y, w), length = n) else {
+ junk = lm.wfit(x = x, y = y, w = w)
abs(junk$fitted)
}
- etastart = matrix(theta2eta(mean.init, .link, earg = .earg), n, M)
+ etastart =
+ matrix(theta2eta(mean.init, .link, earg = .earg), n, M)
}
}), list( .link = link, .earg = earg, .imethod = imethod,
.digw = digw, .w.aml = w.aml ))),
- inverse = eval(substitute(function(eta, extra = NULL) {
+ linkinv = eval(substitute(function(eta, extra = NULL) {
mu.ans = eta = as.matrix(eta)
for(ii in 1:ncol(eta))
mu.ans[,ii] = eta2theta(eta[,ii], .link, earg = .earg)
@@ -1277,26 +1293,26 @@ amlpoisson.deviance = function(mu, y, w, residuals = FALSE, eta, extra = NULL) {
names(extra$percentile) = names(misc$link)
extra$individual = TRUE
- extra$deviance = amlpoisson.deviance(mu=mu, y = y, w = w,
- residuals=FALSE, eta=eta, extra=extra)
+ extra$deviance = amlpoisson.deviance(mu = mu, y = y, w = w,
+ residuals = FALSE, eta = eta, extra = extra)
names(extra$deviance) = extra$y.names
- }), list( .link = link, .earg = earg, .parallel=parallel ))),
- link=eval(substitute(function(mu, extra = NULL) {
- theta2eta(mu, link= .link, earg = .earg)
+ }), list( .link = link, .earg = earg, .parallel = parallel ))),
+ linkfun = eval(substitute(function(mu, extra = NULL) {
+ theta2eta(mu, link = .link, earg = .earg)
}, list( .link = link, .earg = earg ))),
vfamily = c("amlpoisson"),
deriv = eval(substitute(expression({
mymu = eta2theta(eta, .link, earg = .earg)
dexpectile.deta = dtheta.deta(mymu, .link, earg = .earg)
myresid = matrix(y,extra$n,extra$M) - cbind(mu)
- wor1 = Wr2(myresid, w= matrix(extra$w.aml, extra$n, extra$M,
+ wor1 = Wr2(myresid, w = matrix(extra$w.aml, extra$n, extra$M,
byrow = TRUE))
- w * myresid * wor1 * (dexpectile.deta / mymu)
+ c(w) * myresid * wor1 * (dexpectile.deta / mymu)
}), list( .link = link, .earg = earg ))),
weight = eval(substitute(expression({
use.mu = mymu
use.mu[use.mu < .Machine$double.eps^(3/4)] = .Machine$double.eps^(3/4)
- wz = w * wor1 * use.mu * (dexpectile.deta / mymu)^2
+ wz = c(w) * wor1 * use.mu * (dexpectile.deta / mymu)^2
wz
}), list( .link = link, .earg = earg ))))
}
@@ -1347,7 +1363,7 @@ amlbinomial.deviance = function(mu, y, w, residuals = FALSE, eta, extra = NULL)
link = "logit", earg = list())
{
- if (!is.Numeric(w.aml, posit=TRUE))
+ if (!is.Numeric(w.aml, posit = TRUE))
stop("'w.aml' must be a vector of positive values")
if (mode(link)!= "character" && mode(link)!= "name")
link = as.character(substitute(link))
@@ -1357,14 +1373,14 @@ amlbinomial.deviance = function(mu, y, w, residuals = FALSE, eta, extra = NULL)
blurb = c("Logistic expectile regression by ",
"asymmetric maximum likelihood estimation\n\n",
"Link: ", namesof("expectile", link, earg = earg)),
- constraints=eval(substitute(expression({
+ constraints = eval(substitute(expression({
constraints = cm.vgam(matrix(1,M,1), x, .parallel, constraints)
- }), list( .parallel=parallel ))),
- deviance= function(mu, y, w, residuals = FALSE, eta, extra = NULL) {
- amlbinomial.deviance(mu=mu, y = y, w = w, residuals=residuals,
- eta=eta, extra=extra)
+ }), list( .parallel = parallel ))),
+ deviance = function(mu, y, w, residuals = FALSE, eta, extra = NULL) {
+ amlbinomial.deviance(mu = mu, y = y, w = w, residuals = residuals,
+ eta = eta, extra = extra)
},
- initialize=eval(substitute(expression({
+ initialize = eval(substitute(expression({
{
@@ -1414,7 +1430,7 @@ amlbinomial.deviance = function(mu, y, w, residuals = FALSE, eta, extra = NULL)
}), list( .link = link, .earg = earg,
.digw = digw, .w.aml = w.aml ))),
- inverse = eval(substitute(function(eta, extra = NULL) {
+ linkinv = eval(substitute(function(eta, extra = NULL) {
mu.ans = eta = as.matrix(eta)
for(ii in 1:ncol(eta))
mu.ans[,ii] = eta2theta(eta[,ii], .link, earg = .earg)
@@ -1434,27 +1450,27 @@ amlbinomial.deviance = function(mu, y, w, residuals = FALSE, eta, extra = NULL)
names(extra$percentile) = names(misc$link)
extra$individual = TRUE
- extra$deviance = amlbinomial.deviance(mu=mu, y = y, w = w,
- residuals=FALSE, eta=eta, extra=extra)
+ extra$deviance = amlbinomial.deviance(mu = mu, y = y, w = w,
+ residuals = FALSE, eta = eta, extra = extra)
names(extra$deviance) = extra$y.names
- }), list( .link = link, .earg = earg, .parallel=parallel ))),
- link=eval(substitute(function(mu, extra = NULL) {
- theta2eta(mu, link= .link, earg = .earg)
+ }), list( .link = link, .earg = earg, .parallel = parallel ))),
+ linkfun = eval(substitute(function(mu, extra = NULL) {
+ theta2eta(mu, link = .link, earg = .earg)
}, list( .link = link, .earg = earg ))),
vfamily = c("amlbinomial"),
deriv = eval(substitute(expression({
- mymu = eta2theta(eta, .link, earg = .earg)
- use.mu = mymu
- use.mu[use.mu < .Machine$double.eps^(3/4)] = .Machine$double.eps^(3/4)
- dexpectile.deta = dtheta.deta(use.mu, .link, earg = .earg)
- myresid = matrix(y,extra$n,extra$M) - cbind(mu)
- wor1 = Wr2(myresid, w= matrix(extra$w.aml, extra$n, extra$M,
- byrow = TRUE))
- w * myresid * wor1 * (dexpectile.deta / (use.mu * (1-use.mu)))
+ mymu = eta2theta(eta, .link, earg = .earg)
+ use.mu = mymu
+ use.mu[use.mu < .Machine$double.eps^(3/4)] = .Machine$double.eps^(3/4)
+ dexpectile.deta = dtheta.deta(use.mu, .link, earg = .earg)
+ myresid = matrix(y,extra$n,extra$M) - cbind(mu)
+ wor1 = Wr2(myresid, w = matrix(extra$w.aml, extra$n, extra$M,
+ byrow = TRUE))
+ c(w) * myresid * wor1 * (dexpectile.deta / (use.mu * (1-use.mu)))
}), list( .link = link, .earg = earg ))),
weight = eval(substitute(expression({
- wz = w * wor1 * (dexpectile.deta^2 / (use.mu * (1 - use.mu)))
- wz
+ wz = c(w) * wor1 * (dexpectile.deta^2 / (use.mu * (1 - use.mu)))
+ wz
}), list( .link = link, .earg = earg ))))
}
@@ -1494,12 +1510,12 @@ amlexponential.deviance = function(mu, y, w, residuals = FALSE, eta, extra = NUL
amlexponential <- function(w.aml = 1, parallel = FALSE, imethod = 1,
digw = 4, link = "loge", earg = list())
{
- if (!is.Numeric(w.aml, posit=TRUE))
+ if (!is.Numeric(w.aml, posit = TRUE))
stop("'w.aml' must be a vector of positive values")
if (mode(link)!= "character" && mode(link)!= "name")
link = as.character(substitute(link))
if (!is.list(earg)) earg = list()
- if (!is.Numeric(imethod, allow=1, integ=TRUE, posit=TRUE) ||
+ if (!is.Numeric(imethod, allow = 1, integ = TRUE, posit = TRUE) ||
imethod > 3) stop("argument 'imethod' must be 1, 2 or 3")
y.names = paste("w.aml = ", round(w.aml, dig=digw), sep = "")
@@ -1511,14 +1527,14 @@ amlexponential.deviance = function(mu, y, w, residuals = FALSE, eta, extra = NUL
blurb = c("Exponential expectile regression by",
" asymmetric maximum likelihood estimation\n\n",
"Link: ", predictors.names),
- constraints=eval(substitute(expression({
+ constraints = eval(substitute(expression({
constraints = cm.vgam(matrix(1,M,1), x, .parallel, constraints)
- }), list( .parallel=parallel ))),
- deviance= function(mu, y, w, residuals = FALSE, eta, extra = NULL) {
- amlexponential.deviance(mu=mu, y = y, w = w, residuals=residuals,
- eta=eta, extra=extra)
+ }), list( .parallel = parallel ))),
+ deviance = function(mu, y, w, residuals = FALSE, eta, extra = NULL) {
+ amlexponential.deviance(mu = mu, y = y, w = w, residuals = residuals,
+ eta = eta, extra = extra)
},
- initialize=eval(substitute(expression({
+ initialize = eval(substitute(expression({
extra$w.aml = .w.aml
if (ncol(y <- cbind(y)) != 1)
stop("response must be a vector or a one-column matrix")
@@ -1534,9 +1550,9 @@ amlexponential.deviance = function(mu, y, w, residuals = FALSE, eta, extra = NUL
if (!length(etastart)) {
mean.init = if ( .imethod == 1)
- rep(median(y), length=n) else
+ rep(median(y), length = n) else
if ( .imethod == 2)
- rep(weighted.mean(y, w), length=n) else {
+ rep(weighted.mean(y, w), length = n) else {
1 / (y + 1)
}
etastart = matrix(theta2eta(mean.init, .link, earg = .earg),
@@ -1544,7 +1560,7 @@ amlexponential.deviance = function(mu, y, w, residuals = FALSE, eta, extra = NUL
}
}), list( .link = link, .earg = earg, .imethod = imethod,
.digw = digw, .w.aml = w.aml ))),
- inverse = eval(substitute(function(eta, extra = NULL) {
+ linkinv = eval(substitute(function(eta, extra = NULL) {
mu.ans = eta = as.matrix(eta)
for(ii in 1:ncol(eta))
mu.ans[,ii] = eta2theta(eta[,ii], .link, earg = .earg)
@@ -1560,16 +1576,16 @@ amlexponential.deviance = function(mu, y, w, residuals = FALSE, eta, extra = NUL
misc$expected = TRUE
extra$percentile = numeric(M)
for(ii in 1:M)
- extra$percentile[ii] = 100 * weighted.mean(myresid[,ii] <= 0, w)
+ extra$percentile[ii] = 100 * weighted.mean(myresid[,ii] <= 0, w)
names(extra$percentile) = names(misc$link)
extra$individual = TRUE
- extra$deviance = amlexponential.deviance(mu=mu, y = y, w = w,
- residuals=FALSE, eta=eta, extra=extra)
+ extra$deviance = amlexponential.deviance(mu = mu, y = y, w = w,
+ residuals = FALSE, eta = eta, extra = extra)
names(extra$deviance) = extra$y.names
- }), list( .link = link, .earg = earg, .parallel=parallel ))),
- link=eval(substitute(function(mu, extra = NULL) {
- theta2eta(mu, link= .link, earg = .earg)
+ }), list( .link = link, .earg = earg, .parallel = parallel ))),
+ linkfun = eval(substitute(function(mu, extra = NULL) {
+ theta2eta(mu, link = .link, earg = .earg)
}, list( .link = link, .earg = earg ))),
vfamily = c("amlexponential"),
deriv = eval(substitute(expression({
@@ -1578,7 +1594,7 @@ amlexponential.deviance = function(mu, y, w, residuals = FALSE, eta, extra = NUL
dl.dmu = (bigy - mymu) / mymu^2
dmu.deta = dtheta.deta(mymu, .link, earg = .earg)
myresid = bigy - cbind(mymu)
- wor1 = Wr2(myresid, w= matrix(extra$w.aml, extra$n, extra$M,
+ wor1 = Wr2(myresid, w = matrix(extra$w.aml, extra$n, extra$M,
byrow = TRUE))
w * wor1 * dl.dmu * dmu.deta
}), list( .link = link, .earg = earg ))),
@@ -1594,18 +1610,18 @@ amlexponential.deviance = function(mu, y, w, residuals = FALSE, eta, extra = NUL
-rho1check = function(u, tau=0.5)
+rho1check = function(u, tau = 0.5)
u * (tau - (u <= 0))
-dalap = function(x, location=0, scale=1, tau=0.5,
- kappa=sqrt(tau/(1-tau)), log=FALSE) {
+dalap = function(x, location = 0, scale = 1, tau = 0.5,
+ kappa = sqrt(tau/(1-tau)), log = FALSE) {
if (!is.logical(log.arg <- log)) stop("bad input for argument 'log'")
rm(log)
NN = max(length(x), length(location), length(scale), length(kappa))
- location = rep(location, len=NN); scale= rep(scale, len=NN)
- kappa = rep(kappa, len=NN); x = rep(x, len=NN)
- tau = rep(tau, len=NN)
+ location = rep(location, len = NN); scale= rep(scale, len = NN)
+ kappa = rep(kappa, len = NN); x = rep(x, len = NN)
+ tau = rep(tau, len = NN)
logconst = 0.5 * log(2) - log(scale) + log(kappa) - log1p(kappa^2)
exponent = -(sqrt(2) / scale) * abs(x - location) *
@@ -1618,10 +1634,10 @@ dalap = function(x, location=0, scale=1, tau=0.5,
}
-ralap = function(n, location=0, scale=1, tau=0.5,
- kappa=sqrt(tau/(1-tau))) {
+ralap = function(n, location = 0, scale = 1, tau = 0.5,
+ kappa = sqrt(tau/(1-tau))) {
use.n = if ((length.n <- length(n)) > 1) length.n else
- if (!is.Numeric(n, integ=TRUE, allow=1, posit=TRUE))
+ if (!is.Numeric(n, integ = TRUE, allow = 1, posit = TRUE))
stop("bad input for argument 'n'") else n
location = rep(location, len=use.n); scale= rep(scale, len=use.n)
@@ -1634,11 +1650,12 @@ ralap = function(n, location=0, scale=1, tau=0.5,
}
-palap = function(q, location=0, scale=1, tau=0.5, kappa=sqrt(tau/(1-tau))) {
+palap = function(q, location = 0, scale = 1, tau = 0.5,
+ kappa = sqrt(tau/(1-tau))) {
NN = max(length(q), length(location), length(scale), length(kappa))
- location = rep(location, len=NN); scale= rep(scale, len=NN)
- kappa = rep(kappa, len=NN); q= rep(q, len=NN)
- tau = rep(tau, len=NN);
+ location = rep(location, len = NN); scale= rep(scale, len = NN)
+ kappa = rep(kappa, len = NN); q= rep(q, len = NN)
+ tau = rep(tau, len = NN);
exponent = -(sqrt(2) / scale) * abs(q - location) *
ifelse(q >= location, kappa, 1/kappa)
@@ -1653,11 +1670,12 @@ palap = function(q, location=0, scale=1, tau=0.5, kappa=sqrt(tau/(1-tau))) {
}
-qalap = function(p, location=0, scale=1, tau=0.5, kappa=sqrt(tau/(1-tau))) {
+qalap = function(p, location = 0, scale = 1, tau = 0.5,
+ kappa = sqrt(tau/(1-tau))) {
NN = max(length(p), length(location), length(scale), length(kappa))
- location = rep(location, len=NN); scale= rep(scale, len=NN)
- kappa = rep(kappa, len=NN); p = rep(p, len=NN)
- tau = rep(tau, len=NN)
+ location = rep(location, len = NN); scale= rep(scale, len = NN)
+ kappa = rep(kappa, len = NN); p = rep(p, len = NN)
+ tau = rep(tau, len = NN)
ans = p
temp5 = kappa^2 / (1 + kappa^2)
index1 = (p <= temp5)
@@ -1679,9 +1697,9 @@ qalap = function(p, location=0, scale=1, tau=0.5, kappa=sqrt(tau/(1-tau))) {
if (FALSE)
-dqregal = function(x, tau=0.5, location=0, scale=1) {
- if (!is.Numeric(scale, posit=TRUE)) stop("'scale' must be positive")
- if (!is.Numeric(tau, posit=TRUE) || max(tau) >= 1)
+dqregal = function(x, tau = 0.5, location = 0, scale = 1) {
+ if (!is.Numeric(scale, posit = TRUE)) stop("'scale' must be positive")
+ if (!is.Numeric(tau, posit = TRUE) || max(tau) >= 1)
stop("'tau' must have values in (0,1)")
const = tau * (1-tau) / scale
const * exp(-rho1check((x-location)/scale, tau=tau))
@@ -1690,13 +1708,13 @@ dqregal = function(x, tau=0.5, location=0, scale=1) {
if (FALSE)
-rqregal = function(n, tau=0.5, location=0, scale=1) {
- if (!is.Numeric(n, posit=TRUE, integ=TRUE, allow=1))
+rqregal = function(n, tau = 0.5, location = 0, scale = 1) {
+ if (!is.Numeric(n, posit = TRUE, integ = TRUE, allow = 1))
stop("bad input for argument 'n'")
- if (!is.Numeric(scale, posit=TRUE)) stop("'scale' must be positive")
- if (!is.Numeric(tau, posit=TRUE) || max(tau) >= 1)
+ if (!is.Numeric(scale, posit = TRUE)) stop("'scale' must be positive")
+ if (!is.Numeric(tau, posit = TRUE) || max(tau) >= 1)
stop("'tau' must have values in (0,1)")
- location = rep(location, len=n); scale= rep(scale, len=n)
+ location = rep(location, len = n); scale= rep(scale, len = n)
r = runif(n)
location - sign(r-tau) * scale * log(2*ifelse(r < tau, r, 1-r))
}
@@ -1704,19 +1722,19 @@ rqregal = function(n, tau=0.5, location=0, scale=1) {
if (FALSE)
-pqregal = function(q, tau=0.5, location=0, scale=1) {
+pqregal = function(q, tau = 0.5, location = 0, scale = 1) {
if (!all(scale == 1))
stop("currently can only handle scale == 1")
if (!is.Numeric(q))
stop("bad input for argument 'q'")
if (!is.Numeric(location))
stop("bad input for argument 'location'")
- if (!is.Numeric(scale, posit=TRUE)) stop("'scale' must be positive")
- if (!is.Numeric(tau, posit=TRUE) || max(tau) >= 1)
+ if (!is.Numeric(scale, posit = TRUE)) stop("'scale' must be positive")
+ if (!is.Numeric(tau, posit = TRUE) || max(tau) >= 1)
stop("'tau' must have values in (0,1)")
N = max(length(q), length(tau), length(location), length(scale))
- location = rep(location, len=N); scale= rep(scale, len=N)
- tau = rep(tau, len=N); q= rep(q, len=N)
+ location = rep(location, len = N); scale= rep(scale, len = N)
+ tau = rep(tau, len = N); q= rep(q, len = N)
ans = tau * exp(-(location - q) * (1 - tau))
index1 = (q > location)
ans[index1] = (1 - (1-tau) * exp(-tau * (q - location)))[index1]
@@ -1726,15 +1744,15 @@ pqregal = function(q, tau=0.5, location=0, scale=1) {
if (FALSE)
qregal = function(tau = c(0.25, 0.5, 0.75),
llocation = "identity",
- elocation=list(),
- lscale = "loge", escale=list(),
- ilocation=NULL,
- parallel=FALSE, imethod=1, digt = 4) {
+ elocation = list(),
+ lscale = "loge", escale = list(),
+ ilocation = NULL,
+ parallel = FALSE, imethod = 1, digt = 4) {
if (mode(llocation) != "character" && mode(llocation) != "name")
llocation = as.character(substitute(llocation))
- if (!is.Numeric(imethod, allow=1, integ=TRUE, posit=TRUE) ||
+ if (!is.Numeric(imethod, allow = 1, integ = TRUE, posit = TRUE) ||
imethod > 2) stop("argument 'imethod' must be 1 or 2")
- if (!is.Numeric(tau, posit=TRUE) || max(tau) >= 1)
+ if (!is.Numeric(tau, posit = TRUE) || max(tau) >= 1)
stop("bad input for argument 'tau'")
if (!is.list(elocation)) elocation = list()
if (mode(lscale) != "character" && mode(lscale) != "name")
@@ -1746,10 +1764,10 @@ qregal = function(tau = c(0.25, 0.5, 0.75),
"Links: ",
namesof("scale", lscale, earg =escale), ", ",
namesof("location", llocation, earg =elocation)),
- constraints=eval(substitute(expression({
+ constraints = eval(substitute(expression({
constraints = cm.vgam(matrix(1,M,1), x, .parallel, constraints)
- }), list( .parallel=parallel ))),
- initialize=eval(substitute(expression({
+ }), list( .parallel = parallel ))),
+ initialize = eval(substitute(expression({
extra$tau = .tau
if (ncol(y <- cbind(y)) != 1)
stop("response must be a vector or a one-column matrix")
@@ -1772,19 +1790,19 @@ qregal = function(tau = c(0.25, 0.5, 0.75),
locat.init = if (length(.ilocat)) {
matrix( .ilocat, n, M-1, byrow = TRUE)
} else {
- rep(locat.init, len=n)
+ rep(locat.init, len = n)
}
- scale.init = rep(1.0, len=n)
+ scale.init = rep(1.0, len = n)
etastart = cbind(
- theta2eta(scale.init, .lscale, earg = .escale),
- matrix(
- theta2eta(locat.init, .llocat, earg = .elocat), n, M-1))
+ theta2eta(scale.init, .lscale, earg = .escale),
+ matrix(
+ theta2eta(locat.init, .llocat, earg = .elocat), n, M-1))
}
}), list( .imethod = imethod, .tau = tau, .digt = digt,
.elocat = elocation, .escale = escale,
.llocat = llocation, .lscale = lscale,
.ilocat = ilocation ))),
- inverse = eval(substitute(function(eta, extra = NULL) {
+ linkinv = eval(substitute(function(eta, extra = NULL) {
eta = as.matrix(eta)
xi.ans = matrix(0, nrow(eta), ncol(eta)-1)
for(ii in 1:(ncol(eta)-1))
@@ -1810,7 +1828,7 @@ qregal = function(tau = c(0.25, 0.5, 0.75),
misc$tau = .tau
}), list( .elocat = elocation, .llocat = llocation, .tau = tau,
.escale = escale, .lscale = lscale ))),
- loglikelihood=eval(substitute(
+ loglikelihood = eval(substitute(
function(mu, y, w, residuals = FALSE,eta, extra = NULL) {
locmat = eta2theta(eta[, -1, drop = FALSE],
.llocat, earg = .elocat)
@@ -1841,7 +1859,7 @@ qregal = function(tau = c(0.25, 0.5, 0.75),
}), list( .tau = tau, .elocat = elocation, .llocat = llocation,
.escale = escale, .lscale = lscale ))),
weight = eval(substitute(expression({
- wz = matrix(0, nrow=n, M) # Diagonal
+ wz = matrix(0, nrow = n, M) # Diagonal
ed2l.dlocation2 = taumat * (1 - taumat) / scalemat^2
ed2l.dscale2 = 2 * (3*taumat^2 - 3*taumat+1) / (scalemat^2 *
taumat * (1-taumat))
@@ -1856,10 +1874,10 @@ qregal = function(tau = c(0.25, 0.5, 0.75),
-rloglap = function(n, location.ald=0, scale.ald=1, tau=0.5,
- kappa=sqrt(tau/(1-tau))) {
+rloglap = function(n, location.ald = 0, scale.ald = 1, tau = 0.5,
+ kappa = sqrt(tau/(1-tau))) {
use.n = if ((length.n <- length(n)) > 1) length.n else
- if (!is.Numeric(n, integ=TRUE, allow=1, posit=TRUE))
+ if (!is.Numeric(n, integ = TRUE, allow = 1, posit = TRUE))
stop("bad input for argument 'n'") else n
location.ald = rep(location.ald, len=use.n);
scale.ald= rep(scale.ald, len=use.n)
@@ -1873,15 +1891,15 @@ rloglap = function(n, location.ald=0, scale.ald=1, tau=0.5,
}
-dloglap = function(x, location.ald=0, scale.ald=1, tau=0.5,
- kappa=sqrt(tau/(1-tau)), log=FALSE) {
+dloglap = function(x, location.ald = 0, scale.ald = 1, tau = 0.5,
+ kappa = sqrt(tau/(1-tau)), log = FALSE) {
if (!is.logical(log.arg <- log)) stop("bad input for argument 'log'")
rm(log)
NN = max(length(x), length(location.ald), length(scale.ald), length(kappa))
- location = rep(location.ald, len=NN); scale= rep(scale.ald, len=NN)
- kappa = rep(kappa, len=NN); x = rep(x, len=NN)
- tau = rep(tau, len=NN)
+ location = rep(location.ald, len = NN); scale= rep(scale.ald, len = NN)
+ kappa = rep(kappa, len = NN); x = rep(x, len = NN)
+ tau = rep(tau, len = NN)
Alpha = sqrt(2) * kappa / scale.ald
Beta = sqrt(2) / (scale.ald * kappa)
@@ -1896,12 +1914,12 @@ dloglap = function(x, location.ald=0, scale.ald=1, tau=0.5,
}
-qloglap = function(p, location.ald=0, scale.ald=1,
- tau=0.5, kappa=sqrt(tau/(1-tau))) {
+qloglap = function(p, location.ald = 0, scale.ald = 1,
+ tau = 0.5, kappa = sqrt(tau/(1-tau))) {
NN = max(length(p), length(location.ald), length(scale.ald), length(kappa))
- location = rep(location.ald, len=NN); scale= rep(scale.ald, len=NN)
- kappa = rep(kappa, len=NN); p = rep(p, len=NN)
- tau = rep(tau, len=NN)
+ location = rep(location.ald, len = NN); scale= rep(scale.ald, len = NN)
+ kappa = rep(kappa, len = NN); p = rep(p, len = NN)
+ tau = rep(tau, len = NN)
Alpha = sqrt(2) * kappa / scale.ald
Beta = sqrt(2) / (scale.ald * kappa)
@@ -1922,12 +1940,12 @@ qloglap = function(p, location.ald=0, scale.ald=1,
-ploglap = function(q, location.ald=0, scale.ald=1,
- tau=0.5, kappa=sqrt(tau/(1-tau))) {
+ploglap = function(q, location.ald = 0, scale.ald = 1,
+ tau = 0.5, kappa = sqrt(tau/(1-tau))) {
NN = max(length(q), length(location.ald), length(scale.ald), length(kappa))
- location = rep(location.ald, len=NN); scale = rep(scale.ald, len=NN)
- kappa = rep(kappa, len=NN); q = rep(q, len=NN)
- tau = rep(tau, len=NN)
+ location = rep(location.ald, len = NN); scale = rep(scale.ald, len = NN)
+ kappa = rep(kappa, len = NN); q = rep(q, len = NN)
+ tau = rep(tau, len = NN)
Alpha = sqrt(2) * kappa / scale.ald
Beta = sqrt(2) / (scale.ald * kappa)
@@ -1947,26 +1965,26 @@ ploglap = function(q, location.ald=0, scale.ald=1,
-rlogitlap = function(n, location.ald=0, scale.ald=1, tau=0.5,
- kappa=sqrt(tau/(1-tau)), earg =list()) {
+rlogitlap = function(n, location.ald = 0, scale.ald = 1, tau = 0.5,
+ kappa = sqrt(tau/(1-tau)), earg = list()) {
logit(ralap(n=n, location=location.ald, scale=scale.ald,
- tau=tau, kappa=kappa), inverse=TRUE, earg = earg)
+ tau=tau, kappa=kappa), inverse = TRUE, earg = earg)
}
-dlogitlap = function(x, location.ald=0, scale.ald=1, tau=0.5,
- kappa=sqrt(tau/(1-tau)), log=FALSE, earg =list()) {
+dlogitlap = function(x, location.ald = 0, scale.ald = 1, tau = 0.5,
+ kappa = sqrt(tau/(1-tau)), log = FALSE, earg = list()) {
if (!is.logical(log.arg <- log)) stop("bad input for argument 'log'")
rm(log)
NN = max(length(x), length(location.ald), length(scale.ald), length(kappa))
- location = rep(location.ald, len=NN); scale= rep(scale.ald, len=NN)
- kappa = rep(kappa, len=NN); x = rep(x, len=NN)
- tau = rep(tau, len=NN)
+ location = rep(location.ald, len = NN); scale= rep(scale.ald, len = NN)
+ kappa = rep(kappa, len = NN); x = rep(x, len = NN)
+ tau = rep(tau, len = NN)
Alpha = sqrt(2) * kappa / scale.ald
Beta = sqrt(2) / (scale.ald * kappa)
- Delta = logit(location.ald, inverse=TRUE, earg = earg)
+ Delta = logit(location.ald, inverse = TRUE, earg = earg)
exponent = ifelse(x >= Delta, -Alpha, Beta) *
(logit(x, earg = earg) - location.ald)
@@ -1980,11 +1998,11 @@ dlogitlap = function(x, location.ald=0, scale.ald=1, tau=0.5,
}
-qlogitlap = function(p, location.ald=0, scale.ald=1,
- tau=0.5, kappa=sqrt(tau/(1-tau)), earg =list()) {
+qlogitlap = function(p, location.ald = 0, scale.ald = 1,
+ tau = 0.5, kappa = sqrt(tau/(1-tau)), earg = list()) {
qqq = qalap(p=p, location=location.ald, scale=scale.ald,
tau=tau, kappa=kappa)
- ans = logit(qqq, inverse=TRUE, earg = earg)
+ ans = logit(qqq, inverse = TRUE, earg = earg)
ans[(p < 0) | (p > 1)] = NaN
ans[p == 0] = 0
ans[p == 1] = 1
@@ -1993,18 +2011,18 @@ qlogitlap = function(p, location.ald=0, scale.ald=1,
-plogitlap = function(q, location.ald=0, scale.ald=1,
- tau=0.5, kappa=sqrt(tau/(1-tau)), earg =list()) {
+plogitlap = function(q, location.ald = 0, scale.ald = 1,
+ tau = 0.5, kappa = sqrt(tau/(1-tau)), earg = list()) {
NN = max(length(q), length(location.ald), length(scale.ald),
length(kappa))
- location.ald = rep(location.ald, len=NN); scale.ald= rep(scale.ald, len=NN)
- kappa = rep(kappa, len=NN); q= rep(q, len=NN)
- tau = rep(tau, len=NN);
+ location.ald = rep(location.ald, len = NN); scale.ald= rep(scale.ald, len = NN)
+ kappa = rep(kappa, len = NN); q= rep(q, len = NN)
+ tau = rep(tau, len = NN);
indexTF = (q > 0) & (q < 1)
qqq = logit(q[indexTF], earg = earg)
ans = q
- ans[indexTF] = palap(q=qqq, location=location.ald[indexTF],
+ ans[indexTF] = palap(q = qqq, location=location.ald[indexTF],
scale=scale.ald[indexTF],
tau=tau[indexTF], kappa=kappa[indexTF])
ans[q >= 1] = 1
@@ -2014,23 +2032,23 @@ plogitlap = function(q, location.ald=0, scale.ald=1,
-rprobitlap = function(n, location.ald=0, scale.ald=1, tau=0.5,
- kappa=sqrt(tau/(1-tau)), earg =list()) {
+rprobitlap = function(n, location.ald = 0, scale.ald = 1, tau = 0.5,
+ kappa = sqrt(tau/(1-tau)), earg = list()) {
probit(ralap(n=n, location=location.ald, scale=scale.ald,
- tau=tau, kappa=kappa), inverse=TRUE, earg = earg)
+ tau=tau, kappa=kappa), inverse = TRUE, earg = earg)
}
-dprobitlap = function(x, location.ald=0, scale.ald=1, tau=0.5,
- kappa=sqrt(tau/(1-tau)), log=FALSE,
- earg =list(), meth2=TRUE) {
+dprobitlap = function(x, location.ald = 0, scale.ald = 1, tau = 0.5,
+ kappa = sqrt(tau/(1-tau)), log = FALSE,
+ earg = list(), meth2 = TRUE) {
if (!is.logical(log.arg <- log)) stop("bad input for argument 'log'")
rm(log)
NN = max(length(x), length(location.ald), length(scale.ald), length(kappa))
- location.ald = rep(location.ald, len=NN); scale.ald= rep(scale.ald, len=NN)
- kappa = rep(kappa, len=NN); x = rep(x, len=NN)
- tau = rep(tau, len=NN)
+ location.ald = rep(location.ald, len = NN); scale.ald= rep(scale.ald, len = NN)
+ kappa = rep(kappa, len = NN); x = rep(x, len = NN)
+ tau = rep(tau, len = NN)
logdensity = x * NaN
index1 = (x > 0) & (x < 1)
@@ -2040,13 +2058,13 @@ dprobitlap = function(x, location.ald=0, scale.ald=1, tau=0.5,
use.x = probit(x[index1], earg = earg)
logdensity[index1] = dalap(x=use.x, location=location.ald[index1],
scale=scale.ald[index1], tau=tau[index1],
- kappa=kappa[index1], log=TRUE)
+ kappa=kappa[index1], log = TRUE)
} else {
Alpha = sqrt(2) * kappa / scale.ald
Beta = sqrt(2) / (scale.ald * kappa)
Delta = pnorm(location.ald)
use.x = qnorm(x) # qnorm(x[index1])
- log.dy.dw = dnorm(use.x, log=TRUE)
+ log.dy.dw = dnorm(use.x, log = TRUE)
exponent = ifelse(x >= Delta, -Alpha, Beta) * (use.x - location.ald) -
log.dy.dw
@@ -2059,7 +2077,7 @@ dprobitlap = function(x, location.ald=0, scale.ald=1, tau=0.5,
logdensity[x > 1 & indexTF] = -Inf
if (meth2) {
- dx.dy[index1] = probit(x[index1], earg = earg, inverse=FALSE, deriv=1)
+ dx.dy[index1] = probit(x[index1], earg = earg, inverse = FALSE, deriv = 1)
dx.dy[!index1] = 0
dx.dy[!indexTF] = NaN
if (log.arg) logdensity - log(abs(dx.dy)) else exp(logdensity) / abs(dx.dy)
@@ -2069,11 +2087,11 @@ dprobitlap = function(x, location.ald=0, scale.ald=1, tau=0.5,
}
-qprobitlap = function(p, location.ald=0, scale.ald=1,
- tau=0.5, kappa=sqrt(tau/(1-tau)), earg =list()) {
+qprobitlap = function(p, location.ald = 0, scale.ald = 1,
+ tau = 0.5, kappa = sqrt(tau/(1-tau)), earg = list()) {
qqq = qalap(p=p, location=location.ald, scale=scale.ald,
tau=tau, kappa=kappa)
- ans = probit(qqq, inverse=TRUE, earg = earg)
+ ans = probit(qqq, inverse = TRUE, earg = earg)
ans[(p < 0) | (p > 1)] = NaN
ans[p == 0] = 0
ans[p == 1] = 1
@@ -2082,18 +2100,18 @@ qprobitlap = function(p, location.ald=0, scale.ald=1,
-pprobitlap = function(q, location.ald=0, scale.ald=1,
- tau=0.5, kappa=sqrt(tau/(1-tau)), earg =list()) {
+pprobitlap = function(q, location.ald = 0, scale.ald = 1,
+ tau = 0.5, kappa = sqrt(tau/(1-tau)), earg = list()) {
NN = max(length(q), length(location.ald), length(scale.ald),
length(kappa))
- location.ald = rep(location.ald, len=NN); scale.ald= rep(scale.ald, len=NN)
- kappa = rep(kappa, len=NN); q= rep(q, len=NN)
- tau = rep(tau, len=NN);
+ location.ald = rep(location.ald, len = NN); scale.ald= rep(scale.ald, len = NN)
+ kappa = rep(kappa, len = NN); q= rep(q, len = NN)
+ tau = rep(tau, len = NN);
indexTF = (q > 0) & (q < 1)
qqq = probit(q[indexTF], earg = earg)
ans = q
- ans[indexTF] = palap(q=qqq, location=location.ald[indexTF],
+ ans[indexTF] = palap(q = qqq, location=location.ald[indexTF],
scale=scale.ald[indexTF],
tau=tau[indexTF], kappa=kappa[indexTF])
ans[q >= 1] = 1
@@ -2102,23 +2120,23 @@ pprobitlap = function(q, location.ald=0, scale.ald=1,
}
-rclogloglap = function(n, location.ald=0, scale.ald=1, tau=0.5,
- kappa=sqrt(tau/(1-tau)), earg =list()) {
+rclogloglap = function(n, location.ald = 0, scale.ald = 1, tau = 0.5,
+ kappa = sqrt(tau/(1-tau)), earg = list()) {
cloglog(ralap(n=n, location=location.ald, scale=scale.ald,
- tau=tau, kappa=kappa), inverse=TRUE, earg = earg)
+ tau=tau, kappa=kappa), inverse = TRUE, earg = earg)
}
-dclogloglap = function(x, location.ald=0, scale.ald=1, tau=0.5,
- kappa=sqrt(tau/(1-tau)), log=FALSE,
- earg =list(), meth2=TRUE) {
+dclogloglap = function(x, location.ald = 0, scale.ald = 1, tau = 0.5,
+ kappa = sqrt(tau/(1-tau)), log = FALSE,
+ earg = list(), meth2 = TRUE) {
if (!is.logical(log.arg <- log)) stop("bad input for argument 'log'")
rm(log)
NN = max(length(x), length(location.ald), length(scale.ald), length(kappa))
- location.ald = rep(location.ald, len=NN); scale.ald= rep(scale.ald, len=NN)
- kappa = rep(kappa, len=NN); x = rep(x, len=NN)
- tau = rep(tau, len=NN)
+ location.ald = rep(location.ald, len = NN); scale.ald= rep(scale.ald, len = NN)
+ kappa = rep(kappa, len = NN); x = rep(x, len = NN)
+ tau = rep(tau, len = NN)
logdensity = x * NaN
index1 = (x > 0) & (x < 1)
@@ -2128,12 +2146,12 @@ dclogloglap = function(x, location.ald=0, scale.ald=1, tau=0.5,
use.w = cloglog(x[index1], earg = earg)
logdensity[index1] = dalap(x=use.w, location=location.ald[index1],
scale=scale.ald[index1], tau=tau[index1],
- kappa=kappa[index1], log=TRUE)
+ kappa=kappa[index1], log = TRUE)
} else {
Alpha = sqrt(2) * kappa / scale.ald
Beta = sqrt(2) / (scale.ald * kappa)
- Delta = cloglog(location.ald, inverse=TRUE)
+ Delta = cloglog(location.ald, inverse = TRUE)
exponent = ifelse(x >= Delta, -(Alpha+1), Beta-1) * log(-log1p(-x)) +
ifelse(x >= Delta, Alpha, -Beta) * location.ald
@@ -2145,7 +2163,7 @@ dclogloglap = function(x, location.ald=0, scale.ald=1, tau=0.5,
logdensity[x > 1 & indexTF] = -Inf
if (meth2) {
- dx.dy[index1] = cloglog(x[index1], earg = earg, inverse=FALSE, deriv=1)
+ dx.dy[index1] = cloglog(x[index1], earg = earg, inverse = FALSE, deriv = 1)
dx.dy[!index1] = 0
dx.dy[!indexTF] = NaN
if (log.arg) logdensity - log(abs(dx.dy)) else
@@ -2156,11 +2174,11 @@ dclogloglap = function(x, location.ald=0, scale.ald=1, tau=0.5,
}
-qclogloglap = function(p, location.ald=0, scale.ald=1,
- tau=0.5, kappa=sqrt(tau/(1-tau)), earg =list()) {
+qclogloglap = function(p, location.ald = 0, scale.ald = 1,
+ tau = 0.5, kappa = sqrt(tau/(1-tau)), earg = list()) {
qqq = qalap(p=p, location=location.ald, scale=scale.ald,
tau=tau, kappa=kappa)
- ans = cloglog(qqq, inverse=TRUE, earg = earg)
+ ans = cloglog(qqq, inverse = TRUE, earg = earg)
ans[(p < 0) | (p > 1)] = NaN
ans[p == 0] = 0
ans[p == 1] = 1
@@ -2169,18 +2187,18 @@ qclogloglap = function(p, location.ald=0, scale.ald=1,
-pclogloglap = function(q, location.ald=0, scale.ald=1,
- tau=0.5, kappa=sqrt(tau/(1-tau)), earg =list()) {
+pclogloglap = function(q, location.ald = 0, scale.ald = 1,
+ tau = 0.5, kappa = sqrt(tau/(1-tau)), earg = list()) {
NN = max(length(q), length(location.ald), length(scale.ald),
length(kappa))
- location.ald = rep(location.ald, len=NN); scale.ald= rep(scale.ald, len=NN)
- kappa = rep(kappa, len=NN); q= rep(q, len=NN)
- tau = rep(tau, len=NN);
+ location.ald = rep(location.ald, len = NN); scale.ald= rep(scale.ald, len = NN)
+ kappa = rep(kappa, len = NN); q= rep(q, len = NN)
+ tau = rep(tau, len = NN);
indexTF = (q > 0) & (q < 1)
qqq = cloglog(q[indexTF], earg = earg)
ans = q
- ans[indexTF] = palap(q=qqq, location=location.ald[indexTF],
+ ans[indexTF] = palap(q = qqq, location=location.ald[indexTF],
scale=scale.ald[indexTF],
tau=tau[indexTF], kappa=kappa[indexTF])
ans[q >= 1] = 1
@@ -2405,7 +2423,7 @@ alaplace2.control <- function(maxit = 100, ...)
.elocat = elocat, .escale = escale,
.llocat = llocat, .lscale = lscale, .kappa = kappa,
.ilocat = ilocat, .iscale = iscale ))),
- inverse = eval(substitute(function(eta, extra = NULL) {
+ linkinv = eval(substitute(function(eta, extra = NULL) {
Mdiv2 = extra$Mdiv2
locat = eta2theta(eta[, 2 * (1:Mdiv2) - 1, drop = FALSE],
.llocat, earg = .elocat)
@@ -2683,7 +2701,8 @@ alaplace1.control <- function(maxit = 100, ...)
}
if ( .llocat == "loge") locat.init = abs(locat.init)
- etastart = cbind(theta2eta(locat.init, .llocat, earg = .elocat))
+ etastart =
+ cbind(theta2eta(locat.init, .llocat, earg = .elocat))
}
}
}), list( .imethod = imethod,
@@ -2692,7 +2711,7 @@ alaplace1.control <- function(maxit = 100, ...)
.elocat = elocation, .Scale.arg = Scale.arg,
.llocat = llocation, .kappa = kappa,
.ilocat = ilocation ))),
- inverse = eval(substitute(function(eta, extra = NULL) {
+ linkinv = eval(substitute(function(eta, extra = NULL) {
if ( .fittedMean ) {
kappamat = matrix(extra$kappa, extra$n, extra$M, byrow = TRUE)
location = eta2theta(eta, .llocat, earg = .elocat)
@@ -2860,7 +2879,7 @@ alaplace3.control <- function(maxit = 100, ...)
.elocat = elocation, .escale = escale, .ekappa = ekappa,
.llocat = llocation, .lscale = lscale, .lkappa = lkappa,
.ilocat = ilocation, .iscale = iscale, .ikappa = ikappa ))),
- inverse = eval(substitute(function(eta, extra = NULL) {
+ linkinv = eval(substitute(function(eta, extra = NULL) {
location = eta2theta(eta[,1], .llocat, earg = .elocat)
Scale = eta2theta(eta[,2], .lscale, earg = .escale)
kappa = eta2theta(eta[,3], .lkappa, earg = .ekappa)
@@ -2921,7 +2940,7 @@ alaplace3.control <- function(maxit = 100, ...)
d2l.dkappa2 = 1 / kappa^2 + 4 / (1+kappa^2)^2
d2l.dkappadloc = -sqrt(8) / ((1+kappa^2) * Scale)
d2l.dkappadscale = -(1-kappa^2) / ((1+kappa^2) * kappa * Scale)
- wz = matrix(0, nrow=n, dimm(M))
+ wz = matrix(0, nrow = n, dimm(M))
wz[,iam(1,1,M)] = d2l.dlocation2 * dlocation.deta^2
wz[,iam(2,2,M)] = d2l.dscale2 * dscale.deta^2
wz[,iam(3,3,M)] = d2l.dkappa2 * dkappa.deta^2
@@ -2938,7 +2957,7 @@ alaplace3.control <- function(maxit = 100, ...)
-dlaplace = function(x, location=0, scale=1, log = FALSE) {
+dlaplace = function(x, location = 0, scale = 1, log = FALSE) {
if (!is.logical(log.arg <- log))
stop("bad input for argument 'log'")
rm(log)
@@ -2947,7 +2966,7 @@ dlaplace = function(x, location=0, scale=1, log = FALSE) {
if (log.arg) logdensity else exp(logdensity)
}
-plaplace = function(q, location=0, scale=1) {
+plaplace = function(q, location = 0, scale = 1) {
if (!is.Numeric(scale, posit = TRUE))
stop("argument 'scale' must be positive")
zedd = (q-location) / scale
@@ -2956,7 +2975,7 @@ plaplace = function(q, location=0, scale=1) {
ifelse(q < location, 0.5*exp(zedd), 1-0.5*exp(-zedd))
}
-qlaplace = function(p, location=0, scale=1) {
+qlaplace = function(p, location = 0, scale = 1) {
if (!is.Numeric(scale, posit = TRUE))
stop("argument 'scale' must be positive")
L = max(length(p), length(location), length(scale))
@@ -2964,7 +2983,7 @@ qlaplace = function(p, location=0, scale=1) {
location - sign(p-0.5) * scale * log(2*ifelse(p < 0.5, p, 1-p))
}
-rlaplace = function(n, location=0, scale=1) {
+rlaplace = function(n, location = 0, scale = 1) {
if (!is.Numeric(n, posit = TRUE, integ = TRUE, allow = 1))
stop("bad input for argument 'n'")
if (!is.Numeric(scale, posit = TRUE)) stop("'scale' must be positive")
@@ -3031,7 +3050,7 @@ rlaplace = function(n, location=0, scale=1) {
.elocat = elocation, .escale = escale,
.llocat = llocation, .lscale = lscale,
.ilocat = ilocation, .iscale = iscale ))),
- inverse = eval(substitute(function(eta, extra = NULL) {
+ linkinv = eval(substitute(function(eta, extra = NULL) {
eta2theta(eta[,1], .llocat, earg = .elocat)
}, list( .elocat = elocation, .llocat = llocation ))),
last = eval(substitute(expression({
@@ -3067,7 +3086,7 @@ rlaplace = function(n, location=0, scale=1) {
.elocat = elocation, .llocat = llocation ))),
weight = eval(substitute(expression({
d2l.dlocation2 = d2l.dscale2 = 1 / Scale^2
- wz = matrix(0, nrow=n, ncol=M) # diagonal
+ wz = matrix(0, nrow = n, ncol=M) # diagonal
wz[,iam(1,1,M)] = d2l.dlocation2 * dlocation.deta^2
wz[,iam(2,2,M)] = d2l.dscale2 * dscale.deta^2
c(w) * wz
@@ -3083,7 +3102,7 @@ fff.control <- function(save.weight = TRUE, ...)
}
fff = function(link = "loge", earg = list(),
- idf1 = NULL, idf2 = NULL, nsimEIM = 100, # ncp=0,
+ idf1 = NULL, idf2 = NULL, nsimEIM = 100, # ncp = 0,
imethod = 1, zero = NULL) {
if (mode(link) != "character" && mode(link) != "name")
link = as.character(substitute(link))
@@ -3103,10 +3122,10 @@ fff.control <- function(save.weight = TRUE, ...)
namesof("df1", link, earg = earg), ", ",
namesof("df2", link, earg = earg),
"\n", "\n",
- "Mean: df2/(df2-2) provided df2>2 and ncp=0", "\n",
+ "Mean: df2/(df2-2) provided df2>2 and ncp = 0", "\n",
"Variance: ",
"2*df2^2*(df1+df2-2)/(df1*(df2-2)^2*(df2-4)) ",
- "provided df2>4 and ncp=0"),
+ "provided df2>4 and ncp = 0"),
constraints = eval(substitute(expression({
constraints = cm.zero.vgam(constraints, x, .zero, M)
}), list( .zero = zero ))),
@@ -3129,13 +3148,14 @@ fff.control <- function(save.weight = TRUE, ...)
}
df1.init = if (length( .idf1)) rep( .idf1, len = n) else
rep(df1.init, len = n)
- df2.init = if (length( .idf2)) rep( .idf2, len = n) else rep(1, len = n)
+ df2.init = if (length( .idf2)) rep( .idf2, len = n) else
+ rep(1, len = n)
etastart = cbind(theta2eta(df1.init, .link, earg = .earg),
theta2eta(df2.init, .link, earg = .earg))
}
}), list( .imethod = imethod, .idf1=idf1, .earg = earg,
.idf2=idf2, .link = link ))),
- inverse = eval(substitute(function(eta, extra = NULL) {
+ linkinv = eval(substitute(function(eta, extra = NULL) {
df2 = eta2theta(eta[,2], .link, earg = .earg)
ans = df2 * NA
ans[df2>2] = df2[df2>2] / (df2[df2>2]-2)
@@ -3261,7 +3281,7 @@ fff.control <- function(save.weight = TRUE, ...)
}
}), list( .lprob = lprob, .earg = earg, .N = N, .D = D,
.iprob = iprob ))),
- inverse = eval(substitute(function(eta, extra = NULL) {
+ linkinv = eval(substitute(function(eta, extra = NULL) {
eta2theta(eta, .lprob, earg = .earg)
}, list( .lprob = lprob, .earg = earg ))),
last = eval(substitute(expression({
@@ -3270,7 +3290,7 @@ fff.control <- function(save.weight = TRUE, ...)
misc$Dvector <- .D
misc$Nvector <- .N
}), list( .N = N, .D = D, .lprob = lprob, .earg = earg ))),
- link = eval(substitute(function(mu, extra = NULL) {
+ linkfun = eval(substitute(function(mu, extra = NULL) {
theta2eta(mu, .lprob, earg = .earg)
}, list( .lprob = lprob, .earg = earg ))),
loglikelihood = eval(substitute(
@@ -3318,7 +3338,7 @@ fff.control <- function(save.weight = TRUE, ...)
weight = eval(substitute(expression({
if (extra$Nunknown) {
tmp722 = tmp72^2
- tmp13 = 2*Dvec / prob^3
+ tmp13 = 2*Dvec / prob^3
d2l.dprob2 = tmp722 * (trigamma(1 + tmp12) +
trigamma(1 + Dvec/prob - w) -
trigamma(1 + tmp12 - w + yvec) -
@@ -3350,9 +3370,9 @@ dbenini = function(x, shape, y0, log = FALSE) {
rm(log)
N = max(length(x), length(shape), length(y0))
- x = rep(x, len=N); shape = rep(shape, len=N); y0 = rep(y0, len=N);
+ x = rep(x, len = N); shape = rep(shape, len = N); y0 = rep(y0, len = N);
- logdensity = rep(log(0), len=N)
+ logdensity = rep(log(0), len = N)
xok = (x > y0)
tempxok = log(x[xok]/y0[xok])
logdensity[xok] = log(2*shape[xok]) - shape[xok] * tempxok^2 +
@@ -3361,11 +3381,14 @@ dbenini = function(x, shape, y0, log = FALSE) {
}
pbenini = function(q, shape, y0) {
- if (!is.Numeric(q)) stop("bad input for argument 'q'")
- if (!is.Numeric(shape, posit = TRUE)) stop("bad input for argument 'shape'")
- if (!is.Numeric(y0, posit = TRUE)) stop("bad input for argument 'y0'")
+ if (!is.Numeric(q))
+ stop("bad input for argument 'q'")
+ if (!is.Numeric(shape, posit = TRUE))
+ stop("bad input for argument 'shape'")
+ if (!is.Numeric(y0, posit = TRUE))
+ stop("bad input for argument 'y0'")
N = max(length(q), length(shape), length(y0))
- q = rep(q, len=N); shape = rep(shape, len=N); y0 = rep(y0, len=N);
+ q = rep(q, len = N); shape = rep(shape, len = N); y0 = rep(y0, len = N);
ans = y0 * 0
ok = q > y0
ans[ok] = -expm1(-shape[ok] * (log(q[ok]/y0[ok]))^2)
@@ -3375,20 +3398,24 @@ pbenini = function(q, shape, y0) {
qbenini = function(p, shape, y0) {
if (!is.Numeric(p, posit = TRUE) || any(p >= 1))
stop("bad input for argument 'p'")
- if (!is.Numeric(shape, posit = TRUE)) stop("bad input for argument 'shape'")
- if (!is.Numeric(y0, posit = TRUE)) stop("bad input for argument 'y0'")
+ if (!is.Numeric(shape, posit = TRUE))
+ stop("bad input for argument 'shape'")
+ if (!is.Numeric(y0, posit = TRUE))
+ stop("bad input for argument 'y0'")
y0 * exp(sqrt(-log1p(-p) / shape))
}
rbenini = function(n, shape, y0) {
if (!is.Numeric(n, posit = TRUE, integ = TRUE, allow = 1))
stop("bad input for argument 'n'")
- if (!is.Numeric(shape, posit = TRUE)) stop("bad input for argument 'shape'")
- if (!is.Numeric(y0, posit = TRUE)) stop("bad input for argument 'y0'")
+ if (!is.Numeric(shape, posit = TRUE))
+ stop("bad input for argument 'shape'")
+ if (!is.Numeric(y0, posit = TRUE))
+ stop("bad input for argument 'y0'")
y0 * exp(sqrt(-log(runif(n)) / shape))
}
- benini = function(y0=stop("argument 'y0' must be specified"),
+ benini = function(y0 = stop("argument 'y0' must be specified"),
lshape = "loge", earg = list(),
ishape = NULL, imethod = 1) {
if (mode(lshape) != "character" && mode(lshape) != "name")
@@ -3410,7 +3437,8 @@ rbenini = function(n, shape, y0) {
predictors.names =
c(namesof("shape", .lshape, earg = .earg, tag = FALSE))
extra$y0 = .y0
- if (min(y) <= extra$y0) stop("argument 'y0' is too large")
+ if (min(y) <= extra$y0)
+ stop("argument 'y0' is too large")
if (!length(etastart)) {
probs = (1:3) / 4
qofy= quantile(rep(y, times=w), probs=probs) # fails if w != integer
@@ -3425,7 +3453,7 @@ rbenini = function(n, shape, y0) {
}
}), list( .imethod = imethod, .ishape=ishape, .lshape = lshape, .earg = earg,
.y0=y0 ))),
- inverse = eval(substitute(function(eta, extra = NULL) {
+ linkinv = eval(substitute(function(eta, extra = NULL) {
shape = eta2theta(eta, .lshape, earg = .earg)
temp = 1/(4*shape)
extra$y0 * exp(temp) *
@@ -3464,16 +3492,24 @@ rbenini = function(n, shape, y0) {
-dpolono = function(x, meanlog=0, sdlog = 1, bigx=Inf, ...) {
- if (!is.Numeric(x)) stop("bad input for argument 'x'")
- if (!is.Numeric(meanlog)) stop("bad input for argument 'meanlog'")
- if (!is.Numeric(sdlog, posit = TRUE)) stop("bad input for argument 'sdlog'")
- if (length(bigx) != 1)
- stop("bad input for argument 'bigx'")
- if (bigx < 10)
- warning("argument 'bigx' is probably too small")
+
+
+if (FALSE)
+dpolono = function(x, meanlog = 0, sdlog = 1, bigx = Inf, ...) {
+ if (!is.Numeric(x))
+ stop("bad input for argument 'x'")
+ if (!is.Numeric(meanlog))
+ stop("bad input for argument 'meanlog'")
+ if (!is.Numeric(sdlog, posit = TRUE))
+ stop("bad input for argument 'sdlog'")
+
+ if (length(bigx) != 1)
+ stop("bad input for argument 'bigx'")
+ if (bigx < 10)
+ warning("argument 'bigx' is probably too small")
+
N = max(length(x), length(meanlog), length(sdlog))
- x = rep(x, len=N); meanlog = rep(meanlog, len=N); sdlog = rep(sdlog, len=N)
+ x = rep(x, len = N); meanlog = rep(meanlog, len = N); sdlog = rep(sdlog, len = N)
ans = x * 0
integrand = function(t, x, meanlog, sdlog)
exp(t*x - exp(t) - 0.5*((t-meanlog)/sdlog)^2)
@@ -3485,7 +3521,7 @@ dpolono = function(x, meanlog=0, sdlog = 1, bigx=Inf, ...) {
1) / (2*x[ii]*(sdlog[ii])^2)
ans[ii] = temp * exp(-0.5*zedd^2)/(sqrt(2*pi)*sdlog[ii] * x[ii])
} else {
- temp = integrate(f=integrand, lower=-Inf, upper=Inf, x = x[ii],
+ temp = integrate(f=integrand, lower=-Inf, upper = Inf, x = x[ii],
meanlog=meanlog[ii], sdlog = sdlog[ii], ...)
if (temp$message == "OK") {
ans[ii] = temp$value / (sqrt(2*pi) * sdlog[ii] *
@@ -3501,7 +3537,53 @@ dpolono = function(x, meanlog=0, sdlog = 1, bigx=Inf, ...) {
}
-rpolono = function(n, meanlog=0, sdlog = 1) {
+
+
+ dpolono <- function (x, meanlog = 0, sdlog = 1, bigx = 170, ...) {
+ mapply(function(x, meanlog, sdlog, ...) {
+ if (abs(x) > floor(x)) { # zero prob for -ve or non-integer
+ 0
+ } else
+ if (x > bigx) {
+ z <- (log(x) - meanlog) / sdlog
+ (1 + (z^2 + log(x) - meanlog - 1) / (2 * x * sdlog^2)) *
+ exp(-0.5 * z^2) / (sqrt(2 * pi) * sdlog * x)
+ } else
+ integrate( function(t) exp(t * x - exp(t) -
+ 0.5 * ((t - meanlog) / sdlog)^2),
+ lower = -Inf, upper = Inf, ...)$value / (sqrt(2 * pi) *
+ sdlog * exp(lgamma(x + 1.0)))
+ }, x, meanlog, sdlog, ...)
+}
+
+
+
+
+ppolono <- function(q, meanlog = 0, sdlog = 1,
+ isOne = 1 - sqrt( .Machine$double.eps ), ...) {
+
+
+ .cumprob <- rep(0, length(q))
+ .cumprob[q == Inf] <- 1 # special case
+
+
+ q <- floor(q)
+ i <- -1
+ while (any(xActive <- ((.cumprob < isOne) & (q > i))))
+ .cumprob[xActive] <- .cumprob[xActive] +
+ dpolono(i <- (i+1), meanlog, sdlog, ...)
+ .cumprob
+}
+
+
+
+
+
+
+
+
+
+rpolono = function(n, meanlog = 0, sdlog = 1) {
lambda = rlnorm(n=n, meanlog=meanlog, sdlog = sdlog)
rpois(n=n, lambda=lambda)
}
@@ -3516,18 +3598,18 @@ rpolono = function(n, meanlog=0, sdlog = 1) {
-dtriangle = function(x, theta, lower=0, upper=1, log = FALSE) {
+dtriangle = function(x, theta, lower = 0, upper = 1, log = FALSE) {
if (!is.logical(log.arg <- log))
stop("bad input for argument 'log'")
rm(log)
N = max(length(x), length(theta), length(lower), length(upper))
- x = rep(x, len=N); lower = rep(lower, len=N); upper = rep(upper, len=N);
- theta = rep(theta, len=N)
+ x = rep(x, len = N); lower = rep(lower, len = N); upper = rep(upper, len = N);
+ theta = rep(theta, len = N)
denom1 = ((upper-lower)*(theta-lower))
denom2 = ((upper-lower)*(upper-theta))
- logdensity = rep(log(0), len=N)
+ logdensity = rep(log(0), len = N)
xok.neg = (lower < x) & (x <= theta)
xok.pos = (theta <= x) & (x < upper)
logdensity[xok.neg] = log(2 * (x[xok.neg]-lower[xok.neg]) / denom1[xok.neg])
@@ -3539,16 +3621,20 @@ dtriangle = function(x, theta, lower=0, upper=1, log = FALSE) {
}
-rtriangle = function(n, theta, lower=0, upper=1) {
- if (!is.Numeric(n, integ = TRUE,allow = 1)) stop("bad input for argument 'n'")
- if (!is.Numeric(theta)) stop("bad input for argument 'theta'")
- if (!is.Numeric(lower)) stop("bad input for argument 'lower'")
- if (!is.Numeric(upper)) stop("bad input for argument 'upper'")
+rtriangle = function(n, theta, lower = 0, upper = 1) {
+ if (!is.Numeric(n, integ = TRUE,allow = 1))
+ stop("bad input for argument 'n'")
+ if (!is.Numeric(theta))
+ stop("bad input for argument 'theta'")
+ if (!is.Numeric(lower))
+ stop("bad input for argument 'lower'")
+ if (!is.Numeric(upper))
+ stop("bad input for argument 'upper'")
if (!all(lower < theta & theta < upper))
- stop("lower < theta < upper values are required")
+ stop("lower < theta < upper values are required")
N = n
- lower = rep(lower, len=N); upper = rep(upper, len=N);
- theta = rep(theta, len=N)
+ lower = rep(lower, len = N); upper = rep(upper, len = N);
+ theta = rep(theta, len = N)
t1 = sqrt(runif(n))
t2 = sqrt(runif(n))
ifelse(runif(n) < (theta-lower)/(upper-lower),
@@ -3557,21 +3643,25 @@ rtriangle = function(n, theta, lower=0, upper=1) {
}
-qtriangle = function(p, theta, lower=0, upper=1) {
- if (!is.Numeric(p, posit = TRUE)) stop("bad input for argument 'p'")
- if (!is.Numeric(theta)) stop("bad input for argument 'theta'")
- if (!is.Numeric(lower)) stop("bad input for argument 'lower'")
- if (!is.Numeric(upper)) stop("bad input for argument 'upper'")
+qtriangle = function(p, theta, lower = 0, upper = 1) {
+ if (!is.Numeric(p, posit = TRUE))
+ stop("bad input for argument 'p'")
+ if (!is.Numeric(theta))
+ stop("bad input for argument 'theta'")
+ if (!is.Numeric(lower))
+ stop("bad input for argument 'lower'")
+ if (!is.Numeric(upper))
+ stop("bad input for argument 'upper'")
if (!all(lower < theta & theta < upper))
- stop("lower < theta < upper values are required")
+ stop("lower < theta < upper values are required")
N = max(length(p), length(theta), length(lower), length(upper))
- p = rep(p, len=N); lower = rep(lower, len=N); upper = rep(upper, len=N);
- theta = rep(theta, len=N)
+ p = rep(p, len = N); lower = rep(lower, len = N); upper = rep(upper, len = N);
+ theta = rep(theta, len = N)
bad = (p < 0) | (p > 1)
if (any(bad))
- stop("bad input for 'p'")
+ stop("bad input for argument 'p'")
Neg = (p <= (theta - lower)/(upper - lower))
ans = as.numeric(NA) * p
@@ -3591,17 +3681,21 @@ qtriangle = function(p, theta, lower=0, upper=1) {
}
-ptriangle = function(q, theta, lower=0, upper=1) {
- if (!is.Numeric(q)) stop("bad input for argument 'q'")
- if (!is.Numeric(theta)) stop("bad input for argument 'theta'")
- if (!is.Numeric(lower)) stop("bad input for argument 'lower'")
- if (!is.Numeric(upper)) stop("bad input for argument 'upper'")
+ptriangle = function(q, theta, lower = 0, upper = 1) {
+ if (!is.Numeric(q))
+ stop("bad input for argument 'q'")
+ if (!is.Numeric(theta))
+ stop("bad input for argument 'theta'")
+ if (!is.Numeric(lower))
+ stop("bad input for argument 'lower'")
+ if (!is.Numeric(upper))
+ stop("bad input for argument 'upper'")
if (!all(lower < theta & theta < upper))
- stop("lower < theta < upper values are required")
+ stop("lower < theta < upper values are required")
N = max(length(q), length(theta), length(lower), length(upper))
- q = rep(q, len=N); lower = rep(lower, len=N); upper = rep(upper, len=N);
- theta = rep(theta, len=N)
+ q = rep(q, len = N); lower = rep(lower, len = N); upper = rep(upper, len = N);
+ theta = rep(theta, len = N)
ans = q * 0
qstar = (q - lower)^2 / ((upper-lower) * (theta-lower))
@@ -3618,16 +3712,18 @@ ptriangle = function(q, theta, lower=0, upper=1) {
- triangle = function(lower=0, upper=1,
+ triangle = function(lower = 0, upper = 1,
link = "elogit", earg = if (link == "elogit")
list(min = lower, max = upper) else list(), itheta = NULL)
{
- if (!is.Numeric(lower)) stop("bad input for argument 'lower'")
- if (!is.Numeric(upper)) stop("bad input for argument 'upper'")
+ if (!is.Numeric(lower))
+ stop("bad input for argument 'lower'")
+ if (!is.Numeric(upper))
+ stop("bad input for argument 'upper'")
if (!all(lower < upper))
- stop("lower < upper values are required")
+ stop("lower < upper values are required")
if (length(itheta) && !is.Numeric(itheta))
- stop("bad input for 'itheta'")
+ stop("bad input for 'itheta'")
if (mode(link) != "character" && mode(link) != "name")
link = as.character(substitute(link))
@@ -3641,12 +3737,12 @@ ptriangle = function(q, theta, lower=0, upper=1) {
initialize = eval(substitute(expression({
y = as.numeric(y)
if (ncol(cbind(y)) != 1)
- stop("response must be a vector or a one-column matrix")
+ stop("response must be a vector or a one-column matrix")
extra$lower = rep( .lower, len = n)
extra$upper = rep( .upper, len = n)
if (any(y <= extra$lower | y >= extra$upper))
- stop("some y values in [lower,upper] detected")
+ stop("some y values in [lower,upper] detected")
predictors.names = namesof("theta", .link, earg = .earg, tag = FALSE)
if (!length(etastart)) {
Theta.init = if (length( .itheta)) .itheta else {
@@ -3657,7 +3753,7 @@ ptriangle = function(q, theta, lower=0, upper=1) {
}
}), list( .link = link, .earg = earg, .itheta=itheta,
.upper=upper, .lower=lower ))),
- inverse = eval(substitute(function(eta, extra = NULL) {
+ linkinv = eval(substitute(function(eta, extra = NULL) {
Theta = eta2theta(eta, .link, earg = .earg )
lower = extra$lower
upper = extra$upper
@@ -3747,10 +3843,13 @@ loglaplace1.control <- function(maxit = 300, ...)
if (mode(llocation) != "character" && mode(llocation) != "name")
llocation = as.character(substitute(llocation))
if (!is.Numeric(imethod, allow = 1, integ = TRUE, posit = TRUE) ||
- imethod > 4) stop("argument 'imethod' must be 1, 2 or ... 4")
+ imethod > 4)
+ stop("argument 'imethod' must be 1, 2 or ... 4")
if (!is.list(elocation)) elocation = list()
if (!is.Numeric(shrinkage.init, allow = 1) || shrinkage.init < 0 ||
- shrinkage.init > 1) stop("bad input for argument 'shrinkage.init'")
+ shrinkage.init > 1)
+ stop("bad input for argument 'shrinkage.init'")
+
if (length(zero) &&
!(is.Numeric(zero, integer = TRUE, posit = TRUE) || is.character(zero )))
stop("bad input for argument 'zero'")
@@ -3796,7 +3895,8 @@ loglaplace1.control <- function(maxit = 300, ...)
if (FALSE) {
- if (min(y) < 0) stop("negative response values detected")
+ if (min(y) < 0)
+ stop("negative response values detected")
if ((prop.0. <- weighted.mean(1*(y == 0), w)) >= min(extra$tau))
stop("sample proportion of 0s == ", round(prop.0., dig=4),
" > minimum 'tau' value. Choose larger values for 'tau'.")
@@ -3836,7 +3936,7 @@ loglaplace1.control <- function(maxit = 300, ...)
.elocat = elocation, .Scale.arg = Scale.arg,
.llocat = llocation, .kappa = kappa,
.ilocat = ilocation ))),
- inverse = eval(substitute(function(eta, extra = NULL) {
+ linkinv = eval(substitute(function(eta, extra = NULL) {
location.y = eta2theta(eta, .llocat, earg = .elocat)
if ( .fittedMean ) {
stop("Yet to do: handle 'fittedMean = TRUE'")
@@ -3882,7 +3982,7 @@ loglaplace1.control <- function(maxit = 300, ...)
if ( .llocat == "loge")
- ymat = adjust0.loglaplace1(ymat=ymat, y = y, w = w, rep0= .rep0)
+ ymat = adjust0.loglaplace1(ymat = ymat, y = y, w = w, rep0= .rep0)
w.mat = theta2eta(ymat, .llocat, earg = .elocat) # e.g., logoff()
if (residuals) {
stop("loglikelihood residuals not implemented yet")
@@ -3903,7 +4003,7 @@ loglaplace1.control <- function(maxit = 300, ...)
location.y = eta2theta(location.w, .llocat, earg = .elocat)
kappamat = matrix(extra$kappa, n, M, byrow = TRUE)
- ymat = adjust0.loglaplace1(ymat=ymat, y = y, w = w, rep0= .rep0)
+ ymat = adjust0.loglaplace1(ymat = ymat, y = y, w = w, rep0= .rep0)
w.mat = theta2eta(ymat, .llocat, earg = .elocat) # e.g., logit()
zedd = abs(w.mat-location.w) / Scale.w
dl.dlocation = ifelse(w.mat >= location.w, kappamat, 1/kappamat) *
@@ -3951,6 +4051,7 @@ loglaplace2.control <- function(save.weight = TRUE, ...)
stop("bad input for argument 'kappa'")
if (length(tau) && max(abs(kappa - sqrt(tau/(1-tau)))) > 1.0e-6)
stop("arguments 'kappa' and 'tau' do not match")
+
if (mode(llocation) != "character" && mode(llocation) != "name")
llocation = as.character(substitute(llocation))
if (mode(lscale) != "character" && mode(lscale) != "name")
@@ -3959,12 +4060,15 @@ loglaplace2.control <- function(save.weight = TRUE, ...)
imethod > 4) stop("argument 'imethod' must be 1, 2 or ... 4")
if (length(iscale) && !is.Numeric(iscale, posit = TRUE))
stop("bad input for argument 'iscale'")
+
if (!is.list(elocation)) elocation = list()
if (!is.list(escale)) escale = list()
+
if (!is.Numeric(shrinkage.init, allow = 1) || shrinkage.init < 0 ||
shrinkage.init > 1) stop("bad input for argument 'shrinkage.init'")
if (length(zero) &&
- !(is.Numeric(zero, integer = TRUE, posit = TRUE) || is.character(zero )))
+ !(is.Numeric(zero, integer = TRUE, posit = TRUE) ||
+ is.character(zero )))
stop("bad input for argument 'zero'")
if (!is.logical(sameScale) || length(sameScale) != 1)
stop("bad input for argument 'sameScale'")
@@ -4017,7 +4121,7 @@ loglaplace2.control <- function(save.weight = TRUE, ...)
extra$kappa = .kappa
extra$tau = extra$kappa^2 / (1 + extra$kappa^2)
if (ncol(y <- cbind(y)) != 1)
- stop("response must be a vector or a one-column matrix")
+ stop("response must be a vector or a one-column matrix")
extra$M = M = 2 * length(extra$kappa)
extra$n = n
extra$y.names = y.names =
@@ -4029,8 +4133,8 @@ loglaplace2.control <- function(save.weight = TRUE, ...)
namesof(if (M == 2) "scale" else paste("scale", 1:(M/2), sep = ""),
.lscale, earg = .escale, tag = FALSE))
if (weighted.mean(1 * (y < 0.001), w) >= min(extra$tau))
- stop("sample proportion of 0s > minimum 'tau' value. ",
- "Choose larger values for 'tau'.")
+ stop("sample proportion of 0s > minimum 'tau' value. ",
+ "Choose larger values for 'tau'.")
if (!length(etastart)) {
if ( .imethod == 1) {
@@ -4065,7 +4169,7 @@ loglaplace2.control <- function(save.weight = TRUE, ...)
.elocat = elocation, .escale = escale,
.llocat = llocation, .lscale = lscale, .kappa = kappa,
.ilocat = ilocation, .iscale = iscale ))),
- inverse = eval(substitute(function(eta, extra = NULL) {
+ linkinv = eval(substitute(function(eta, extra = NULL) {
location.y = eta2theta(eta[,1:(extra$M/2), drop = FALSE],
.llocat, earg = .elocat)
if ( .fittedMean ) {
@@ -4212,19 +4316,24 @@ adjust01.logitlaplace1 = function(ymat, y, w, rep01) {
stop("bad input for argument 'rep01'")
if (!is.Numeric(kappa, posit = TRUE))
stop("bad input for argument 'kappa'")
+
if (length(tau) && max(abs(kappa - sqrt(tau/(1-tau)))) > 1.0e-6)
stop("arguments 'kappa' and 'tau' do not match")
if (mode(llocation) != "character" && mode(llocation) != "name")
llocation = as.character(substitute(llocation))
if (!is.Numeric(imethod, allow = 1, integ = TRUE, posit = TRUE) ||
- imethod > 4) stop("argument 'imethod' must be 1, 2 or ... 4")
+ imethod > 4)
+ stop("argument 'imethod' must be 1, 2 or ... 4")
+
if (!is.list(elocation)) elocation = list()
if (!is.Numeric(shrinkage.init, allow = 1) || shrinkage.init < 0 ||
- shrinkage.init > 1) stop("bad input for argument 'shrinkage.init'")
+ shrinkage.init > 1)
+ stop("bad input for argument 'shrinkage.init'")
if (length(zero) &&
!(is.Numeric(zero, integer = TRUE, posit = TRUE) ||
is.character(zero )))
stop("bad input for argument 'zero'")
+
if (!is.Numeric(Scale.arg, posit = TRUE))
stop("bad input for argument 'Scale.arg'")
if (!is.logical(parallelLocation) || length(parallelLocation) != 1)
@@ -4233,12 +4342,14 @@ adjust01.logitlaplace1 = function(ymat, y, w, rep01) {
if (!is.logical(fittedMean) || length(fittedMean) != 1)
stop("bad input for argument 'fittedMean'")
+
mystring0 = namesof("location", llocation, earg = elocation)
mychars = substring(mystring0, fi = 1:nchar(mystring0),
la = 1:nchar(mystring0))
mychars[nchar(mystring0)] = ", inverse = TRUE)"
mystring1 = paste(mychars, collapse = "")
+
new("vglmff",
blurb = c("One-parameter ", llocation, "-Laplace distribution\n\n",
"Links: ", mystring0, "\n", "\n",
@@ -4264,9 +4375,12 @@ adjust01.logitlaplace1 = function(ymat, y, w, rep01) {
namesof(paste("quantile(", y.names, ")", sep = ""),
.llocat, earg = .elocat, tag = FALSE)
- if (all(y == 0 | y == 1)) stop("response cannot be all 0s or 1s")
- if (min(y) < 0) stop("negative response values detected")
- if (max(y) > 1) stop("response values greater than 1 detected")
+ if (all(y == 0 | y == 1))
+ stop("response cannot be all 0s or 1s")
+ if (min(y) < 0)
+ stop("negative response values detected")
+ if (max(y) > 1)
+ stop("response values greater than 1 detected")
if ((prop.0. <- weighted.mean(1*(y == 0), w)) >= min(extra$tau))
stop("sample proportion of 0s == ", round(prop.0., dig=4),
" > minimum 'tau' value. Choose larger values for 'tau'.")
@@ -4300,7 +4414,7 @@ adjust01.logitlaplace1 = function(ymat, y, w, rep01) {
.elocat = elocation, .Scale.arg = Scale.arg,
.llocat = llocation, .kappa = kappa,
.ilocat = ilocation ))),
- inverse = eval(substitute(function(eta, extra = NULL) {
+ linkinv = eval(substitute(function(eta, extra = NULL) {
location.y = eta2theta(eta, .llocat, earg = .elocat)
if ( .fittedMean ) {
stop("Yet to do: handle 'fittedMean = TRUE'")
@@ -4340,7 +4454,7 @@ adjust01.logitlaplace1 = function(ymat, y, w, rep01) {
kappamat = matrix(extra$kappa, extra$n, extra$M, byrow = TRUE)
Scale.w = matrix(extra$Scale, extra$n, extra$M, byrow = TRUE)
ymat = matrix(y, extra$n, extra$M)
- ymat = adjust01.logitlaplace1(ymat=ymat, y = y, w = w, rep01= .rep01)
+ ymat = adjust01.logitlaplace1(ymat = ymat, y = y, w = w, rep01 = .rep01)
w.mat = theta2eta(ymat, .llocat, earg = .elocat) # e.g., logit()
if (residuals) {
stop("loglikelihood residuals not implemented yet")
@@ -4360,7 +4474,7 @@ adjust01.logitlaplace1 = function(ymat, y, w, rep01) {
Scale.w = matrix(extra$Scale, extra$n, extra$M, byrow = TRUE)
location.w = eta
kappamat = matrix(extra$kappa, n, M, byrow = TRUE)
- ymat = adjust01.logitlaplace1(ymat=ymat, y = y, w = w, rep01= .rep01)
+ ymat = adjust01.logitlaplace1(ymat = ymat, y = y, w = w, rep01 = .rep01)
w.mat = theta2eta(ymat, .llocat, earg = .elocat) # e.g., logit()
zedd = abs(w.mat-location.w) / Scale.w
dl.dlocation = ifelse(w.mat >= location.w, kappamat, 1/kappamat) *
diff --git a/R/family.quantal.R b/R/family.quantal.R
new file mode 100644
index 0000000..689e767
--- /dev/null
+++ b/R/family.quantal.R
@@ -0,0 +1,373 @@
+# These functions are
+# Copyright (C) 1998-2011 T.W. Yee, University of Auckland.
+# All rights reserved.
+
+
+
+
+
+
+
+
+
+
+
+
+
+ abbott = function(link0 = "logit", earg0 = list(),
+ link1 = "logit", earg1 = list(),
+ iprob0 = NULL, iprob1 = NULL,
+ fitted.type = c("observed", "treatment", "control"),
+ mux.offdiagonal = 0.98,
+ zero = 1) {
+
+
+ fitted.type <- match.arg(fitted.type,
+ c("observed", "treatment", "control"),
+ several.ok =TRUE)
+
+
+ if (mode(link0) != "character" && mode(link0) != "name")
+ link0 <- as.character(substitute(link0))
+ if (!is.list(earg0)) earg0 = list()
+
+ if (mode(link1) != "character" && mode(link1) != "name")
+ link1 <- as.character(substitute(link1))
+ if (!is.list(earg1)) earg1 = list()
+
+ if (!is.Numeric(mux.offdiagonal, allow = 1) ||
+ mux.offdiagonal >= 1 ||
+ mux.offdiagonal < 0)
+ stop("argument 'mux.offdiagonal' must be in the interval [0, 1)")
+
+
+ new("vglmff",
+ blurb = c("Abbott's model for binary responses\n",
+ "mu = prob0 + (1 - prob0) * prob1\n",
+ "where 'prob0' is the 'control' mortality and\n",
+ "'prob1' is the 'treatment' mortality and\n",
+ "'mu' is the 'observed' mortality\n\n",
+ "Links: ",
+ namesof("prob0", link0, earg = earg0), ", ",
+ namesof("prob1", link1, earg = earg1)),
+ constraints = eval(substitute(expression({
+ constraints <- cm.zero.vgam(constraints, x, .zero, M)
+ }), list( .zero = zero # ,
+ ))),
+ initialize = eval(substitute(expression({
+
+ eval(binomialff(link = .link0)@initialize) # w, y, mustart are assigned
+
+
+ predictors.names <-
+ c(namesof("prob0", .link0, earg = .earg0, short = TRUE),
+ namesof("prob1", .link1, earg = .earg1, short = TRUE))
+
+
+ if (is.null(etastart)) {
+ prob0.init <- if (length( .iprob0 )) {
+ rep( .iprob0, len = n)
+ } else {
+ mustart / 2
+ }
+
+ prob1.init <- if (length( .iprob1 )) {
+ rep( .iprob1, len = n)
+ } else {
+ mustart / 2
+ }
+
+
+ mustart <- NULL
+
+
+ etastart <-
+ cbind(theta2eta(prob0.init, link = .link0 , earg = .earg0 ),
+ theta2eta(prob1.init, link = .link1 , earg = .earg1 ))
+ }
+ }), list( .link0 = link0, .earg0 = earg0,
+ .link1 = link1, .earg1 = earg1,
+ .iprob0 = iprob0, .iprob1 = iprob1 ))),
+ linkinv = eval(substitute(function(eta, extra = NULL) {
+ prob0 <- eta2theta(eta[, 1], .link0 , earg = .earg0 )
+ prob1 <- eta2theta(eta[, 2], .link1 , earg = .earg1 )
+
+ con.fv = prob0
+ trt.fv = prob1
+ obs.fv = prob0 + (1 - prob0) * prob1
+
+
+
+ ans = cbind("observed" = obs.fv,
+ "treatment" = trt.fv,
+ "control" = con.fv)
+
+
+ ans[, .fitted.type , drop = FALSE]
+ }, list( .link0 = link0, .earg0 = earg0,
+ .link1 = link1, .earg1 = earg1,
+ .fitted.type = fitted.type ))),
+
+ loglikelihood = eval(substitute(
+ function(mu, y, w, residuals = FALSE, eta, extra = NULL) {
+
+
+ prob0 <- eta2theta(eta[, 1], .link0, earg = .earg0 )
+ prob1 <- eta2theta(eta[, 2], .link1, earg = .earg1 )
+ mymu = prob0 + (1 - prob0) * prob1
+
+
+ if (residuals) {
+ w * (y / mymu - (1-y) / (1 - mymu))
+ } else {
+ ycounts = if (is.numeric(extra$orig.w)) y * w / extra$orig.w else
+ y * w # Convert proportions to counts
+ nvec = if (is.numeric(extra$orig.w)) round(w / extra$orig.w) else
+ round(w)
+ smallno = 1.0e6 * .Machine$double.eps
+ smallno = sqrt(.Machine$double.eps)
+ if (max(abs(ycounts - round(ycounts))) > smallno)
+ warning("converting 'ycounts' to integer in @loglikelihood")
+ ycounts = round(ycounts)
+ sum((if (is.numeric(extra$orig.w)) extra$orig.w else 1) *
+ dbinom(x = ycounts, size = nvec, prob = mymu, log = TRUE))
+ }
+ }, list( .link0 = link0, .earg0 = earg0,
+ .link1 = link1, .earg1 = earg1 ))),
+
+
+ last = eval(substitute(expression({
+ misc$link <- c(prob0 = .link0 , prob1 = .link1 )
+ misc$earg <- list(prob0 = .earg0 , prob1 = .earg1 )
+ misc$mux.offdiagonal = .mux.offdiagonal
+ misc$fitted.type = .fitted.type
+ misc$true.mu = ( .fitted.type == "observed")
+
+
+ }), list( .link0 = link0, .earg0 = earg0,
+ .link1 = link1, .earg1 = earg1,
+ .mux.offdiagonal = mux.offdiagonal,
+ .fitted.type = fitted.type
+ ))),
+ vfamily = c("abbott", "vquantal"),
+ deriv = eval(substitute(expression({
+ prob0 <- eta2theta(eta[, 1], .link0, earg = .earg0 )
+ prob1 <- eta2theta(eta[, 2], .link1, earg = .earg1 )
+ dprob0.deta <- dtheta.deta(prob0, .link0 , earg = .earg0 )
+ dprob1.deta <- dtheta.deta(prob1, .link1 , earg = .earg1 )
+
+
+ mymu = prob0 + (1 - prob0) * prob1
+
+
+ dl.dmu <- y / mymu - (1 - y) / (1 - mymu)
+ dmu.dprob0 <- 1 - prob1
+ dmu.dprob1 <- 1 - prob0
+ dl.dprob0 <- dl.dmu * dmu.dprob0
+ dl.dprob1 <- dl.dmu * dmu.dprob1
+
+
+ c(w) * cbind(dl.dprob0 * dprob0.deta,
+ dl.dprob1 * dprob1.deta)
+ }), list( .link0 = link0, .earg0 = earg0,
+ .link1 = link1, .earg1 = earg1 ))),
+ weight = eval(substitute(expression({
+
+
+ ed2l.dmu2 <- 1 / (mymu * (1-mymu))
+ ed2l.dprob02 <- ed2l.dmu2 * dmu.dprob0^2
+ ed2l.dprob12 <- ed2l.dmu2 * dmu.dprob1^2
+ ed2l.dprob1prob2 <- ( 1) # seems sort of ok but slow cvgc
+ ed2l.dprob1prob2 <- ( 0) # kill it
+ ed2l.dprob1prob2 <- ed2l.dmu2 * ( 1) # dont seem to work
+
+ ed2l.dprob1prob2 <- ed2l.dmu2 * dmu.dprob1 * dmu.dprob0 *
+ .mux.offdiagonal
+
+ od2l.dmu2 <- y / mymu^2 + (1 - y) / (1 - mymu)^2
+ od2l.dprob02 <- od2l.dmu2 * dmu.dprob0^2
+ od2l.dprob12 <- od2l.dmu2 * dmu.dprob1^2
+ od2l.dprob1prob2 <- od2l.dmu2 * dmu.dprob1 * dmu.dprob0 + dl.dmu
+
+
+ wz <- cbind(ed2l.dprob02 * dprob0.deta^2,
+ ed2l.dprob12 * dprob1.deta^2,
+ ed2l.dprob1prob2 * dprob1.deta * dprob0.deta)
+
+
+ if (FALSE)
+ wz <- cbind(od2l.dprob02 * dprob0.deta^2,
+ od2l.dprob12 * dprob1.deta^2,
+ od2l.dprob1prob2 * dprob1.deta * dprob0.deta)
+
+
+ c(w) * wz
+ }), list( .link0 = link0, .earg0 = earg0,
+ .link1 = link1, .earg1 = earg1,
+ .mux.offdiagonal = mux.offdiagonal ))))
+}
+
+
+
+
+
+
+
+
+
+
+if (FALSE)
+ Abbott = function(lprob1 = "elogit",
+ eprob1 = list(min = 0, max = 1), # For now, that is
+ lprob0 = "logit", eprob0 = list(),
+ iprob0 = NULL, iprob1 = NULL,
+ nointercept = 2, # NULL,
+ zero = 1) {
+
+
+
+
+ stop("does not work")
+
+
+
+ if (mode(lprob1) != "character" && mode(lprob1) != "name")
+ lprob1 <- as.character(substitute(lprob1))
+ if (!is.list(eprob1)) eprob1 = list()
+
+ if (mode(lprob0) != "character" && mode(lprob0) != "name")
+ lprob0 <- as.character(substitute(lprob0))
+ if (!is.list(eprob0)) eprob0 = list()
+
+
+ new("vglmff",
+ blurb = c("Abbott's model for binary response\n",
+ "mu = prob0 + prob1\n",
+ "where 'prob0' is the control mortality and\n",
+ "'prob1' is the treatment mortality\n\n",
+ "Links: ",
+ namesof("prob0", lprob0, earg = eprob0), ", ",
+ namesof("prob1", lprob1, earg = eprob1)),
+ constraints = eval(substitute(expression({
+ constraints <- cm.zero.vgam(constraints, x, .zero, M)
+ constraints = cm.nointercept.vgam(constraints, x, .nointercept, M)
+ }), list( .zero = zero,
+ .nointercept = nointercept ))),
+
+
+ initialize = eval(substitute(expression({
+ print("here1")
+
+ eval(binomialff(link = .lprob1)@initialize) # w, y, mustart are assigned
+
+ print("here2")
+ print("summary(mustart)")
+ print( summary(mustart) )
+
+ predictors.names <-
+ c(namesof("prob0", .lprob0, earg = .eprob0, short = TRUE),
+ namesof("prob1", .lprob1, earg = .eprob1, short = TRUE))
+
+
+ if (is.null(etastart)) {
+ prob0.init <- if (length( .iprob0 )) {
+ rep( .iprob0, len = n)
+ } else {
+ mustart / 2
+ }
+
+ prob1.init <- if (length( .iprob1 )) {
+ rep( .iprob1, len = n)
+ } else {
+ mustart * 1 / 4
+ }
+
+
+ mustart <- NULL
+
+
+ print("prob0.init ")
+ print( sort(prob0.init) )
+ print("prob1.init ")
+ print( sort(prob1.init) )
+
+
+ eprob1 = list(min = prob0.init, max = 1)
+ etastart <-
+ cbind(theta2eta(prob0.init, link = .lprob0 , earg = .eprob0 ),
+ theta2eta(prob1.init, link = .lprob1 , earg = eprob1 ))
+ print("head(etastart)")
+ print( head(etastart) )
+ }
+ }), list( .lprob1 = lprob1, .eprob1 = eprob1,
+ .lprob0 = lprob0, .eprob0 = eprob0,
+ .iprob0 = iprob0, .iprob1 = iprob1 ))),
+ linkinv = eval(substitute(function(eta, extra = NULL) {
+ prob0 <- eta2theta(eta[, 1], .lprob0 , earg = .eprob0)
+
+ eprob1 = list(min = prob0, max = 1)
+
+ prob1 <- eta2theta(eta[, 2], .lprob1 , earg = eprob1)
+ prob0 + prob1
+ }, list( .lprob1 = lprob1, .eprob1 = eprob1,
+ .lprob0 = lprob0, .eprob0 = eprob0 ))),
+ last = eval(substitute(expression({
+ eprob1 = list(min = prob0, max = 1)
+ misc$link <- c(prob0 = .lprob0, prob1 = .lprob1)
+ misc$earg <- list(prob0 = .eprob0, prob1 = eprob1)
+
+ misc$nointercept = .nointercept
+ }), list( .lprob1 = lprob1, .eprob1 = eprob1,
+ .lprob0 = lprob0, .eprob0 = eprob0,
+ .nointercept = nointercept ))),
+ vfamily = c("Abbott", "vquantal"),
+ deriv = eval(substitute(expression({
+ prob0 <- eta2theta(eta[,1], .lprob0, earg = .eprob0)
+
+ eprob1 = list(min = prob0, max = 1)
+ prob1 <- eta2theta(eta[,2], .lprob1, earg = eprob1)
+ dprob0.deta <- dtheta.deta(prob0, .lprob0 , earg = .eprob0 )
+ dprob1.deta <- dtheta.deta(prob1, .lprob1 , earg = eprob1 )
+
+ dl.dmu <- y / mu - (1 - y) / (1 - mu)
+ dmu.dprob0 <- 1 # - prob1
+ dmu.dprob1 <- 1 # - prob0
+ dl.dprob0 <- dl.dmu * dmu.dprob0
+ dl.dprob1 <- dl.dmu * dmu.dprob1
+
+ c(w) * cbind(dl.dmu * dmu.dprob0 * dprob0.deta,
+ dl.dmu * dmu.dprob1 * dprob1.deta)
+ }), list( .lprob1 = lprob1, .eprob1 = eprob1,
+ .lprob0 = lprob0, .eprob0 = eprob0 ))),
+ weight = eval(substitute(expression({
+
+
+ ed2l.dmu2 <- 1 / (mu * (1-mu))
+ ed2l.dprob02 <- ed2l.dmu2 * dmu.dprob0^2
+ ed2l.dprob12 <- ed2l.dmu2 * dmu.dprob1^2
+
+ wz <- cbind(ed2l.dprob02 * dprob0.deta^2,
+ ed2l.dprob12 * dprob1.deta^2)
+
+ print("head(wz)")
+ print( head(wz) )
+ c(w) * wz
+ }), list( .lprob1 = lprob1, .eprob1 = eprob1,
+ .lprob0 = lprob0, .eprob0 = eprob0 ))))
+}
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
diff --git a/R/family.rcam.R b/R/family.rcam.R
index 8142077..bbac38c 100644
--- a/R/family.rcam.R
+++ b/R/family.rcam.R
@@ -15,11 +15,11 @@
-
rcam <- function(y,
family = poissonff,
Rank = 0,
Musual = NULL,
+ weights = NULL,
Index.corner = if (!Rank) NULL else 1 + Musual * (1:Rank),
rprefix = "Row.",
cprefix = "Col.",
@@ -220,12 +220,16 @@
rrvglm(as.formula(str2),
family = family,
constraints = Hlist,
+ weights = if (length(weights)) weights else rep(1, length = nrow(y)),
+ ...,
control = mycontrol, data = .rcam.df)
} else {
if (is(object.save, "vglm")) object.save else
vglm(as.formula(str2),
family = family,
constraints = Hlist,
+ weights = if (length(weights)) weights else rep(1, length = nrow(y)),
+ ...,
control = mycontrol, data = .rcam.df)
}
@@ -570,7 +574,7 @@ moffset <- function (mat, roffset = 0, coffset = 0, postfix = "") {
-confint_rrnb <- function(rrnb2) {
+confint_rrnb <- function(rrnb2, level = 0.95) {
if (class(rrnb2) != "rrvglm")
stop("argument 'rrnb2' does not appear to be a rrvglm() object")
@@ -596,12 +600,13 @@ confint_rrnb <- function(rrnb2) {
se.a21.hat <- sqrt(vcovrrvglm(rrnb2)["I(lv.mat)", "I(lv.mat)"])
- ci.a21 <- a21.hat + c(-1, 1) * 1.96 * se.a21.hat
- (ci.delta2 <- 2 - rev(ci.a21)) # The 95 percent confidence interval
+ ci.a21 <- a21.hat + c(-1, 1) * qnorm(1 - (1 - level)/2) * se.a21.hat
+ (ci.delta2 <- 2 - rev(ci.a21)) # e.g., the 95 percent CI
list(a21.hat = a21.hat,
beta11.hat = beta11.hat,
beta21.hat = beta21.hat,
+ CI.a21 = ci.a21,
ci.delta2 = ci.delta2,
delta1 = delta1.hat,
delta2 = delta2.hat,
@@ -610,7 +615,12 @@ confint_rrnb <- function(rrnb2) {
-confint_nb1 <- function(nb1) {
+
+
+confint_nb1 <- function(nb1, level = 0.95) {
+
+
+
if (class(nb1) != "vglm")
stop("argument 'nb1' does not appear to be a vglm() object")
@@ -638,11 +648,14 @@ confint_nb1 <- function(nb1) {
myvcov <- vcovvlm(as(nb1, "vglm")) # Not great; improve this!
myvec <- cbind(c(-1, 1, rep(0, len = nrow(myvcov) - 2)))
(se.mydiff <- sqrt(t(myvec) %*% myvcov %*% myvec))
- ci.mydiff <- mydiff + c(-1.96, 1.96) * se.mydiff
+
+ ci.mydiff <- mydiff + c(-1, 1) * qnorm(1 - (1 - level)/2) * se.mydiff
+
ci.delta0 <- ci.exp.mydiff <- exp(ci.mydiff)
- (ci.phi0 <- 1 + 1 / rev(ci.delta0)) # The 95 percent conf int. for phi0
+ (ci.phi0 <- 1 + 1 / rev(ci.delta0)) # e.g., the 95 percent CI for phi0
list(ci.phi0 = ci.phi0,
+ CI.delta0 = ci.delta0,
delta0 = delta0.hat,
phi0 = phi0.hat)
}
@@ -657,3 +670,492 @@ confint_nb1 <- function(nb1) {
+
+if (FALSE)
+Qvar <- function(object, factor.name = NULL,
+ level1.name = "level1",
+ ...) {
+
+
+
+
+ object.xlevels = if (is(object, "vglm")) {
+ object at xlevels
+ } else {
+ factor(rownames(object))
+ }
+
+ myvcov = if (is(object, "vglm")) {
+ if (length(object.xlevels) == 0)
+ stop("no factors amongst the model.matrix of 'object'")
+
+ if (is.null(factor.name)) {
+ if (length(object.xlevels) > 1)
+ stop("more than one factor in the model.matrix of 'object'")
+
+ factor.name = names(object.xlevels)
+ object.xlevels = object at xlevels[[1]]
+ } else {
+ object.xlevels = object.xlevels[[factor.name]]
+ }
+
+
+
+
+
+ colptr = attr(model.matrix(object), "vassign")
+ colptr = colptr[[factor.name]]
+ vcov(object)[colptr, colptr, drop = FALSE]
+ } else if (is.matrix(object)) {
+ object
+ } else {
+ stop("argument 'object' is not a vglm() object or a matrix")
+ }
+
+
+
+
+ myvcov = rbind(0, cbind(0, myvcov))
+
+ LL = nrow(myvcov)
+ if (LL <= 3)
+ stop("the factor must have at least three levels")
+
+
+ vcov0 = myvcov
+ for (ilocal in 1:LL)
+ for (jlocal in ilocal:LL)
+ myvcov[ilocal, jlocal] =
+ myvcov[jlocal, ilocal] = vcov0[ilocal, ilocal] + vcov0[jlocal, jlocal] -
+ 2 * vcov0[ilocal, jlocal]
+
+ allvcov = myvcov
+ rownames(allvcov) =
+ c(paste(if (is.matrix(object)) level1.name else factor.name,
+ if (is.matrix(object)) NULL else object.xlevels[1], sep = ""),
+ rownames(vcov0)[-1])
+ colnames(allvcov) = rownames(allvcov)
+
+
+
+
+
+
+
+
+
+ diag(allvcov) = rep(1, len = LL) # Any positive value should do
+
+
+
+
+
+ Allvcov = allvcov
+
+
+
+
+ wmat = matrix(1, LL, LL)
+ diag(wmat) = sqrt( .Machine$double.eps )
+
+
+ logAllvcov = log(Allvcov)
+ attr(logAllvcov, "Prior.Weights") = wmat
+ logAllvcov
+}
+
+
+
+
+
+
+
+
+
+
+
+
+Qvar <- function(object, factorname = NULL, coef.indices = NULL,
+ labels = NULL, dispersion = NULL,
+ reference.name = "(reference)",
+ estimates = NULL
+ ) {
+
+
+
+
+ coef.indices.saved <- coef.indices
+ if (!is.matrix(object)) {
+ model <- object
+ if (is.null(factorname) && is.null(coef.indices)) {
+ stop("arguments \"factorname\" and \"coef.indices\" are both NULL")
+ }
+
+ if (is.null(coef.indices)) {
+ tmodel <- terms(model)
+ modelmat <- if (is.matrix(model at x)) model at x else
+ model.matrix(tmodel,
+ data = model at model)
+
+
+
+
+ colptr = attr(model.matrix(object), "vassign")
+ colptr = colptr[[factorname]]
+ coef.indices <- colptr
+
+
+ contmat <- if (length(model at xlevels[[factorname]]) ==
+ length(coef.indices)) {
+ diag(length(coef.indices))
+ } else {
+ eval(call(model at contrasts[[factorname]],
+ model at xlevels[[factorname]]))
+ }
+ rownames(contmat) <- model at xlevels[[factorname]]
+
+ if (is.null(estimates))
+ estimates <- contmat %*% coefvlm(model)[coef.indices]
+
+ covmat <- vcovvlm(model, dispersion = dispersion)
+ covmat <- covmat[coef.indices, coef.indices, drop = FALSE]
+ covmat <- contmat %*% covmat %*% t(contmat)
+ } else {
+ k <- length(coef.indices)
+ refPos <- numeric(0)
+ if (0 %in% coef.indices) {
+ refPos <- which(coef.indices == 0)
+ coef.indices <- coef.indices[-refPos]
+ }
+ covmat <- vcovvlm(model, dispersion = dispersion)
+ covmat <- covmat[coef.indices, coef.indices, drop = FALSE]
+
+ if (is.null(estimates))
+ estimates <- coefvlm(model)[coef.indices]
+
+ if (length(refPos) == 1) {
+ if (length(estimates) != k)
+ estimates <- c(0, estimates)
+ covmat <- rbind(0, cbind(0, covmat))
+ names(estimates)[1] <-
+ rownames(covmat)[1] <-
+ colnames(covmat)[1] <- reference.name
+ if (refPos != 1) {
+ perm <- if (refPos == k) c(2:k, 1) else
+ c(2:refPos, 1, (refPos + 1):k)
+ estimates <- estimates[perm]
+ covmat <- covmat[perm, perm, drop = FALSE]
+ }
+ }
+ }
+
+
+ return(Recall(covmat,
+ factorname = factorname,
+ coef.indices = coef.indices.saved,
+ labels = labels,
+ dispersion = dispersion,
+ estimates = estimates
+ )
+ )
+ } else {
+
+ covmat <- object
+ if (length(labels))
+ rownames(covmat) <- colnames(covmat) <- labels
+ if ((LL <- dim(covmat)[1]) <= 2)
+ stop("This function works only for factors with 3 or more levels")
+ }
+
+
+
+
+ allvcov = covmat
+ for (ilocal in 1:LL)
+ for (jlocal in ilocal:LL)
+ allvcov[ilocal, jlocal] =
+ allvcov[jlocal, ilocal] = covmat[ilocal, ilocal] +
+ covmat[jlocal, jlocal] -
+ covmat[ilocal, jlocal] * 2
+
+ diag(allvcov) = rep(1.0, len = LL) # Any positive value should do
+
+
+ wmat = matrix(1.0, LL, LL)
+ diag(wmat) = sqrt( .Machine$double.eps )
+
+ logAllvcov = log(allvcov)
+ attr(logAllvcov, "Prior.Weights") = wmat
+ attr(logAllvcov, "estimates") = estimates
+ attr(logAllvcov, "coef.indices") = coef.indices
+ attr(logAllvcov, "factorname") = factorname
+ attr(logAllvcov, "regularVar") = diag(covmat)
+
+ logAllvcov
+}
+
+
+
+
+
+
+WorstErrors <- function(qv.object) {
+ stop("20110729; does not work")
+
+ reducedForm <- function(covmat, qvmat){
+ nlevels <- dim(covmat)[1]
+ firstRow <- covmat[1, ]
+ ones <- rep(1, nlevels)
+ J <- outer(ones, ones)
+ notzero <- 2:nlevels
+ r.covmat <- covmat + (firstRow[1]*J) -
+ outer(firstRow, ones) -
+ outer(ones, firstRow)
+ r.covmat <- r.covmat[notzero, notzero]
+ qv1 <- qvmat[1, 1]
+ r.qvmat <- (qvmat + qv1*J)[notzero, notzero]
+ list(r.covmat, r.qvmat)}
+ covmat <- qv.object$covmat
+ qvmat <- diag(qv.object$qvframe$quasiVar)
+ r.form <- reducedForm(covmat, qvmat)
+ r.covmat <- r.form[[1]]
+ r.qvmat <- r.form[[2]]
+ inverse.sqrt <- solve(chol(r.covmat))
+ evalues <- eigen(t(inverse.sqrt) %*% r.qvmat %*% inverse.sqrt,
+ symmetric = TRUE)$values
+ sqrt(c(min(evalues), max(evalues))) - 1
+}
+
+
+
+
+IndentPrint <- function(object, indent = 4, ...){
+ stop("20110729; does not work")
+
+ zz <- ""
+ tc <- textConnection("zz", "w", local = TRUE)
+ sink(tc)
+ try(print(object, ...))
+ sink()
+ close(tc)
+ indent <- paste(rep(" ", indent), sep = "", collapse = "")
+ cat(paste(indent, zz, sep = ""), sep = "\n")}
+
+
+
+Print.qv <- function(x, ...){
+ stop("20110729; does not work")
+
+}
+
+
+
+summary.qvar <- function(object, ...) {
+
+
+ relerrs = 1 - sqrt(exp(residuals(object, type = "response")))
+ diag(relerrs) = NA
+
+ minErrSimple <- round(100 * min(relerrs, na.rm = TRUE), 1)
+ maxErrSimple <- round(100 * max(relerrs, na.rm = TRUE), 1)
+
+
+
+ estimates = c(object at extra$attributes.y$estimates)
+ if (!length(names(estimates)) &&
+ is.matrix(object at extra$attributes.y$estimates))
+ names( estimates) = rownames(object at extra$attributes.y$estimates)
+ if (!length(names(estimates)))
+ names( estimates) = paste("Level", 1:length(estimates), sep = "")
+
+
+ regularVar = c(object at extra$attributes.y$regularVar)
+ QuasiVar <- exp(diag(fitted(object))) / 2
+ QuasiSE <- sqrt(quasiVar)
+
+
+ structure(list(estimate = estimates,
+ SE = sqrt(regularVar), # zz dispersion parameter??
+ minErrSimple = minErrSimple,
+ maxErrSimple = maxErrSimple,
+ quasiSE = QuasiSE,
+ object = object,
+ quasiVar = QuasiVar),
+ class = "summary.qvar")
+}
+
+
+
+print.summary.qvar <- function(x, ...) {
+
+ object = x$object
+ minErrSimple = x$minErrSimple
+ maxErrSimple = x$maxErrSimple
+
+ x$minErrSimple = NULL
+ x$maxErrSimple = NULL
+ x$object = NULL
+
+
+ if (length(cl <- object at call)) {
+ cat("Call:\n")
+ dput(cl)
+ }
+
+
+ facname = c(object at extra$attributes.y$factorname)
+ if (length(facname))
+ cat("Factor name: ", facname, "\n")
+
+
+ if (length(object at dispersion))
+ cat("\nDispersion: ", object at dispersion, "\n\n")
+
+ x = as.data.frame(c(x))
+ print.data.frame(x)
+
+
+ cat("\nWorst relative errors in SEs of simple contrasts (%): ",
+ minErrSimple, ", ", maxErrSimple, "\n")
+
+ invisible(x)
+}
+
+
+
+plotqvar <- function(object,
+ intervalWidth = 2,
+ ylab = "Estimate",
+ xlab = NULL, # x$factorname,
+ ylim = NULL,
+ main = "",
+ levelNames = NULL,
+ conf.level = 0.95,
+ warn.ratio = 10,
+ border = "transparent", # None
+ points.arg = TRUE,
+ length.arrows = 0.25, angle = 30,
+ scol = par()$col,
+ slwd = par()$lwd,
+ slty = par()$lty,
+ ...) {
+
+
+
+
+ if (!is.numeric(intervalWidth) &&
+ !is.numeric(conf.level))
+ stop("at least one of arguments 'intervalWidth' and 'conf.level' ",
+ "should be numeric")
+
+
+
+
+
+ if (!any("normal1" %in% object at family@vfamily))
+ stop("argument 'object' dos not appear to be a ",
+ "rcam(, normal1) object")
+
+ estimates = c(object at extra$attributes.y$estimates)
+ if (!length(names(estimates)) &&
+ is.matrix(object at extra$attributes.y$estimates))
+ names( estimates) = rownames(object at extra$attributes.y$estimates)
+ if (!length(names(estimates)))
+ names( estimates) = paste("Level", 1:length(estimates), sep = "")
+
+
+
+
+ QuasiVar <- exp(diag(fitted(object))) / 2
+ QuasiSE <- sqrt(quasiVar)
+
+ if (!is.numeric(estimates))
+ stop("Cannot plot, because there are no 'proper' parameter estimates")
+ if (!is.numeric(quasiSE))
+ stop("Cannot plot, because there are no quasi standard errors")
+
+
+
+ faclevels <- factor(names(estimates), levels = names(estimates))
+
+
+ xvalues <- seq(along = faclevels)
+ tops <- estimates + intervalWidth * QuasiSE
+ tails <- estimates - intervalWidth * QuasiSE
+
+
+
+
+ if (is.numeric(conf.level)) {
+ zedd = abs(qnorm((1 - conf.level) / 2))
+ lsd.tops <- estimates + zedd * QuasiSE / sqrt(2)
+ lsd.tails <- estimates - zedd * QuasiSE / sqrt(2)
+ if (max(quasiSE) / min(quasiSE) > warn.ratio)
+ warning("Quasi SEs appear to be quite different... the ",
+ "LSD intervals may not be very accurate")
+ } else {
+ lsd.tops <- NULL
+ lsd.tails <- NULL
+ }
+
+
+
+
+ if (is.null(ylim))
+ ylim <- range(c(tails, tops, lsd.tails, lsd.tops), na.rm = TRUE)
+
+ if (is.null(xlab))
+ xlab <- "Factor level"
+
+ plot(faclevels, estimates,
+ border = border,
+ ylim = ylim, xlab = xlab, ylab = ylab,
+ main = main, ...)
+
+
+ if (points.arg)
+ points(estimates, ...)
+
+
+ if (is.numeric(intervalWidth)) {
+ segments(xvalues, tails, xvalues, tops,
+ col = scol, lty = slty, lwd = slwd)
+ }
+
+
+ if (is.numeric(conf.level)) {
+ arrows(xvalues, lsd.tails, xvalues, lsd.tops,
+ col = scol, lty = slty, lwd = slwd, code = 3,
+ length = length.arrows, angle = angle)
+
+ }
+
+
+
+
+ if (any(slotNames(object) == "post")) {
+ object at post$estimates = estimates
+ object at post$xvalues = xvalues
+ if (is.numeric(intervalWidth)) {
+ object at post$tails = tails
+ object at post$tops = tops
+ }
+ if (is.numeric(conf.level)) {
+ object at post$lsd.tails = lsd.tails
+ object at post$lsd.tops = lsd.tops
+ }
+ }
+
+
+ invisible(object)
+}
+
+
+
+
+
+
+
+
+
+
diff --git a/R/family.robust.R b/R/family.robust.R
index 4576a19..b17eeab 100644
--- a/R/family.robust.R
+++ b/R/family.robust.R
@@ -10,6 +10,8 @@
+
+
edhuber <- function(x, k = 0.862, mu = 0, sigma = 1, log = FALSE) {
if (!is.logical(log.arg <- log)) stop("bad input for argument 'log'")
rm(log)
@@ -130,7 +132,7 @@ phuber <- function(q, k = 0.862, mu = 0, sigma = 1)
if (!is.Numeric(imethod, allow = 1, integ = TRUE, posit = TRUE) ||
imethod > 4)
- stop("'imethod' must be 1 or 2 or 3 or 4")
+ stop("argument 'imethod' must be 1 or 2 or 3 or 4")
if (!is.Numeric(k, allow = 1, posit = TRUE))
stop("bad input for argument 'k'")
@@ -179,8 +181,8 @@ phuber <- function(q, k = 0.862, mu = 0, sigma = 1)
}
}), list( .llocat = llocation, .lscale = lscale,
.elocat = elocation, .escale = escale,
- .imethod=imethod ))),
- inverse = eval(substitute(function(eta, extra = NULL) {
+ .imethod = imethod ))),
+ linkinv = eval(substitute(function(eta, extra = NULL) {
eta2theta(eta[,1], .llocat, earg = .elocat)
}, list( .llocat = llocation,
.elocat = elocation, .escale = escale ))),
@@ -257,3 +259,128 @@ phuber <- function(q, k = 0.862, mu = 0, sigma = 1)
+
+ huber1 <- function(llocation = "identity",
+ elocation = list(),
+ k = 0.862,
+ imethod = 1) {
+
+
+ print("hi 20110802")
+ A1 <- (2 * dnorm(k) / k - 2 * pnorm(-k))
+ eps <- A1 / (1 + A1)
+
+ if (!is.Numeric(imethod, allow = 1, integ = TRUE, posit = TRUE) ||
+ imethod > 4)
+ stop("argument 'imethod' must be 1 or 2 or 3 or 4")
+
+ if (!is.Numeric(k, allow = 1, posit = TRUE))
+ stop("bad input for argument 'k'")
+
+ if (mode(llocation) != "character" && mode(llocation) != "name")
+ llocation = as.character(substitute(llocation))
+ if (!is.list(elocation)) elocation = list()
+
+ new("vglmff",
+ blurb = c("Huber least favorable distribution\n\n",
+ "Links: ",
+ namesof("location", llocation, earg = elocation), "\n\n",
+ "Mean: location"),
+ initialize = eval(substitute(expression({
+ predictors.names <-
+ c(namesof("location", .llocat, earg = .elocat, tag = FALSE))
+
+ if (ncol(y <- cbind(y)) != 1)
+ stop("response must be a vector or a one-column matrix")
+
+ if (!length(etastart)) {
+ junk = lm.wfit(x = x, y = y, w = w)
+ location.init <- if ( .llocat == "loge") pmax(1/1024, y) else {
+ if ( .imethod == 3) {
+ rep(weighted.mean(y, w), len = n)
+ } else if ( .imethod == 2) {
+ rep(median(rep(y, w)), len = n)
+ } else if ( .imethod == 1) {
+ junk$fitted
+ } else {
+ y
+ }
+ }
+ etastart <- cbind(
+ theta2eta(location.init, .llocat, earg = .elocat))
+ }
+ }), list( .llocat = llocation,
+ .elocat = elocation,
+ .imethod = imethod ))),
+ linkinv = eval(substitute(function(eta, extra = NULL) {
+ eta2theta(eta, .llocat, earg = .elocat)
+ }, list( .llocat = llocation,
+ .elocat = elocation ))),
+ last = eval(substitute(expression({
+ misc$link <- c("location" = .llocat )
+ misc$earg <- list("location" = .elocat )
+ misc$expected <- TRUE
+ misc$k.huber <- .k
+ misc$imethod <- .imethod
+ }), list( .llocat = llocation,
+ .elocat = elocation,
+ .k = k, .imethod = imethod ))),
+ loglikelihood = eval(substitute(
+ function(mu, y, w, residuals = FALSE, eta, extra = NULL) {
+ location <- eta2theta(eta, .llocat, earg = .elocat)
+ kay <- .k
+ if (residuals) stop("loglikelihood residuals not ",
+ "implemented yet") else {
+ sum(w * dhuber(y, k = kay, mu = location, sigma = 1,
+ log = TRUE))
+ }
+ }, list( .llocat = llocation,
+ .elocat = elocation,
+ .k = k ))),
+ vfamily = c("huber1"),
+ deriv = eval(substitute(expression({
+ mylocat <- eta2theta(eta, .llocat, earg = .elocat)
+ myk <- .k
+
+ zedd <- (y - mylocat) # / myscale
+ cond2 <- (abs(zedd) <= myk)
+ cond3 <- (zedd > myk)
+
+ dl.dlocat <- -myk + 0 * zedd # cond1
+ dl.dlocat[cond2] <- zedd[cond2]
+ dl.dlocat[cond3] <- myk # myk is a scalar
+ dl.dlocat <- dl.dlocat # / myscale
+
+
+ if (FALSE) {
+ dl.dscale <- (-myk * zedd)
+ dl.dscale[cond2] <- (zedd^2)[cond2]
+ dl.dscale[cond3] <- ( myk * zedd)[cond3]
+ dl.dscale <- (-1 + dl.dscale) / myscale
+ }
+
+ dlocat.deta <- dtheta.deta(mylocat, .llocat, earg = .elocat)
+ ans <-
+ c(w) * cbind(dl.dlocat * dlocat.deta)
+ ans
+ }), list( .llocat = llocation,
+ .elocat = elocation,
+ .eps = eps, .k = k ))),
+ weight = eval(substitute(expression({
+ wz <- matrix(as.numeric(NA), n, 1) # diag matrix; y is one-col too
+
+
+
+
+ temp4 <- erf(myk / sqrt(2))
+ ed2l.dlocat2 <- temp4 * (1 - .eps) # / myscale^2
+
+
+ wz[, iam(1,1,M)] <- ed2l.dlocat2 * dlocat.deta^2
+ ans
+ c(w) * wz
+ }), list( .eps = eps ))))
+}
+
+
+
diff --git a/R/family.rrr.R b/R/family.rrr.R
index e24bca2..24b8961 100644
--- a/R/family.rrr.R
+++ b/R/family.rrr.R
@@ -564,7 +564,7 @@ rrr.end.expression = expression({
if (FALSE && control$Rank == 1) {
ooo = order(lv.mat[,1])
}
- mu <- family at inverse(eta, extra)
+ mu <- family at linkinv(eta, extra)
if (any(is.na(mu)))
warning("there are NAs in mu")
@@ -958,7 +958,7 @@ Coef.qrrvglm <- function(object, varlvI = FALSE, reference = NULL, ...) {
if (varlvI) {
if (!length(xmat <- object at x)) stop("cannot obtain the model matrix")
numat = xmat[,ocontrol$colx2.index,drop = FALSE] %*% Cmat
- sdnumat = sd(numat)
+ sdnumat = apply(cbind(numat), 2, sd)
Mmat = if (Rank > 1) diag(sdnumat) else matrix(sdnumat, 1, 1)
Cmat = Cmat %*% solve(t(Mmat))
Amat = Amat %*% Mmat
@@ -978,7 +978,7 @@ Coef.qrrvglm <- function(object, varlvI = FALSE, reference = NULL, ...) {
Amat[ii,,drop = FALSE] %*% optimum[,ii,drop = FALSE] +
t(optimum[,ii,drop = FALSE]) %*%
Darray[,,ii,drop= TRUE] %*% optimum[,ii,drop = FALSE]
- mymax = object at family@inverse(rbind(eta.temp), extra=object at extra)
+ mymax = object at family@linkinv(rbind(eta.temp), extra=object at extra)
c(mymax) # Convert from matrix to vector
} else {
5 * rep(as.numeric(NA), len = M) # Make "numeric"
@@ -1133,7 +1133,7 @@ printCoef.qrrvglm = function(x, ...) {
print(mymat, ...)
cat("\nStandard deviation of the latent variables (site scores)\n")
- print(sd(object at lv))
+ print(apply(cbind(object at lv), 2, sd))
invisible(object)
}
@@ -1146,7 +1146,7 @@ setMethod("summary", "qrrvglm", function(object, ...)
summary.qrrvglm(object, ...))
-predict.qrrvglm <- function(object,
+predictqrrvglm <- function(object,
newdata = NULL,
type=c("link", "response", "lv", "terms"),
se.fit = FALSE,
@@ -1252,7 +1252,7 @@ predict.qrrvglm <- function(object,
pred = switch(type,
response={
- fv = if (length(newdata)) object at family@inverse(etamat, extra) else
+ fv = if (length(newdata)) object at family@linkinv(etamat, extra) else
fitted(object)
if (M > 1 && is.matrix(fv)) {
dimnames(fv) <- list(dimnames(fv)[[1]],
@@ -1276,7 +1276,7 @@ predict.qrrvglm <- function(object,
}
setMethod("predict", "qrrvglm", function(object, ...)
- predict.qrrvglm(object, ...))
+ predictqrrvglm(object, ...))
coefqrrvglm = function(object, matrix.out = FALSE,
label = TRUE) {
@@ -1688,7 +1688,7 @@ num.deriv.rrr <- function(fit, M, r, x1mat, x2mat,
fit at predictors = neweta
- newmu <- fit at family@inverse(neweta, fit at extra)
+ newmu <- fit at family@linkinv(neweta, fit at extra)
fit at fitted.values = as.matrix(newmu) # 20100909
fred = weights(fit, type = "w", deriv= TRUE, ignore.slot= TRUE)
@@ -2180,13 +2180,13 @@ lvplot.qrrvglm = function(object, varlvI = FALSE, reference = NULL,
stop("can only plot ellipses for intercept models only")
}
for(i in 1:ncol(r.curves)) {
- cutpoint = object at family@link( if (Absolute) ellipse.temp
+ cutpoint = object at family@linkfun( if (Absolute) ellipse.temp
else Coef.list at Maximum[i] * ellipse.temp,
extra=object at extra)
if (MSratio > 1)
cutpoint = cutpoint[1,1]
- cutpoint = object at family@link(Coef.list at Maximum[i],
+ cutpoint = object at family@linkfun(Coef.list at Maximum[i],
extra=object at extra) - cutpoint
if (is.finite(cutpoint) && cutpoint > 0) {
Mmat = diag(rep(ifelse(object at control$Crow1positive, 1, -1),
@@ -2841,7 +2841,7 @@ setMethod("model.matrix", "qrrvglm", function(object, ...)
-persp.qrrvglm = function(x, varlvI = FALSE, reference = NULL,
+perspqrrvglm = function(x, varlvI = FALSE, reference = NULL,
plot.it = TRUE,
xlim = NULL, ylim = NULL, zlim = NULL, # zlim ignored if Rank == 1
gridlength = if (Rank == 1) 301 else c(51,51),
@@ -2898,7 +2898,7 @@ persp.qrrvglm = function(x, varlvI = FALSE, reference = NULL,
LP = t(LP) # n by M
- fitvals = object at family@inverse(LP) # n by NOS
+ fitvals = object at family@linkinv(LP) # n by NOS
dimnames(fitvals) = list(NULL, dimnames(fv)[[2]])
sppNames = dimnames(object at y)[[2]]
if (!length(whichSpecies)) {
@@ -2956,9 +2956,17 @@ persp.qrrvglm = function(x, varlvI = FALSE, reference = NULL,
maxfitted = if (Rank == 2) maxfitted else NULL))
}
+
+
if (!isGeneric("persp"))
- setGeneric("persp", function(x, ...) standardGeneric("persp"))
-setMethod("persp", "qrrvglm", function(x, ...) persp.qrrvglm(x=x, ...))
+ setGeneric("persp", function(x, ...) standardGeneric("persp"),
+ package = "VGAM")
+
+setMethod("persp", "qrrvglm", function(x, ...) perspqrrvglm(x=x, ...))
+
+
+
+
diff --git a/R/family.survival.R b/R/family.survival.R
index af3fd7b..3783f28 100644
--- a/R/family.survival.R
+++ b/R/family.survival.R
@@ -70,7 +70,7 @@
.emu = emu, .esd = esd,
.imu = imu, .isd = isd,
.r1 = r1, .r2 = r2 ))),
- inverse = function(eta, extra = NULL) eta[,1],
+ linkinv = function(eta, extra = NULL) eta[,1],
last = eval(substitute(expression({
misc$link = c(mu = .lmu , sd = .lsd )
misc$earg = list(mu = .emu , sd = .esd )
@@ -80,7 +80,7 @@
}) , list( .lmu = lmu, .lsd = lsd,
.emu = emu, .esd = esd,
.r1 = r1, .r2 = r2 ))),
- loglikelihood=eval(substitute(
+ loglikelihood = eval(substitute(
function(mu, y, w, residuals = FALSE, eta, extra = NULL) {
sd = eta2theta(eta[, 2], .lsd, earg = .esd )
if (residuals) stop("loglikelihood residuals not ",
@@ -218,25 +218,27 @@ rbisa = function(n, shape, scale=1) {
lshape = as.character(substitute(lshape))
if (mode(lscale) != "character" && mode(lscale) != "name")
lscale = as.character(substitute(lscale))
+
if (length(ishape) && !is.Numeric(ishape, posit = TRUE))
stop("bad input for argument 'ishape'")
if (!is.Numeric(iscale, posit = TRUE))
stop("bad input for argument 'iscale'")
if (!is.Numeric(imethod, allow = 1, integ = TRUE, posit = TRUE) ||
imethod > 3)
- stop("imethod must be 1 or 2 or 3")
+ stop("argument 'imethod' must be 1 or 2 or 3")
+
if (!is.list(eshape)) eshape = list()
if (!is.list(escale)) escale = list()
new("vglmff",
- blurb=c("Birnbaum-Saunders distribution\n\n",
- "Links: ",
- namesof("shape", lshape, earg = eshape, tag = TRUE), "; ",
- namesof("scale", lscale, earg = escale, tag = TRUE)),
- constraints=eval(substitute(expression({
+ blurb = c("Birnbaum-Saunders distribution\n\n",
+ "Links: ",
+ namesof("shape", lshape, earg = eshape, tag = TRUE), "; ",
+ namesof("scale", lscale, earg = escale, tag = TRUE)),
+ constraints = eval(substitute(expression({
constraints = cm.zero.vgam(constraints, x, .zero, M)
}) , list( .zero = zero))),
- initialize=eval(substitute(expression({
+ initialize = eval(substitute(expression({
if (ncol(y <- cbind(y)) != 1)
stop("the response must be a vector or a one-column matrix")
predictors.names =
@@ -260,22 +262,22 @@ rbisa = function(n, shape, scale=1) {
theta2eta(scale.init, .lscale, earg = .escale))
}
}) , list( .lshape = lshape, .lscale = lscale,
- .ishape=ishape, .iscale=iscale,
+ .ishape = ishape, .iscale = iscale,
.eshape = eshape, .escale = escale,
.imethod=imethod ))),
- inverse=eval(substitute(function(eta, extra = NULL) {
+ linkinv = eval(substitute(function(eta, extra = NULL) {
sh = eta2theta(eta[,1], .lshape, earg = .eshape)
sc = eta2theta(eta[,2], .lscale, earg = .escale)
sc * (1 + sh^2 / 2)
}, list( .lshape = lshape, .lscale = lscale,
.eshape = eshape, .escale = escale ))),
- last=eval(substitute(expression({
+ last = eval(substitute(expression({
misc$link = c(shape= .lshape, scale= .lscale)
misc$earg = list(shape= .eshape, scale= .escale)
misc$expected = TRUE
}) , list( .lshape = lshape, .lscale = lscale,
.eshape = eshape, .escale = escale ))),
- loglikelihood=eval(substitute(
+ loglikelihood = eval(substitute(
function(mu,y,w,residuals= FALSE,eta, extra = NULL) {
sh = eta2theta(eta[,1], .lshape, earg = .eshape)
sc = eta2theta(eta[,2], .lscale, earg = .escale)
@@ -286,7 +288,7 @@ rbisa = function(n, shape, scale=1) {
} , list( .lshape = lshape, .lscale = lscale,
.eshape = eshape, .escale = escale ))),
vfamily=c("bisa"),
- deriv=eval(substitute(expression({
+ deriv = eval(substitute(expression({
sh = eta2theta(eta[,1], .lshape, earg = .eshape)
sc = eta2theta(eta[,2], .lscale, earg = .escale)
dl.dsh = ((y/sc - 2 + sc/y) / sh^2 - 1) / sh
@@ -298,7 +300,7 @@ rbisa = function(n, shape, scale=1) {
dl.dsc * dsc.deta)
}) , list( .lshape = lshape, .lscale = lscale,
.eshape = eshape, .escale = escale ))),
- weight=eval(substitute(expression({
+ weight = eval(substitute(expression({
wz = matrix(as.numeric(NA), n, M) # Diagonal!!
wz[,iam(1,1,M)] = 2 * dsh.deta^2 / sh^2
hfunction = function(alpha)
diff --git a/R/family.ts.R b/R/family.ts.R
index 677c220..a763903 100644
--- a/R/family.ts.R
+++ b/R/family.ts.R
@@ -14,11 +14,11 @@
rrar.Ak1 <- function(MM, coeffs, Ranks., aa) {
ptr <- 0
Ak1 <- diag(MM)
- for(j in 1:MM) {
+ for(jay in 1:MM) {
for(i in 1:MM) {
- if (i > j && (MM+1)-(Ranks.[j]-1) <= i) {
+ if (i > jay && (MM+1)-(Ranks.[jay]-1) <= i) {
ptr <- ptr + 1
- Ak1[i,j] <- coeffs[ptr]
+ Ak1[i,jay] <- coeffs[ptr]
}
}
}
@@ -26,11 +26,11 @@
Ak1
}
rrar.Di <- function(i, Ranks.) {
- if (Ranks.[1]==Ranks.[i]) diag(Ranks.[i]) else
+ if (Ranks.[1] == Ranks.[i]) diag(Ranks.[i]) else
rbind(diag(Ranks.[i]), matrix(0, Ranks.[1]-Ranks.[i], Ranks.[i]))
}
rrar.Mi <- function(i, MM, Ranks., ki) {
- if (Ranks.[ki[i]]==MM)
+ if (Ranks.[ki[i]] == MM)
return(NULL)
hi <- Ranks.[ki[i]] - Ranks.[ki[i+1]]
Ji <- matrix(0, hi, Ranks.[1])
@@ -120,14 +120,15 @@ rrar.control <- function(stepsize=0.5, save.weight=TRUE, ...)
rrar <- function(Ranks=1, coefstart=NULL)
{
lag.p <- length(Ranks)
+
new("vglmff",
- blurb=c("Nested reduced-rank vector autoregressive model AR(", lag.p,
+ blurb = c("Nested reduced-rank vector autoregressive model AR(", lag.p,
")\n\n",
"Link: ",
namesof("mu_t", "identity"),
", t = ", paste(paste(1:lag.p, coll=",", sep="")) ,
""),
- initialize=eval(substitute(expression({
+ initialize = eval(substitute(expression({
Ranks. <- .Ranks
plag <- length(Ranks.)
nn <- nrow(x) # original n
@@ -146,7 +147,7 @@ rrar <- function(Ranks=1, coefstart=NULL)
ki <- udsrank <- unique(dsrank)
uu <- length(udsrank)
for(i in 1:uu)
- ki[i] <- max((1:plag)[dsrank==udsrank[i]])
+ ki[i] <- max((1:plag)[dsrank == udsrank[i]])
ki <- c(ki, plag+1) # For computing a
Ranks. <- c(Ranks., 0) # For computing a
aa <- sum( (MM-Ranks.[ki[1:uu]]) * (Ranks.[ki[1:uu]]-Ranks.[ki[-1]]) )
@@ -162,7 +163,7 @@ rrar <- function(Ranks=1, coefstart=NULL)
new.coeffs <- .coefstart # Needed for iter=1 of $weight
new.coeffs <- if (length(new.coeffs))
- rep(new.coeffs, len=aa+sum(Ranks.)*MM) else
+ rep(new.coeffs, len = aa+sum(Ranks.)*MM) else
runif(aa+sum(Ranks.)*MM)
temp8 <- rrar.Wmat(y.save,Ranks.,MM,ki,plag,aa,uu,nn,new.coeffs)
X_vlm_save <- temp8$UU %*% temp8$Ht
@@ -185,7 +186,7 @@ rrar <- function(Ranks=1, coefstart=NULL)
w <- w[-indices]
n.save <- n <- nn - plag
}), list( .Ranks=Ranks, .coefstart=coefstart ))),
- inverse=function(eta, extra=NULL) {
+ linkinv=function(eta, extra=NULL) {
aa <- extra$aa
coeffs <- extra$coeffs
MM <- extra$MM
@@ -262,7 +263,7 @@ vglm.garma.control <- function(save.weight=TRUE, ...)
garma <- function(link="identity",
- earg=list(),
+ earg =list(),
p.ar.lag=1, q.lag.ma=0,
coefstart=NULL,
step=1.0)
@@ -278,13 +279,13 @@ garma <- function(link="identity",
if (!is.list(earg)) earg = list()
new("vglmff",
- blurb=c("GARMA(", p.ar.lag, ",", q.lag.ma, ")\n\n",
+ blurb = c("GARMA(", p.ar.lag, ",", q.lag.ma, ")\n\n",
"Link: ",
- namesof("mu_t", link, earg= earg),
+ namesof("mu_t", link, earg = earg),
", t = ", paste(paste(1:p.ar.lag, coll=",", sep=""))),
- initialize=eval(substitute(expression({
+ initialize = eval(substitute(expression({
plag <- .p.ar.lag
- predictors.names = namesof("mu", .link, earg= .earg, tag=FALSE)
+ predictors.names = namesof("mu", .link, earg = .earg, tag=FALSE)
indices <- 1:plag
tt <- (1+plag):nrow(x)
pp <- ncol(x)
@@ -304,8 +305,9 @@ garma <- function(link="identity",
w.save <- w # Save the original
new.coeffs <- .coefstart # Needed for iter=1 of @weight
- new.coeffs <- if (length(new.coeffs)) rep(new.coeffs, len=pp+plag) else
- c(runif(pp), rep(0, plag))
+ new.coeffs <- if (length(new.coeffs))
+ rep(new.coeffs, len = pp+plag) else
+ c(runif(pp), rep(0, plag))
if (!length(etastart)) {
etastart <- x[-indices,,drop=FALSE] %*% new.coeffs[1:pp]
}
@@ -324,16 +326,17 @@ garma <- function(link="identity",
for(i in 1:plag)
more[[i]] <- i + max(unlist(attr(x.save, "assign")))
attr(x, "assign") <- c(attr(x.save, "assign"), more)
- }), list( .link=link, .p.ar.lag=p.ar.lag, .coefstart=coefstart, .earg=earg ))),
- inverse=eval(substitute(function(eta, extra=NULL) {
- eta2theta(eta, link= .link, earg= .earg)
- }, list( .link=link, .earg=earg ))),
- last=eval(substitute(expression({
+ }), list( .link=link, .p.ar.lag=p.ar.lag,
+ .coefstart=coefstart, .earg = earg ))),
+ linkinv = eval(substitute(function(eta, extra=NULL) {
+ eta2theta(eta, link= .link, earg = .earg)
+ }, list( .link=link, .earg = earg ))),
+ last = eval(substitute(expression({
misc$link <- c(mu = .link)
misc$earg <- list(mu = .earg)
misc$plag <- plag
- }), list( .link=link, .earg=earg ))),
- loglikelihood=eval(substitute(
+ }), list( .link=link, .earg = earg ))),
+ loglikelihood = eval(substitute(
function(mu, y, w, residuals = FALSE, eta, extra=NULL) {
if (residuals) switch( .link,
identity=y-mu,
@@ -345,8 +348,8 @@ garma <- function(link="identity",
loge=sum(w*(-mu + y*log(mu))),
inverse=sum(w*(-mu + y*log(mu))),
sum(w*(y*log(mu) + (1-y)*log1p(-mu))))
- }, list( .link=link, .earg=earg ))),
- middle2=eval(substitute(expression({
+ }, list( .link=link, .earg = earg ))),
+ middle2 = eval(substitute(expression({
realfv <- fv
for(i in 1:plag) {
realfv <- realfv + old.coeffs[i+pp] *
@@ -354,30 +357,30 @@ garma <- function(link="identity",
}
true.eta <- realfv + offset
- mu <- family at inverse(true.eta, extra) # overwrite mu with correct one
- }), list( .link=link, .earg=earg ))),
- vfamily=c("garma", "vglmgam"),
- deriv=eval(substitute(expression({
+ mu <- family at linkinv(true.eta, extra) # overwrite mu with correct one
+ }), list( .link=link, .earg = earg ))),
+ vfamily = c("garma", "vglmgam"),
+ deriv = eval(substitute(expression({
dl.dmu <- switch( .link,
identity=y-mu,
loge=(y-mu)/mu,
inverse=(y-mu)/mu,
(y-mu) / (mu*(1-mu)))
- dmu.deta <- dtheta.deta(mu, .link, earg= .earg)
+ dmu.deta <- dtheta.deta(mu, .link, earg = .earg)
step <- .step # This is another method of adjusting step lengths
step * w * dl.dmu * dmu.deta
- }), list( .link=link, .step=step, .earg=earg ))),
- weight=eval(substitute(expression({
+ }), list( .link=link, .step=step, .earg = earg ))),
+ weight = eval(substitute(expression({
x[,1:pp] <- x.save[tt,1:pp] # Reinstate
for(i in 1:plag) {
- temp = theta2eta(y.save[tt-i], .link, earg= .earg)
+ temp = theta2eta(y.save[tt-i], .link, earg = .earg)
x[,1:pp] <- x[,1:pp] - x.save[tt-i,1:pp] * new.coeffs[i+pp]
x[,pp+i] <- temp - x.save[tt-i,1:pp,drop=FALSE] %*% new.coeffs[1:pp]
}
class(x)=if(is.R()) "matrix" else "model.matrix" # Added 27/2/02; 26/2/04
- if (iter==1)
+ if (iter == 1)
old.coeffs <- new.coeffs
X_vlm_save <- lm2vlm.model.matrix(x, Blist, xij=control$xij)
@@ -387,9 +390,9 @@ garma <- function(link="identity",
loge=mu,
inverse=mu^2,
mu*(1-mu))
- w * dtheta.deta(mu, link= .link, earg= .earg)^2 / vary
+ w * dtheta.deta(mu, link= .link, earg = .earg)^2 / vary
}), list( .link=link,
- .earg=earg ))))
+ .earg = earg ))))
}
diff --git a/R/family.univariate.R b/R/family.univariate.R
index 541b125..5871275 100644
--- a/R/family.univariate.R
+++ b/R/family.univariate.R
@@ -63,7 +63,7 @@ getMaxMin = function(vov, objfun, y, x, w, extraargs = NULL, maximize = TRUE,
" -1 < y < 1, -1 < theta < 1, nu > -1/2\n",
"Links: ",
namesof("theta", ltheta, earg = etheta), ", ",
- namesof("nu", lnu, earg = enu),
+ namesof("nu", lnu, earg = enu),
"\n",
"\n",
"Mean: nu*theta/(1+nu)"),
@@ -99,7 +99,7 @@ getMaxMin = function(vov, objfun, y, x, w, extraargs = NULL, maximize = TRUE,
}
}), list( .ltheta=ltheta, .lnu=lnu, .inu=inu, .itheta=itheta,
.etheta = etheta, .enu=enu ))),
- inverse = eval(substitute(function(eta, extra = NULL) {
+ linkinv = eval(substitute(function(eta, extra = NULL) {
Theta = eta2theta(eta[,1], .ltheta, earg = .etheta )
nu = eta2theta(eta[,2], .lnu, earg = .enu )
nu*Theta/(1+nu)
@@ -171,21 +171,24 @@ hzeta.control <- function(save.weight = TRUE, ...)
"Variance: (1-2^(1-alpha)) * zeta(alpha-1) - mean^2 if alpha>2"),
initialize = eval(substitute(expression({
y = as.numeric(y)
+
if (ncol(cbind(y)) != 1)
stop("response must be a vector or a one-column matrix")
if (any(y < 1))
stop("all y values must be in 1,2,3,....")
+
predictors.names = namesof("alpha", .link, earg = .earg, tag = FALSE)
+
if (!length(etastart)) {
a.init = if (length( .ialpha)) .ialpha else {
- if ((meany <- weighted.mean(y,w)) < 1.5) 3.0 else
+ if ((meany <- weighted.mean(y, w)) < 1.5) 3.0 else
if (meany < 2.5) 1.4 else 1.1
}
a.init = rep(a.init, length = n)
etastart = theta2eta(a.init, .link, earg = .earg )
}
}), list( .link = link, .earg = earg, .ialpha=ialpha ))),
- inverse = eval(substitute(function(eta, extra = NULL) {
+ linkinv = eval(substitute(function(eta, extra = NULL) {
alpha = eta2theta(eta, .link, earg = .earg )
mu = (1-2^(-alpha)) * zeta(alpha)
mu[alpha <= 1] = Inf
@@ -357,7 +360,7 @@ rhzeta = function(n, alpha)
theta2eta(phi.init, .lphi, earg = .ephi ))
}
}), list( .lphi = lphi, .ephi = ephi, .iphi=iphi ))),
- inverse = eval(substitute(function(eta, extra = NULL) {
+ linkinv = eval(substitute(function(eta, extra = NULL) {
M <- if (is.matrix(eta)) ncol(eta) else 1
temp <- cbind(exp(eta[,-M]), 1)
temp / as.vector(temp %*% rep(1, M))
@@ -494,7 +497,7 @@ rhzeta = function(n, alpha)
for(iii in 1:n) {
rrr <- 1:omega[iii] # A vector
PHI <- phi[iii]
- pYiM.ge.rrr <- 1 - pbetabin.ab(q=rrr-1, size=omega[iii],
+ pYiM.ge.rrr <- 1 - pbetabinom.ab(q=rrr-1, size=omega[iii],
shape1<-probs[iii,M]*(1/PHI-1),
shape2<-(1-probs[iii,M])*(1/PHI-1)) # A vector
denomM <- ((1-PHI)*probs[iii,M] + (rrr-1)*PHI)^2 # A vector
@@ -503,7 +506,7 @@ rhzeta = function(n, alpha)
sum(1 / (1 + (rrr-2)*PHI)^2)
for(jay in 1:(M-1)) {
denomj <- ((1-PHI)*probs[iii,jay] + (rrr-1)*PHI)^2
- pYij.ge.rrr <- 1 - pbetabin.ab(q=rrr-1, size=omega[iii],
+ pYij.ge.rrr <- 1 - pbetabinom.ab(q=rrr-1, size=omega[iii],
shape1<-probs[iii,jay]*(1/PHI-1),
shape2<-(1-probs[iii,jay])*(1/PHI-1))
wz[iii,iam(jay,jay,M)] <- wz[iii,iam(jay,jay,M)] +
@@ -524,7 +527,7 @@ rhzeta = function(n, alpha)
for(rrr in 1:maxomega) {
ind5 <- rrr <= omega
PHI <- phi[ind5]
- pYiM.ge.rrr <- 1 - pbetabin.ab(q=rrr-1, size=omega[ind5],
+ pYiM.ge.rrr <- 1 - pbetabinom.ab(q=rrr-1, size=omega[ind5],
shape1<-probs[ind5,M]*(1/PHI-1),
shape2<-(1-probs[ind5,M])*(1/PHI-1))
denomM <- ((1-PHI)*probs[ind5,M] + (rrr-1)*PHI)^2
@@ -533,7 +536,7 @@ rhzeta = function(n, alpha)
1 / (1 + (rrr-2)*PHI)^2
for(jay in 1:(M-1)) {
denomj <- ((1-PHI)*probs[ind5,jay] + (rrr-1)*PHI)^2
- pYij.ge.rrr <- 1 - pbetabin.ab(q=rrr-1, size=omega[ind5],
+ pYij.ge.rrr <- 1 - pbetabinom.ab(q=rrr-1, size=omega[ind5],
shape1<-probs[ind5,jay]*(1/PHI-1),
shape2<-(1-probs[ind5,jay])*(1/PHI-1))
wz[ind5,iam(jay,jay,M)] <- wz[ind5,iam(jay,jay,M)] +
@@ -609,7 +612,7 @@ dirmul.old = function(link = "loge", earg = list(), init.alpha = 0.01,
etastart = theta2eta(yy, .link, earg = .earg)
}
}), list( .link = link, .earg = earg, .init.alpha=init.alpha ))),
- inverse = eval(substitute(function(eta, extra = NULL) {
+ linkinv = eval(substitute(function(eta, extra = NULL) {
shape = eta2theta(eta, .link, earg = .earg)
M = if (is.matrix(eta)) ncol(eta) else 1
sumshape = as.vector(shape %*% rep(1, len = M))
@@ -715,14 +718,14 @@ rdiric = function(n, shape, dimension = NULL) {
etastart = theta2eta(yy, .link, earg = .earg )
}
}), list( .link = link, .earg = earg ))),
- inverse = eval(substitute(function(eta, extra = NULL) {
+ linkinv = eval(substitute(function(eta, extra = NULL) {
shape = eta2theta(eta, .link, earg = .earg )
M = if (is.matrix(eta)) ncol(eta) else 1
sumshape = rowSums(shape)
shape / sumshape
}, list( .link = link, .earg = earg ))),
last = eval(substitute(expression({
- misc$link = c(shape= .link)
+ misc$link = c(shape = .link)
temp.names = paste("shape", 1:M, sep = "")
misc$link = rep( .link, len = M)
names(misc$link) = temp.names
@@ -918,8 +921,8 @@ dzeta = function(x, p, log = FALSE)
if ( .link == "loglog") pp.init[pp.init <= 1] = 1.2
etastart = theta2eta(pp.init, .link, earg = .earg)
}
- }), list( .link = link, .earg = earg, .init.p=init.p ))),
- inverse = eval(substitute(function(eta, extra = NULL) {
+ }), list( .link = link, .earg = earg, .init.p = init.p ))),
+ linkinv = eval(substitute(function(eta, extra = NULL) {
ans <- pp <- eta2theta(eta, .link, earg = .earg)
ans[pp > 1] <- zeta(pp[pp > 1]) / zeta(pp[pp > 1] + 1)
ans[pp <= 1] <- NA
@@ -1077,7 +1080,7 @@ pzipf = function(q, N, s) {
etastart = theta2eta(ss.init, .link, earg = .earg)
}
}), list( .link = link, .earg = earg, .init.s = init.s, .N = N ))),
- inverse = eval(substitute(function(eta, extra = NULL) {
+ linkinv = eval(substitute(function(eta, extra = NULL) {
ss = eta2theta(eta, .link, earg = .earg)
gharmonic(extra$N, s=ss - 1) / gharmonic(extra$N, s=ss)
}, list( .link = link, .earg = earg ))),
@@ -1163,11 +1166,11 @@ cauchy.control <- function(save.weight = TRUE, ...)
if (!length(etastart)) {
loc.init = if (length( .ilocation)) .ilocation else {
- if ( .imethod == 2) median(rep(y,w)) else
+ if ( .imethod == 2) median(rep(y, w)) else
if ( .imethod == 3) y else {
cauchy2.Loglikfun = function(loc, y, x, w, extraargs) {
iprobs = .iprobs
- qy = quantile(rep(y,w), probs=iprobs)
+ qy = quantile(rep(y, w), probs=iprobs)
ztry = tan(pi*(iprobs-0.5))
btry = (qy - loc) / ztry
scal = median(btry, na.rm = TRUE)
@@ -1186,7 +1189,7 @@ cauchy.control <- function(save.weight = TRUE, ...)
sca.init = if (length( .iscale)) .iscale else {
iprobs = .iprobs
- qy = quantile(rep(y,w), probs=iprobs)
+ qy = quantile(rep(y, w), probs=iprobs)
ztry = tan(pi*(iprobs-0.5))
btry = (qy - loc.init[1]) / ztry
sca.init = median(btry, na.rm = TRUE)
@@ -1202,7 +1205,7 @@ cauchy.control <- function(save.weight = TRUE, ...)
}), list( .ilocation = ilocation, .elocation = elocation, .llocation = llocation,
.iscale = iscale, .escale = escale, .lscale = lscale,
.iprobs=iprobs, .imethod = imethod ))),
- inverse = eval(substitute(function(eta, extra = NULL) {
+ linkinv = eval(substitute(function(eta, extra = NULL) {
eta2theta(eta[,1], .llocation, earg = .elocation)
}, list( .llocation = llocation,
.elocation = elocation ))),
@@ -1302,7 +1305,7 @@ cauchy.control <- function(save.weight = TRUE, ...)
if (!length(etastart)) {
loc.init = if (length( .ilocation)) .ilocation else {
- if ( .imethod == 2) median(rep(y,w)) else
+ if ( .imethod == 2) median(rep(y, w)) else
if ( .imethod == 3) y else {
cauchy1.Loglikfun = function(loc, y, x, w, extraargs) {
scal = extraargs
@@ -1322,7 +1325,7 @@ cauchy.control <- function(save.weight = TRUE, ...)
}), list( .scale.arg=scale.arg, .ilocation = ilocation,
.elocation = elocation, .llocation = llocation,
.imethod = imethod ))),
- inverse = eval(substitute(function(eta, extra = NULL) {
+ linkinv = eval(substitute(function(eta, extra = NULL) {
eta2theta(eta, .llocation, earg = .elocation)
}, list( .llocation = llocation,
.elocation = elocation ))),
@@ -1338,7 +1341,7 @@ cauchy.control <- function(save.weight = TRUE, ...)
location = eta2theta(eta, .llocation, earg = .elocation)
if (residuals) stop("loglikelihood residuals not ",
"implemented yet") else {
- sum(w * dcauchy(x = y, loc=location, scale= .scale.arg, log = TRUE))
+ sum(w * dcauchy(x = y, loc=location, scale = .scale.arg, log = TRUE))
}
}, list( .scale.arg=scale.arg, .elocation = elocation,
.llocation = llocation ))),
@@ -1394,7 +1397,7 @@ cauchy.control <- function(save.weight = TRUE, ...)
}
}), list( .imethod = imethod, .llocation = llocation,
.elocation = elocation ))),
- inverse = eval(substitute(function(eta, extra = NULL) {
+ linkinv = eval(substitute(function(eta, extra = NULL) {
eta2theta(eta, .llocation, earg = .elocation)
}, list( .llocation = llocation,
.elocation = elocation ))),
@@ -1472,7 +1475,7 @@ cauchy.control <- function(save.weight = TRUE, ...)
}
}), list( .link = link, .earg = earg,
.shape.arg=shape.arg, .imethod = imethod ))),
- inverse = eval(substitute(function(eta, extra = NULL) {
+ linkinv = eval(substitute(function(eta, extra = NULL) {
sc = eta2theta(eta, .link, earg = .earg)
.shape.arg * sc
}, list( .link = link, .earg = earg, .shape.arg=shape.arg ))),
@@ -1520,10 +1523,10 @@ dbort = function(x, Qsize = 1, a=0.5, log = FALSE) {
if (!is.Numeric(a, posit = TRUE) || max(a) >= 1)
stop("bad input for argument 'a'")
N = max(length(x), length(Qsize), length(a))
- x = rep(x, len=N); Qsize = rep(Qsize, len=N); a = rep(a, len=N);
+ x = rep(x, len = N); Qsize = rep(Qsize, len = N); a = rep(a, len = N);
xok = (x >= Qsize) & (x == round(x)) & (a > 0) & (a < 1)
- ans = rep(if (log.arg) log(0) else 0, len=N) # loglikelihood
+ ans = rep(if (log.arg) log(0) else 0, len = N) # loglikelihood
ans[xok] = lgamma(1 + Qsize[xok]) - lgamma(x[xok] + 1 - Qsize[xok]) +
(x[xok] - 1 - Qsize[xok]) * log(x[xok]) +
(x[xok] - Qsize[xok]) * log(a[xok]) - a[xok] * x[xok]
@@ -1542,7 +1545,7 @@ rbort = function(n, Qsize = 1, a=0.5) {
if (!is.Numeric(a, posit = TRUE) || max(a) >= 1)
stop("bad input for argument 'a'")
N = n
- qsize = rep(Qsize, len=N); a = rep(a, len=N)
+ qsize = rep(Qsize, len = N); a = rep(a, len = N)
totqsize = qsize
fini = (qsize < 1)
while(any(!fini)) {
@@ -1587,14 +1590,14 @@ rbort = function(n, Qsize = 1, a=0.5) {
if (!length(etastart)) {
a.init = switch(as.character( .imethod ),
"1" = 1 - .Qsize / (y+1/8),
- "2" = rep(1 - .Qsize / weighted.mean(y,w), len = n),
+ "2" = rep(1 - .Qsize / weighted.mean(y, w), len = n),
"3" = rep(1 - .Qsize / median(y), len = n),
"4" = rep(0.5, len = n))
etastart = theta2eta(a.init, .link, earg = .earg)
}
}), list( .link = link, .earg = earg, .Qsize=Qsize,
.imethod = imethod ))),
- inverse = eval(substitute(function(eta, extra = NULL) {
+ linkinv = eval(substitute(function(eta, extra = NULL) {
a = eta2theta(eta, .link, earg = .earg)
.Qsize / (1 - a)
}, list( .link = link, .earg = earg, .Qsize=Qsize ))),
@@ -1636,10 +1639,10 @@ dfelix = function(x, a=0.25, log = FALSE) {
if (!is.Numeric(x)) stop("bad input for argument 'x'")
if (!is.Numeric(a, posit = TRUE)) stop("bad input for argument 'a'")
N = max(length(x), length(a))
- x = rep(x, len=N); a = rep(a, len=N);
+ x = rep(x, len = N); a = rep(a, len = N);
xok = (x %% 2 == 1) & (x == round(x)) & (x >= 1) & (a > 0) & (a < 0.5)
- ans = rep(if (log.arg) log(0) else 0, len=N) # loglikelihood
+ ans = rep(if (log.arg) log(0) else 0, len = N) # loglikelihood
ans[xok] = ((x[xok]-3)/2) * log(x[xok]) + ((x[xok]-1)/2) * log(a[xok]) -
lgamma(x[xok]/2 + 0.5) - a[xok] * x[xok]
if (!log.arg) {
@@ -1675,7 +1678,7 @@ dfelix = function(x, a=0.25, log = FALSE) {
predictors.names = namesof("a", .link, earg = .earg, tag = FALSE)
if (!length(etastart)) {
- wymean = weighted.mean(y,w)
+ wymean = weighted.mean(y, w)
a.init = switch(as.character( .imethod ),
"1" = (y-1+1/8) / (2*(y+1/8)+1/8),
"2" = rep((wymean-1+1/8) / (2*(wymean+1/8)+1/8), len = n),
@@ -1685,7 +1688,7 @@ dfelix = function(x, a=0.25, log = FALSE) {
}
}), list( .link = link, .earg = earg,
.imethod = imethod ))),
- inverse = eval(substitute(function(eta, extra = NULL) {
+ linkinv = eval(substitute(function(eta, extra = NULL) {
a = eta2theta(eta, .link, earg = .earg)
1 / (1 - 2*a)
}, list( .link = link, .earg = earg ))),
@@ -1773,8 +1776,8 @@ dfelix = function(x, a=0.25, log = FALSE) {
namesof("phi", .lphi, .ephi, short = TRUE))
if (!length(etastart)) {
mu.init = if (is.Numeric( .imu)) .imu else
- {if ( .imethod == 1) weighted.mean(y,w) else
- median(rep(y,w))}
+ {if ( .imethod == 1) weighted.mean(y, w) else
+ median(rep(y, w))}
mu1.init = (mu.init - .A) / ( .B - .A) # In (0,1)
phi.init = if (is.Numeric( .iphi)) .iphi else
max(0.01, -1 + ( .B-.A)^2 * mu1.init*(1-mu1.init)/var(y))
@@ -1784,7 +1787,7 @@ dfelix = function(x, a=0.25, log = FALSE) {
}
}), list( .lmu = lmu, .lphi = lphi, .imu=imu, .iphi=iphi,
.A = A, .B = B, .emu = emu, .ephi = ephi, .imethod = imethod ))),
- inverse = eval(substitute(function(eta, extra = NULL) {
+ linkinv = eval(substitute(function(eta, extra = NULL) {
mu = eta2theta(eta[,1], .lmu, .emu )
mu
}, list( .lmu = lmu, .emu = emu, .A = A, .B = B))),
@@ -1919,7 +1922,7 @@ dfelix = function(x, a=0.25, log = FALSE) {
}), list( .lshape1 = lshape1, .lshape2 = lshape2,
.i1 = i1, .i2 = i2, .trim = trim, .A = A, .B = B,
.eshape1 = eshape1, .eshape2 = eshape2 ))),
- inverse = eval(substitute(function(eta, extra = NULL) {
+ linkinv = eval(substitute(function(eta, extra = NULL) {
shapes = cbind(eta2theta(eta[,1], .lshape1, earg = .eshape1 ),
eta2theta(eta[,2], .lshape2, earg = .eshape2 ))
.A + ( .B-.A) * shapes[,1] / (shapes[,1] + shapes[,2])
@@ -2008,7 +2011,7 @@ dfelix = function(x, a=0.25, log = FALSE) {
B = if (length( .iB)) .iB else max(y)+my.range/70)
}
}), list( .i1=i1, .i2=i2, .iA=iA, .iB=iB, .link = link, .earg = earg ))),
- inverse = eval(substitute(function(eta, extra = NULL) {
+ linkinv = eval(substitute(function(eta, extra = NULL) {
shapes = eta2theta(eta[,1:2], .link, earg = .earg)
.A = eta[,3]
.B = eta[,4]
@@ -2097,9 +2100,9 @@ dfelix = function(x, a=0.25, log = FALSE) {
predictors.names = "log(rate)"
mustart = y + (y == 0) / 8
}),
- inverse=function(eta, extra = NULL)
+ linkinv = function(eta, extra = NULL)
exp(-eta),
- link=function(mu, extra = NULL)
+ link = function(mu, extra = NULL)
-log(mu),
vfamily = "simple.exponential",
deriv=expression({
@@ -2153,7 +2156,7 @@ dfelix = function(x, a=0.25, log = FALSE) {
if (ncol(cbind(y)) != 1)
stop("response must be a vector or a one-column matrix")
- extra$loc <- .location # Passed into, e.g., @link, @deriv etc.
+ extra$loc <- .location # Passed into, e.g., @linkfun, @deriv etc.
if (any(y <= extra$loc))
stop("all responses must be greater than ", extra$loc)
@@ -2166,7 +2169,7 @@ dfelix = function(x, a=0.25, log = FALSE) {
etastart <- theta2eta(1 / (mustart - extra$loc),
.link, earg = .earg)
}), list( .location = location, .link = link, .earg = earg ))),
- inverse = eval(substitute(function(eta, extra = NULL)
+ linkinv = eval(substitute(function(eta, extra = NULL)
extra$loc + 1 / eta2theta(eta, .link, earg = .earg),
list( .link = link, .earg = earg ))),
last = eval(substitute(expression({
@@ -2175,7 +2178,7 @@ dfelix = function(x, a=0.25, log = FALSE) {
misc$earg <- list(rate = .earg)
misc$expected <- .expected
}), list( .link = link, .earg = earg, .expected = expected ))),
- link = eval(substitute(function(mu, extra = NULL)
+ linkfun = eval(substitute(function(mu, extra = NULL)
theta2eta(1 / (mu - extra$loc), .link, earg = .earg),
list( .link = link, .earg = earg ))),
vfamily = c("exponential"),
@@ -2221,7 +2224,7 @@ dfelix = function(x, a=0.25, log = FALSE) {
if (!length(etastart))
etastart = cbind(theta2eta(y + 1/8, .link, earg = .earg ))
}), list( .link = link, .earg = earg ))),
- inverse = eval(substitute(function(eta, extra = NULL)
+ linkinv = eval(substitute(function(eta, extra = NULL)
eta2theta(eta, .link, earg = .earg)),
list( .link = link, .earg = earg )),
last = eval(substitute(expression({
@@ -2233,7 +2236,7 @@ dfelix = function(x, a=0.25, log = FALSE) {
for(ii in 1:M) misc$earg[[ii]] = .earg
misc$expected = TRUE
}), list( .link = link, .earg = earg ))),
- link = eval(substitute(function(mu, extra = NULL)
+ linkfun = eval(substitute(function(mu, extra = NULL)
theta2eta(mu, .link, earg = .earg)),
list( .link = link, .earg = earg )),
loglikelihood= function(mu, y, w, residuals = FALSE, eta, extra = NULL)
@@ -2309,7 +2312,7 @@ dfelix = function(x, a=0.25, log = FALSE) {
}
}), list( .lrate = lrate, .lshape = lshape, .irate=irate, .ishape = ishape,
.erate = erate, .eshape = eshape ))),
- inverse = eval(substitute(function(eta, extra = NULL) {
+ linkinv = eval(substitute(function(eta, extra = NULL) {
eta2theta(eta[,2], .lshape, earg = .eshape) / eta2theta(eta[,1], .lrate,
earg = .erate)
}, list( .lrate = lrate, .lshape = lshape,
@@ -2446,7 +2449,7 @@ dfelix = function(x, a=0.25, log = FALSE) {
}), list( .lmu = lmu, .lshape = lshape, .ishape = ishape, .zero = zero,
.emu = emu, .eshape = eshape,
.imethod = imethod ))),
- inverse = eval(substitute(function(eta, extra = NULL) {
+ linkinv = eval(substitute(function(eta, extra = NULL) {
Musual <- 2
NOS = ncol(eta) / Musual
eta2theta(eta[, 2*(1:NOS)-1, drop = FALSE], .lmu, earg = .emu )
@@ -2471,7 +2474,7 @@ dfelix = function(x, a=0.25, log = FALSE) {
misc$expected = TRUE
}), list( .lmu = lmu, .lshape = lshape,
.emu = emu, .eshape = eshape ))),
- link = eval(substitute(function(mu, extra = NULL) {
+ linkfun = eval(substitute(function(mu, extra = NULL) {
temp = theta2eta(mu, .lmu, earg = .emu )
temp = cbind(temp, NA * temp)
temp[,interleave.VGAM(ncol(temp), M = 2), drop = FALSE]
@@ -2541,74 +2544,90 @@ dfelix = function(x, a=0.25, log = FALSE) {
- geometric =function(link = "logit", earg = list(), expected = TRUE,
- imethod= 1)
+ geometric = function(link = "logit", earg = list(), expected = TRUE,
+ imethod = 1)
{
- if (!is.logical(expected) || length(expected) != 1)
- stop("bad input for argument 'expected'")
- if (mode(link) != "character" && mode(link) != "name")
- link = as.character(substitute(link))
- if (!is.list(earg)) earg = list()
- if (!is.Numeric(imethod, allow = 1, integ = TRUE, posit = TRUE) ||
- imethod > 3)
- stop("argument 'imethod' must be 1 or 2 or 3")
- new("vglmff",
- blurb = c("Geometric distribution (P[Y=y] = prob*(1-prob)^y, y=0,1,2,...)\n",
+ if (!is.logical(expected) || length(expected) != 1)
+ stop("bad input for argument 'expected'")
+ if (mode(link) != "character" && mode(link) != "name")
+ link = as.character(substitute(link))
+
+ if (!is.list(earg)) earg = list()
+
+ if (!is.Numeric(imethod, allow = 1, integ = TRUE, posit = TRUE) ||
+ imethod > 3)
+ stop("argument 'imethod' must be 1 or 2 or 3")
+
+
+ new("vglmff",
+ blurb = c("Geometric distribution ",
+ "(P[Y=y] = prob * (1 - prob)^y, y = 0, 1, 2,...)\n",
"Link: ",
namesof("prob", link, earg = earg), "\n",
- "Mean: mu = (1-prob)/prob\n",
- "Variance: mu*(1+mu) = (1-prob)/prob^2"),
- initialize = eval(substitute(expression({
- if (ncol(cbind(y)) != 1)
- stop("response must be a vector or a 1-column matrix")
- if (any(y < 0)) stop("all responses must be >= 0")
- if (any(y!=round(y ))) stop("response should be integer-valued")
- predictors.names = namesof("prob", .link, earg = .earg, tag = FALSE)
- if (!length(etastart)) {
- prob.init = if ( .imethod == 3)
- 1 / (1 + y + 1/16) else
- if ( .imethod == 1)
- 1 / (1 + median(rep(y,w)) + 1/16) else
- 1 / (1 + weighted.mean(y,w) + 1/16)
- etastart = theta2eta(prob.init, .link, earg = .earg)
- }
- }), list( .link = link, .earg = earg, .imethod = imethod ))),
- inverse = eval(substitute(function(eta, extra = NULL) {
- prob = eta2theta(eta, .link, earg = .earg)
- (1-prob)/prob
- }, list( .link = link, .earg = earg ))),
- last = eval(substitute(expression({
- misc$link = c(prob = .link)
- misc$earg = list(prob = .earg )
- misc$expected = .expected
- misc$imethod = .imethod
- }), list( .link = link, .earg = earg, .expected = expected, .imethod = imethod ))),
- loglikelihood = eval(substitute(
- function(mu, y, w, residuals = FALSE, eta, extra = NULL) {
- prob = eta2theta(eta, .link, earg = .earg)
- if (residuals) stop("loglikelihood residuals not ",
- "implemented yet") else {
- sum(w * dgeom(x = y, prob=prob, log = TRUE))
- }
- }, list( .link = link, .earg = earg ))),
- vfamily = c("geometric"),
- deriv = eval(substitute(expression({
- prob = eta2theta(eta, .link, earg = .earg)
- dl.dprob = -y/(1-prob) + 1/prob
- dprobdeta = dtheta.deta(prob, .link, earg = .earg)
- c(w) * cbind(dl.dprob * dprobdeta)
- }), list( .link = link, .earg = earg, .expected = expected ))),
- weight = eval(substitute(expression({
- ed2l.dprob2 = if ( .expected ) 1 / (prob^2 * (1-prob)) else
- y / (1-prob)^2 + 1 / prob^2
- wz = ed2l.dprob2 * dprobdeta^2
- if ( !( .expected )) wz = wz - dl.dprob * d2theta.deta2(prob, .link, earg = .earg)
- c(w) * wz
- }), list( .link = link, .earg = earg, .expected = expected ))))
+ "Mean: mu = (1 - prob) / prob\n",
+ "Variance: mu * (1 + mu) = (1 - prob) / prob^2"),
+ initialize = eval(substitute(expression({
+ if (ncol(cbind(y)) != 1)
+ stop("response must be a vector or a 1-column matrix")
+
+ if (any(y < 0)) stop("all responses must be >= 0")
+ if (any(y!=round(y ))) stop("response should be integer-valued")
+
+ predictors.names = namesof("prob", .link, earg = .earg, tag = FALSE)
+
+ if (!length(etastart)) {
+ prob.init = if ( .imethod == 3)
+ 1 / (1 + y + 1/16) else
+ if ( .imethod == 1)
+ 1 / (1 + median(rep(y, w)) + 1/16) else
+ 1 / (1 + weighted.mean(y, w) + 1/16)
+ etastart = theta2eta(prob.init, .link, earg = .earg)
+ }
+ }), list( .link = link, .earg = earg, .imethod = imethod ))),
+ linkinv = eval(substitute(function(eta, extra = NULL) {
+ prob = eta2theta(eta, .link, earg = .earg)
+ (1 - prob) / prob
+ }, list( .link = link, .earg = earg ))),
+ last = eval(substitute(expression({
+ misc$link = c(prob = .link)
+ misc$earg = list(prob = .earg )
+ misc$expected = .expected
+ misc$imethod = .imethod
+ }), list( .link = link, .earg = earg,
+ .expected = expected, .imethod = imethod ))),
+ loglikelihood = eval(substitute(
+ function(mu, y, w, residuals = FALSE, eta, extra = NULL) {
+ prob = eta2theta(eta, .link, earg = .earg)
+ if (residuals) stop("loglikelihood residuals not ",
+ "implemented yet") else {
+ sum(w * dgeom(x = y, prob = prob, log = TRUE))
+ }
+ }, list( .link = link, .earg = earg ))),
+ vfamily = c("geometric"),
+ deriv = eval(substitute(expression({
+ prob = eta2theta(eta, .link, earg = .earg)
+ dl.dprob = -y / (1-prob) + 1/prob
+ dprobdeta = dtheta.deta(prob, .link, earg = .earg)
+ c(w) * cbind(dl.dprob * dprobdeta)
+ }), list( .link = link, .earg = earg, .expected = expected ))),
+ weight = eval(substitute(expression({
+ ed2l.dprob2 = if ( .expected ) {
+ 1 / (prob^2 * (1 - prob))
+ } else {
+ y / (1 - prob)^2 + 1 / prob^2
+ }
+ wz = ed2l.dprob2 * dprobdeta^2
+ if ( !( .expected ))
+ wz = wz - dl.dprob * d2theta.deta2(prob, .link, earg = .earg)
+ c(w) * wz
+ }), list( .link = link, .earg = earg,
+ .expected = expected ))))
}
+
+
dbetageom = function(x, shape1, shape2, log = FALSE) {
if (!is.logical(log.arg <- log))
stop("bad input for argument 'log'")
@@ -2618,7 +2637,7 @@ dbetageom = function(x, shape1, shape2, log = FALSE) {
if (!is.Numeric(shape1, pos = TRUE)) stop("bad input for argument 'shape1'")
if (!is.Numeric(shape2, pos = TRUE)) stop("bad input for argument 'shape2'")
N = max(length(x), length(shape1), length(shape2))
- x = rep(x, len=N); shape1 = rep(shape1, len=N); shape2 = rep(shape2, len=N)
+ x = rep(x, len = N); shape1 = rep(shape1, len = N); shape2 = rep(shape2, len = N)
loglik = lbeta(1+shape1, shape2+abs(x)) - lbeta(shape1, shape2)
xok = (x == round(x) & x >= 0)
loglik[!xok] = log(0)
@@ -2635,7 +2654,7 @@ pbetageom = function(q, shape1, shape2, log.p = FALSE) {
if (!is.Numeric(shape1, pos = TRUE)) stop("bad input for argument 'shape1'")
if (!is.Numeric(shape2, pos = TRUE)) stop("bad input for argument 'shape2'")
N = max(length(q), length(shape1), length(shape2))
- q = rep(q, len=N); shape1 = rep(shape1, len=N); shape2 = rep(shape2, len=N)
+ q = rep(q, len = N); shape1 = rep(shape1, len = N); shape2 = rep(shape2, len = N)
ans = q * 0 # Retains names(q)
if (max(abs(shape1-shape1[1])) < 1.0e-08 &&
max(abs(shape2-shape2[1])) < 1.0e-08) {
@@ -2777,14 +2796,14 @@ negbinomial.control <- function(save.weight = TRUE, ...)
stop("integer-values only allowed for the 'negbinomial' family")
y = as.matrix(y)
- M = 2 * ncol(y)
+ M = Musual * ncol(y)
NOS = ncoly = ncol(y) # Number of species
predictors.names =
- c(namesof(if (NOS == 1) "mu" else paste("mu", 1:NOS, sep = ""),
+ c(namesof(if (NOS == 1) "mu" else paste("mu", 1:NOS, sep = ""),
.lmuuu, earg = .emuuu, tag = FALSE),
namesof(if (NOS == 1) "size" else paste("size", 1:NOS, sep = ""),
.lsize, earg = .esize, tag = FALSE))
- predictors.names = predictors.names[interleave.VGAM(M, M = 2)]
+ predictors.names = predictors.names[interleave.VGAM(M, M = Musual)]
if (is.null( .nsimEIM )) {
save.weight <- control$save.weight <- FALSE
@@ -2809,8 +2828,8 @@ negbinomial.control <- function(save.weight = TRUE, ...)
} else {
medabsres = median(abs(y[, iii] - use.this)) + 1/32
allowfun = function(z, maxtol=1) sign(z)*pmin(abs(z), maxtol)
- mu.init[, iii] = use.this + (1 - .sinit) * allowfun(y[, iii] -
- use.this, maxtol=medabsres)
+ mu.init[, iii] = use.this + (1 - .sinit) *
+ allowfun(y[, iii] - use.this, maxtol = medabsres)
mu.init[, iii] = abs(mu.init[, iii]) + 1 / 1024
}
@@ -2830,12 +2849,12 @@ negbinomial.control <- function(save.weight = TRUE, ...)
kay.init[,spp.] = getMaxMin(k.grid,
objfun=negbinomial.Loglikfun,
y = y[,spp.], x = x, w = w,
- extraargs= mu.init[,spp.])
+ extraargs= mu.init[, spp.])
}
}
- etastart = cbind(theta2eta(mu.init, .lmuuu, earg = .emuuu),
- theta2eta(kay.init, .lsize, earg = .esize))
- etastart = etastart[,interleave.VGAM(M, M = 2), drop = FALSE]
+ etastart = cbind(theta2eta(mu.init, link = .lmuuu, earg = .emuuu),
+ theta2eta(kay.init, link = .lsize, earg = .esize))
+ etastart = etastart[, interleave.VGAM(M, M = Musual), drop = FALSE]
}
}), list( .lmuuu = lmuuu, .lsize = lsize,
.emuuu = emuuu, .esize = esize,
@@ -2843,12 +2862,15 @@ negbinomial.control <- function(save.weight = TRUE, ...)
.k.init = isize, .quantile.probs = quantile.probs,
.sinit = shrinkage.init, .nsimEIM = nsimEIM,
.zero = zero, .imethod = imethod ))),
- inverse = eval(substitute(function(eta, extra = NULL) {
- NOS = ncol(eta) / 2
+
+ linkinv = eval(substitute(function(eta, extra = NULL) {
+ Musual <- 2
+ NOS = ncol(eta) / Musual
eta2theta(eta[, 2*(1:NOS)-1, drop = FALSE],
.lmuuu, earg = .emuuu)
}, list( .lmuuu = lmuuu, .emuuu = emuuu,
.esize = esize ))),
+
last = eval(substitute(expression({
if (exists("CQO.FastAlgorithm", envir = VGAM:::VGAMenv))
rm("CQO.FastAlgorithm", envir = VGAM:::VGAMenv)
@@ -2878,7 +2900,7 @@ negbinomial.control <- function(save.weight = TRUE, ...)
.nsimEIM = nsimEIM,
.sinit = shrinkage.init,
.imethod = imethod ))),
- link = eval(substitute(function(mu, extra = NULL) {
+ linkfun = eval(substitute(function(mu, extra = NULL) {
temp = theta2eta(mu, .lmuuu, earg = .emuuu)
kayy = theta2eta(if (is.numeric( .isize)) .isize else 1.0,
.lsize, earg = .esize)
@@ -2953,7 +2975,7 @@ negbinomial.control <- function(save.weight = TRUE, ...)
wz[, 2*(1:NOS)] = wz[, 2*(1:NOS)] * dk.deta^2
}
- ed2l.dmu2 = 1/mu - 1/(mu+kmat)
+ ed2l.dmu2 = 1 / mu - 1 / (mu+kmat)
wz[, 2*(1:NOS)-1] = dmu.deta^2 * ed2l.dmu2
c(w) * wz
}), list( .cutoff = cutoff, .Maxiter = Maxiter,
@@ -2964,7 +2986,7 @@ negbinomial.control <- function(save.weight = TRUE, ...)
if (deviance.arg) ans at deviance = eval(substitute(
function(mu, y, w, residuals = FALSE, eta, extra = NULL) {
NOS = ncol(eta) / 2
- temp300 = eta[,2*(1:NOS), drop = FALSE]
+ temp300 = eta[, 2*(1:NOS), drop = FALSE]
if ( .lsize == "loge") {
bigval = 28
temp300[temp300 > bigval] = bigval
@@ -2972,9 +2994,11 @@ negbinomial.control <- function(save.weight = TRUE, ...)
} else stop("can only handle the 'loge' link")
k = eta2theta(temp300, .lsize, earg = .esize)
devi = 2 * (y*log(ifelse(y < 1, 1, y)/mu) + (y+k)*log((mu+k)/(k+y)))
- if (residuals)
- sign(y - mu) * sqrt(abs(devi) * w) else
+ if (residuals) {
+ sign(y - mu) * sqrt(abs(devi) * w)
+ } else {
sum(w * devi)
+ }
}, list( .lsize = lsize, .emu = emu, .esize = esize )))
ans
@@ -3144,7 +3168,7 @@ polya.control <- function(save.weight = TRUE, ...)
.quantile.probs = quantile.probs,
.sinit = shrinkage.init, .nsimEIM = nsimEIM, .zero = zero,
.imethod = imethod ))),
- inverse = eval(substitute(function(eta, extra = NULL) {
+ linkinv = eval(substitute(function(eta, extra = NULL) {
Musual = 2
NOS = ncol(eta) / Musual
pmat = eta2theta(eta[, Musual*(1:NOS) - 1, drop = FALSE],
@@ -3325,13 +3349,13 @@ polya.control <- function(save.weight = TRUE, ...)
if (!length(etastart))
etastart = log(mu)
}),
- inverse=function(eta, extra = NULL)
+ linkinv = function(eta, extra = NULL)
exp(eta),
last = expression({
misc$link = c(lambda = "loge")
misc$earg = list(lambda = list())
}),
- link=function(mu, extra = NULL)
+ link = function(mu, extra = NULL)
log(mu),
vfamily = "simple.poisson",
deriv=expression({
@@ -3418,7 +3442,7 @@ polya.control <- function(save.weight = TRUE, ...)
}
}), list( .ldof = ldof, .edof = edof, .idof = idof,
.tol1 = tol1, .imethod = imethod ))),
- inverse = eval(substitute(function(eta, extra = NULL) {
+ linkinv = eval(substitute(function(eta, extra = NULL) {
Dof <- eta2theta(eta, .ldof, earg = .edof)
ans <- 0 * eta
ans[Dof <= 1] <- NA
@@ -3606,7 +3630,7 @@ polya.control <- function(save.weight = TRUE, ...)
.lsca = lsca, .esca = esca, .isca = isca,
.ldof = ldof, .edof = edof, .idof = idof,
.imethod = imethod ))),
- inverse = eval(substitute(function(eta, extra = NULL) {
+ linkinv = eval(substitute(function(eta, extra = NULL) {
NOS <- extra$NOS
Musual <- extra$Musual
Loc <- eta2theta(eta[, Musual*(1:NOS)-2], .lloc, earg = .eloc)
@@ -3832,7 +3856,7 @@ polya.control <- function(save.weight = TRUE, ...)
.lsca = lsca, .esca = esca, .isca = isca,
.doff = doff,
.imethod = imethod ))),
- inverse = eval(substitute(function(eta, extra = NULL) {
+ linkinv = eval(substitute(function(eta, extra = NULL) {
NOS <- extra$NOS
Musual <- extra$Musual
Loc <- eta2theta(eta[, Musual*(1:NOS) - 1], .lloc, earg = .eloc)
@@ -3954,14 +3978,14 @@ polya.control <- function(save.weight = TRUE, ...)
if (!length(mustart) && !length(etastart))
mustart <- y + (1 / 8) * (y == 0)
}), list( .link = link, .earg = earg ))),
- inverse = eval(substitute(function(eta, extra = NULL) {
+ linkinv = eval(substitute(function(eta, extra = NULL) {
eta2theta(eta, .link, earg = .earg)
}, list( .link = link, .earg = earg ))),
last = eval(substitute(expression({
misc$link <- c(df = .link)
misc$earg <- list(df = .earg )
}), list( .link = link, .earg = earg ))),
- link = eval(substitute(function(mu, extra = NULL) {
+ linkfun = eval(substitute(function(mu, extra = NULL) {
theta2eta(mu, .link, earg = .earg)
}, list( .link = link, .earg = earg ))),
loglikelihood = eval(substitute(
@@ -4134,7 +4158,7 @@ rsimplex = function(n, mu = 0.5, dispersion = 1) {
.emu = emu, .esigma = esigma,
.imu = imu, .isigma = isigma,
.sinit = shrinkage.init, .imethod = imethod ))),
- inverse = eval(substitute(function(eta, extra = NULL) {
+ linkinv = eval(substitute(function(eta, extra = NULL) {
eta2theta(eta[,1], .lmu, earg = .emu)
}, list( .lmu = lmu, .emu = emu ))),
last = eval(substitute(expression({
@@ -4231,14 +4255,14 @@ rsimplex = function(n, mu = 0.5, dispersion = 1) {
}), list( .lmu = lmu, .llambda = llambda,
.emu = emu, .elambda = elambda,
.imu=imu, .ilambda=ilambda ))),
- inverse = eval(substitute(function(eta, extra = NULL) {
+ linkinv = eval(substitute(function(eta, extra = NULL) {
eta2theta(eta[,1], .lmu, earg = .emu)
}, list( .lmu = lmu,
.emu = emu, .elambda = elambda ))),
last = eval(substitute(expression({
misc$d3 = d3 # because save.weights = FALSE
- misc$link = c(mu= .lmu, lambda= .llambda)
- misc$earg = list(mu= .emu, lambda= .elambda)
+ misc$link = c(mu= .lmu, lambda = .llambda)
+ misc$earg = list(mu= .emu, lambda = .elambda)
misc$pooled.weight = pooled.weight
}), list( .lmu = lmu, .llambda = llambda,
.emu = emu, .elambda = elambda ))),
@@ -4328,13 +4352,13 @@ rsimplex = function(n, mu = 0.5, dispersion = 1) {
}
}), list( .link.theta = link.theta, .earg = earg,
.init.theta=init.theta ))),
- inverse = eval(substitute(function(eta, extra = NULL) {
+ linkinv = eval(substitute(function(eta, extra = NULL) {
theta = eta2theta(eta, .link.theta, earg = .earg)
tan(theta)
}, list( .link.theta = link.theta, .earg = earg ))),
last = eval(substitute(expression({
- misc$link = c(theta= .link.theta )
- misc$earg = list(theta= .earg )
+ misc$link = c(theta = .link.theta )
+ misc$earg = list(theta = .earg )
misc$expected = TRUE
}), list( .link.theta = link.theta, .earg = earg ))),
loglikelihood = eval(substitute(function(mu, y, w, residuals = FALSE, eta, extra = NULL) {
@@ -4392,13 +4416,13 @@ rsimplex = function(n, mu = 0.5, dispersion = 1) {
}
}), list( .link.theta = link.theta, .earg = earg,
.init.theta=init.theta ))),
- inverse = eval(substitute(function(eta, extra = NULL) {
+ linkinv = eval(substitute(function(eta, extra = NULL) {
theta = eta2theta(eta, .link.theta, earg = .earg)
0.5 + theta/pi
}, list( .link.theta = link.theta, .earg = earg ))),
last = eval(substitute(expression({
- misc$link = c(theta= .link.theta)
- misc$earg = list(theta= .earg )
+ misc$link = c(theta = .link.theta)
+ misc$earg = list(theta = .earg )
misc$expected = TRUE
}), list( .link.theta = link.theta, .earg = earg ))),
loglikelihood = eval(substitute(function(mu, y, w, residuals = FALSE, eta, extra = NULL) {
@@ -4467,13 +4491,13 @@ rsimplex = function(n, mu = 0.5, dispersion = 1) {
}
}), list( .lmu = lmu, .llambda = llambda, .imu=imu, .ilambda=ilambda,
.emu = emu, .elambda = elambda ))),
- inverse = eval(substitute(function(eta, extra = NULL) {
+ linkinv = eval(substitute(function(eta, extra = NULL) {
eta2theta(eta[,1], .lmu, earg = .emu)
}, list( .lmu = lmu,
.emu = emu, .elambda = elambda ))),
last = eval(substitute(expression({
- misc$link = c(mu= .lmu, lambda= .llambda)
- misc$earg = list(mu= .emu, lambda= .elambda)
+ misc$link = c(mu= .lmu, lambda = .llambda)
+ misc$earg = list(mu= .emu, lambda = .elambda)
misc$pooled.weight = pooled.weight
misc$expected = FALSE
}), list( .lmu = lmu, .llambda = llambda,
@@ -4575,9 +4599,11 @@ rsimplex = function(n, mu = 0.5, dispersion = 1) {
initialize = eval(substitute(expression({
if (ncol(cbind(y)) != 1)
stop("response must be a vector or a one-column matrix")
+
predictors.names =
c(namesof("rho", .lrho, earg = .erho, tag = FALSE),
namesof("lambda", .llambda, earg = .elambda, tag = FALSE))
+
if (!length(etastart)) {
covarn = sd(y)^2 / weighted.mean(y, w)
temp1 = 0.5 + (1 + sqrt(1+8*covarn)) / (8*covarn)
@@ -4594,15 +4620,15 @@ rsimplex = function(n, mu = 0.5, dispersion = 1) {
}), list( .llambda = llambda, .lrho=lrho,
.elambda = elambda, .erho=erho,
.ilambda=ilambda, .irho=irho ))),
- inverse = eval(substitute(function(eta, extra = NULL) {
+ linkinv = eval(substitute(function(eta, extra = NULL) {
rho = eta2theta(eta[,1], .lrho, earg = .erho)
lambda = eta2theta(eta[,2], .llambda, earg = .elambda)
ifelse(rho > 0.5, lambda*(1-rho)/(2*rho-1), NA)
}, list( .llambda = llambda, .lrho=lrho,
.elambda = elambda, .erho=erho ))),
last = eval(substitute(expression({
- misc$link = c(rho= .lrho, lambda= .llambda)
- misc$earg = list(rho= .erho, lambda= .elambda)
+ misc$link = c(rho= .lrho, lambda = .llambda)
+ misc$earg = list(rho= .erho, lambda = .elambda)
misc$pooled.weight = pooled.weight
}), list( .llambda = llambda, .lrho=lrho,
.elambda = elambda, .erho=erho ))),
@@ -4659,7 +4685,7 @@ rsimplex = function(n, mu = 0.5, dispersion = 1) {
genpoisson = function(llambda = "elogit", ltheta = "loge",
- elambda=if (llambda == "elogit") list(min=-1,max=1) else list(),
+ elambda=if (llambda == "elogit") list(min=-1,max = 1) else list(),
etheta = list(),
ilambda = NULL, itheta = NULL,
use.approx = TRUE,
@@ -4698,10 +4724,10 @@ rsimplex = function(n, mu = 0.5, dispersion = 1) {
c(namesof("lambda", .llambda, earg = .elambda, tag = FALSE),
namesof("theta", .ltheta, earg = .etheta, tag = FALSE))
init.lambda = if ( .imethod == 1)
- 1 - sqrt(weighted.mean(y,w) / var(y)) else 0.5
+ 1 - sqrt(weighted.mean(y, w) / var(y)) else 0.5
init.theta = if ( .imethod == 1)
- sqrt((0.01+weighted.mean(y,w)^3)/var(y)) else
- median(y)*(1-init.lambda)
+ sqrt((0.01 + weighted.mean(y, w)^3) / var(y)) else
+ median(y) * (1-init.lambda)
if (init.theta <= 0)
init.theta = 0.1
cutpt = if (init.lambda < 0) {
@@ -4723,7 +4749,7 @@ rsimplex = function(n, mu = 0.5, dispersion = 1) {
.etheta=etheta, .elambda = elambda,
.imethod = imethod,
.itheta=itheta, .ilambda=ilambda )) ),
- inverse = eval(substitute(function(eta, extra = NULL) {
+ linkinv = eval(substitute(function(eta, extra = NULL) {
lambda = eta2theta(eta[,1], .llambda, earg = .elambda)
theta = eta2theta(eta[,2], .ltheta, earg = .etheta)
theta/(1-lambda)
@@ -4875,7 +4901,7 @@ rlgamma = function(n, location = 0, scale = 1, k=1) {
etastart = theta2eta(k.init, .link, earg = .earg)
}
}), list( .link = link, .earg = earg, .init.k=init.k ))),
- inverse = eval(substitute(function(eta, extra = NULL) {
+ linkinv = eval(substitute(function(eta, extra = NULL) {
k = eta2theta(eta, .link, earg = .earg)
digamma(k)
}, list( .link = link, .earg = earg ))),
@@ -4966,15 +4992,15 @@ rlgamma = function(n, location = 0, scale = 1, k=1) {
}), list( .llocation = llocation, .lscale = lscale, .lshape = lshape,
.elocation = elocation, .escale = escale, .eshape = eshape,
.iloc=ilocation, .iscale = iscale, .ishape = ishape ))),
- inverse = eval(substitute(function(eta, extra = NULL) {
+ linkinv = eval(substitute(function(eta, extra = NULL) {
eta2theta(eta[,1], .llocation, earg = .elocation) +
eta2theta(eta[,2], .lscale, earg = .escale) *
digamma(eta2theta(eta[,3], .lshape, earg = .eshape))
}, list( .llocation = llocation, .lscale = lscale, .lshape = lshape,
.elocation = elocation, .escale = escale, .eshape = eshape ))),
last = eval(substitute(expression({
- misc$link = c(location= .llocation, scale= .lscale, shape= .lshape)
- misc$earg = list(location= .elocation, scale= .escale, shape= .eshape)
+ misc$link = c(location= .llocation, scale = .lscale, shape = .lshape)
+ misc$earg = list(location= .elocation, scale = .escale, shape = .eshape)
}), list( .llocation = llocation, .lscale = lscale, .lshape = lshape,
.elocation = elocation, .escale = escale, .eshape = eshape ))),
loglikelihood = eval(substitute(
@@ -5081,13 +5107,13 @@ rlgamma = function(n, location = 0, scale = 1, k=1) {
}), list( .llocation = llocation, .lscale = lscale, .lshape = lshape,
.elocation = elocation, .escale = escale, .eshape = eshape,
.iloc=ilocation, .iscale = iscale, .ishape = ishape ))),
- inverse = eval(substitute(function(eta, extra = NULL) {
+ linkinv = eval(substitute(function(eta, extra = NULL) {
eta2theta(eta[,1], .llocation, earg = .elocation)
}, list( .llocation = llocation, .lscale = lscale, .lshape = lshape,
.elocation = elocation, .escale = escale, .eshape = eshape ))),
last = eval(substitute(expression({
- misc$link = c(location= .llocation, scale= .lscale, shape= .lshape)
- misc$earg = list(location= .elocation, scale= .escale, shape= .eshape)
+ misc$link = c(location= .llocation, scale = .lscale, shape = .lshape)
+ misc$earg = list(location= .elocation, scale = .escale, shape = .eshape)
}), list( .llocation = llocation, .lscale = lscale, .lshape = lshape,
.elocation = elocation, .escale = escale, .eshape = eshape ))),
loglikelihood = eval(substitute(
@@ -5158,10 +5184,10 @@ dgengamma = function(x, scale = 1, d = 1, k = 1, log = FALSE) {
if (!is.Numeric(k, posit = TRUE))
stop("bad input for argument 'k'")
N = max(length(x), length(scale), length(d), length(k))
- x = rep(x, len=N); scale = rep(scale, len=N);
- d = rep(d, len=N); k = rep(k, len=N);
+ x = rep(x, len = N); scale = rep(scale, len = N);
+ d = rep(d, len = N); k = rep(k, len = N);
- Loglik = rep(log(0), len=N)
+ Loglik = rep(log(0), len = N)
xok = x > 0
if (any(xok)) {
zedd = (x[xok]/scale[xok])^d[xok]
@@ -5272,15 +5298,15 @@ rgengamma = function(n, scale = 1, d = 1, k=1) {
}), list( .lscale = lscale, .ld = ld, .lk = lk,
.escale = escale, .ed = ed, .ek = ek,
.iscale = iscale, .id=id, .ik=ik ))),
- inverse = eval(substitute(function(eta, extra = NULL) {
+ linkinv = eval(substitute(function(eta, extra = NULL) {
b = eta2theta(eta[,1], .lscale, earg = .escale)
k = eta2theta(eta[,3], .lk, earg = .ek)
b * k
}, list( .ld = ld, .lscale = lscale, .lk = lk,
.escale = escale, .ed = ed, .ek = ek ))),
last = eval(substitute(expression({
- misc$link = c(scale= .lscale, d= .ld, k= .lk)
- misc$earg = list(scale= .escale, d= .ed, k= .ek)
+ misc$link = c(scale = .lscale, d= .ld, k= .lk)
+ misc$earg = list(scale = .escale, d= .ed, k= .ek)
}), list( .lscale = lscale, .ld = ld, .lk = lk,
.escale = escale, .ed = ed, .ek = ek ))),
loglikelihood = eval(substitute(
@@ -5342,9 +5368,9 @@ dlog = function(x, prob, log = FALSE) {
stop("bad input for argument 'prob'")
N = max(length(x), length(prob))
if (length(x) != N)
- x = rep(x, len=N)
+ x = rep(x, len = N)
if (length(prob) != N)
- prob = rep(prob, len=N)
+ prob = rep(prob, len = N)
ox = !is.finite(x)
zero = ox | round(x) != x | x < 1
ans = rep(0.0, len = length(x))
@@ -5368,7 +5394,7 @@ plog = function(q, prob, log.p = FALSE) {
if (!is.Numeric(prob, posit = TRUE) || max(prob) >= 1)
stop("bad input for argument 'prob'")
N = max(length(q), length(prob))
- q = rep(q, len=N); prob = rep(prob, len=N);
+ q = rep(q, len = N); prob = rep(prob, len = N);
bigno = 10
owen1965 = (q * (1 - prob) > bigno)
@@ -5411,12 +5437,12 @@ plog = function(q, prob, log.p = FALSE) {
if (!is.Numeric(prob, posit = TRUE) || max(prob) >= 1)
stop("bad input for argument 'prob'")
N = max(length(q), length(prob))
- q = rep(q, len=N); prob = rep(prob, len=N);
+ q = rep(q, len = N); prob = rep(prob, len = N);
ans = q * 0 # Retains names(q)
if (max(abs(prob-prob[1])) < 1.0e-08) {
qstar = floor(q)
- temp = if (max(qstar) >= 1) dlog(x=1:max(qstar),
- prob=prob[1]) else 0*qstar
+ temp = if (max(qstar) >= 1) dlog(x = 1:max(qstar),
+ prob = prob[1]) else 0*qstar
unq = unique(qstar)
for(ii in unq) {
index = qstar == ii
@@ -5425,7 +5451,8 @@ plog = function(q, prob, log.p = FALSE) {
} else
for(ii in 1:N) {
qstar = floor(q[ii])
- ans[ii] = if (qstar >= 1) sum(dlog(x=1:qstar, prob=prob[ii])) else 0
+ ans[ii] = if (qstar >= 1)
+ sum(dlog(x = 1:qstar, prob = prob[ii])) else 0
}
if (log.p) log(ans) else ans
}
@@ -5505,7 +5532,7 @@ rlog = function(n, prob, Smallno=1.0e-6) {
etastart = theta2eta(c.init, .link, earg = .earg)
}
}), list( .link = link, .earg = earg, .init.c=init.c ))),
- inverse = eval(substitute(function(eta, extra = NULL) {
+ linkinv = eval(substitute(function(eta, extra = NULL) {
cc = eta2theta(eta, .link, earg = .earg)
a = -1 / log1p(-cc)
a * cc / (1-cc)
@@ -5598,7 +5625,7 @@ rlog = function(n, prob, Smallno=1.0e-6) {
.delta=delta,
.idelta=idelta,
.igamma=igamma ))),
- inverse = eval(substitute(function(eta, extra = NULL) {
+ linkinv = eval(substitute(function(eta, extra = NULL) {
eta = as.matrix(eta)
mygamma = eta2theta(eta[,1], .link.gamma, earg = .earg)
delta = if ( .delta.known) .delta else eta[,2]
@@ -5714,13 +5741,13 @@ rlog = function(n, prob, Smallno=1.0e-6) {
}), list( .link.theta = link.theta, .link.alpha = link.alpha,
.y0=y0,
.itheta=itheta, .ialpha=ialpha ))),
- inverse = eval(substitute(function(eta, extra = NULL) {
+ linkinv = eval(substitute(function(eta, extra = NULL) {
alpha = eta2theta(eta[,1], .link.alpha, earg = .ealpha)
theta = eta2theta(eta[,2], .link.theta, earg = .etheta)
theta * extra$y0 * beta(1-1/alpha, theta)
}, list( .link.theta = link.theta, .link.alpha = link.alpha ))),
last = eval(substitute(expression({
- misc$link = c(alpha= .link.alpha, theta= .link.theta)
+ misc$link = c(alpha = .link.alpha, theta = .link.theta)
}), list( .link.theta = link.theta, .link.alpha = link.alpha ))),
loglikelihood = eval(substitute(
function(mu, y, w, residuals = FALSE, eta, extra = NULL) {
@@ -5874,7 +5901,7 @@ rlino = function(n, shape1, shape2, lambda=1) {
}), list( .lshape1 = lshape1, .lshape2 = lshape2, .llambda = llambda,
.eshape1 = eshape1, .eshape2 = eshape2, .elambda = elambda,
.ishape1=ishape1, .ishape2=ishape2, .ilambda=ilambda ))),
- inverse = eval(substitute(function(eta, extra = NULL) {
+ linkinv = eval(substitute(function(eta, extra = NULL) {
sh1 = eta2theta(eta[,1], .lshape1, earg = .eshape1)
sh2 = eta2theta(eta[,2], .lshape2, earg = .eshape2)
lambda = eta2theta(eta[,3], .llambda, earg = .elambda)
@@ -6005,27 +6032,28 @@ rlino = function(n, shape1, shape2, lambda=1) {
}), list( .link.a = link.a, .link.scale = link.scale,
.link.p = link.p, .link.q = link.q,
.earg.a = earg.a, .earg.scale = earg.scale,
- .earg.p=earg.p, .earg.q=earg.q,
+ .earg.p = earg.p, .earg.q = earg.q,
.init.a = init.a, .init.scale = init.scale,
- .init.p=init.p, .init.q=init.q ))),
- inverse = eval(substitute(function(eta, extra = NULL) {
+ .init.p = init.p, .init.q=init.q ))),
+ linkinv = eval(substitute(function(eta, extra = NULL) {
aa = eta2theta(eta[,1], .link.a, earg = .earg.a)
scale = eta2theta(eta[,2], .link.scale, earg = .earg.scale)
parg = eta2theta(eta[,3], .link.p, earg = .earg.p)
qq = eta2theta(eta[,4], .link.q, earg = .earg.q)
- scale*gamma(parg + 1/aa)*gamma(qq-1/aa)/(gamma(parg)*gamma(qq))
+ scale * gamma(parg + 1/aa) *
+ gamma(qq - 1/aa) / (gamma(parg)*gamma(qq))
}, list( .link.a = link.a, .link.scale = link.scale,
- .earg.a = earg.a, .earg.scale = earg.scale,
- .earg.p=earg.p, .earg.q=earg.q,
+ .earg.a = earg.a, .earg.scale = earg.scale,
+ .earg.p = earg.p, .earg.q = earg.q,
.link.p = link.p, .link.q = link.q ))),
last = eval(substitute(expression({
- misc$link = c(a= .link.a, scale= .link.scale,
- p= .link.p, q= .link.q)
- misc$earg = list(a= .earg.a, scale= .earg.scale,
- p= .earg.p, q= .earg.q)
+ misc$link = c(a = .link.a, scale = .link.scale,
+ p = .link.p, q= .link.q)
+ misc$earg = list(a = .earg.a, scale = .earg.scale,
+ p = .earg.p, q= .earg.q)
}), list( .link.a = link.a, .link.scale = link.scale,
.earg.a = earg.a, .earg.scale = earg.scale,
- .earg.p=earg.p, .earg.q=earg.q,
+ .earg.p = earg.p, .earg.q = earg.q,
.link.p = link.p, .link.q = link.q ))),
loglikelihood = eval(substitute(
function(mu, y, w, residuals = FALSE, eta, extra = NULL) {
@@ -6040,7 +6068,7 @@ rlino = function(n, shape1, shape2, lambda=1) {
}
}, list( .link.a = link.a, .link.scale = link.scale,
.earg.a = earg.a, .earg.scale = earg.scale,
- .earg.p=earg.p, .earg.q=earg.q,
+ .earg.p = earg.p, .earg.q = earg.q,
.link.p = link.p, .link.q = link.q ))),
vfamily = c("genbetaII"),
deriv = eval(substitute(expression({
@@ -6070,7 +6098,7 @@ rlino = function(n, shape1, shape2, lambda=1) {
dl.dq * dq.deta )
}), list( .link.a = link.a, .link.scale = link.scale,
.earg.a = earg.a, .earg.scale = earg.scale,
- .earg.p=earg.p, .earg.q=earg.q,
+ .earg.p = earg.p, .earg.q = earg.q,
.link.p = link.p, .link.q = link.q ))),
weight = eval(substitute(expression({
temp5 = trigamma(parg + qq)
@@ -6104,7 +6132,7 @@ rlino = function(n, shape1, shape2, lambda=1) {
wz
}), list( .link.a = link.a, .link.scale = link.scale,
.earg.a = earg.a, .earg.scale = earg.scale,
- .earg.p=earg.p, .earg.q=earg.q,
+ .earg.p = earg.p, .earg.q = earg.q,
.link.p = link.p, .link.q = link.q ))))
}
@@ -6116,13 +6144,13 @@ rlomax <- function(n, scale = 1, q.arg)
rsinmad(n, a = 1, scale, q.arg)
rfisk <- function(n, a, scale = 1)
- rsinmad(n, a, scale, q.arg=1)
+ rsinmad(n, a, scale, q.arg = 1)
rparalogistic <- function(n, a, scale = 1)
rsinmad(n, a, scale, a)
rdagum <- function(n, a, scale = 1, p.arg)
- qdagum(runif(n), a, scale = 1, p.arg)
+ qdagum(runif(n), a = a, scale = scale, p.arg = p.arg)
rinvlomax <- function(n, scale = 1, p.arg)
rdagum(n, a = 1, scale, p.arg)
@@ -6148,22 +6176,30 @@ qlomax <- function(p, scale = 1, q.arg)
qsinmad(p, a = 1, scale, q.arg)
qfisk <- function(p, a, scale = 1)
- qsinmad(p, a, scale, q.arg=1)
+ qsinmad(p, a, scale, q.arg = 1)
qparalogistic <- function(p, a, scale = 1)
qsinmad(p, a, scale, a)
+
+
qdagum <- function(p, a, scale = 1, p.arg) {
- bad = (p < 0) | (p > 1)
+
+ LLL <- max(length(p), length(a), length(scale), length(p.arg))
+ p <- rep(p, length.out = LLL)
+ a <- rep(a, length.out = LLL)
+ Scale <- rep(scale, length.out = LLL)
+ p.arg <- rep(p.arg, length.out = LLL)
+
+
+ bad = (p < 0) | (p > 1) | (Scale <= 0)
ans = NA * p
- a = rep(a, len = length(p))[!bad]
- scale = rep(scale, len = length(p))[!bad]
- p.arg = rep(p.arg, len = length(p))[!bad]
- xx = p[!bad]
- ans[!bad] = scale* (xx^(-1/p.arg) - 1)^(-1/a)
+ ans[!bad] = Scale[!bad] * (p[!bad]^(-1/p.arg[!bad]) - 1)^(-1/a[!bad])
ans
}
+
+
qinvlomax <- function(p, scale = 1, p.arg)
qdagum(p, a = 1, scale, p.arg)
@@ -6334,24 +6370,24 @@ dinvparalogistic <- function(x, a, scale = 1, log = FALSE)
}), list( .link.a = link.a, .link.scale = link.scale,
.link.q = link.q,
.earg.a = earg.a, .earg.scale = earg.scale,
- .earg.q=earg.q,
+ .earg.q = earg.q,
.init.a = init.a, .init.scale = init.scale,
.init.q=init.q ))),
- inverse = eval(substitute(function(eta, extra = NULL) {
+ linkinv = eval(substitute(function(eta, extra = NULL) {
aa = eta2theta(eta[,1], .link.a, earg = .earg.a)
scale = eta2theta(eta[,2], .link.scale, earg = .earg.scale)
qq = eta2theta(eta[,3], .link.q, earg = .earg.q)
scale*gamma(1 + 1/aa)*gamma(qq-1/aa)/(gamma(qq))
}, list( .link.a = link.a, .link.scale = link.scale,
.earg.a = earg.a, .earg.scale = earg.scale,
- .earg.q=earg.q,
+ .earg.q = earg.q,
.link.q = link.q ))),
last = eval(substitute(expression({
- misc$link = c(a= .link.a, scale= .link.scale, q= .link.q)
- misc$earg = list(a= .earg.a, scale= .earg.scale, q= .earg.q)
+ misc$link = c(a = .link.a, scale = .link.scale, q= .link.q)
+ misc$earg = list(a = .earg.a, scale = .earg.scale, q= .earg.q)
}), list( .link.a = link.a, .link.scale = link.scale,
.earg.a = earg.a, .earg.scale = earg.scale,
- .earg.q=earg.q,
+ .earg.q = earg.q,
.link.q = link.q ))),
loglikelihood = eval(substitute(
function(mu, y, w, residuals = FALSE, eta, extra = NULL) {
@@ -6364,7 +6400,7 @@ dinvparalogistic <- function(x, a, scale = 1, log = FALSE)
sum(w * dsinmad(x = y, a=aa, scale = scale, q.arg=qq, log = TRUE))
}
}, list( .link.a = link.a, .link.scale = link.scale, .link.q = link.q,
- .earg.a = earg.a, .earg.scale = earg.scale, .earg.q=earg.q ))),
+ .earg.a = earg.a, .earg.scale = earg.scale, .earg.q = earg.q ))),
vfamily = c("sinmad"),
deriv = eval(substitute(expression({
aa = eta2theta(eta[,1], .link.a, earg = .earg.a)
@@ -6388,7 +6424,7 @@ dinvparalogistic <- function(x, a, scale = 1, log = FALSE)
dl.dq * dq.deta )
}), list( .link.a = link.a, .link.scale = link.scale,
.earg.a = earg.a, .earg.scale = earg.scale,
- .earg.q=earg.q,
+ .earg.q = earg.q,
.link.q = link.q ))),
weight = eval(substitute(expression({
ed2l.da = (1 + parg+qq + parg * qq * (trigamma(parg) + trigamma(qq) +
@@ -6411,7 +6447,7 @@ dinvparalogistic <- function(x, a, scale = 1, log = FALSE)
wz
}), list( .link.a = link.a, .link.scale = link.scale,
.earg.a = earg.a, .earg.scale = earg.scale,
- .earg.q=earg.q,
+ .earg.q = earg.q,
.link.q = link.q ))))
}
@@ -6442,9 +6478,9 @@ dinvparalogistic <- function(x, a, scale = 1, log = FALSE)
new("vglmff",
blurb = c("Dagum distribution\n\n",
"Links: ",
- namesof("a", link.a, earg = earg.a), ", ",
+ namesof("a", link.a, earg = earg.a), ", ",
namesof("scale", link.scale, earg = earg.scale), ", ",
- namesof("p", link.p, earg = earg.p), "\n",
+ namesof("p", link.p, earg = earg.p), "\n",
"Mean: scale*gamma(p + 1/a)*gamma(1 - 1/a)/gamma(p)"),
constraints = eval(substitute(expression({
constraints = cm.zero.vgam(constraints, x, .zero, M)
@@ -6471,50 +6507,50 @@ dinvparalogistic <- function(x, a, scale = 1, log = FALSE)
length = n)
scale = rep(if (length( .init.scale )) .init.scale else
exp(fit0$coef[1]), length = n)
- etastart = cbind(theta2eta(aa, .link.a, earg = .earg.a),
+ etastart = cbind(theta2eta(aa, .link.a, earg = .earg.a),
theta2eta(scale, .link.scale, earg = .earg.scale),
- theta2eta(parg, .link.p, earg = .earg.p))
+ theta2eta(parg, .link.p, earg = .earg.p))
}
}), list( .link.a = link.a, .link.scale = link.scale,
.link.p = link.p,
.earg.a = earg.a, .earg.scale = earg.scale,
- .earg.p=earg.p,
+ .earg.p = earg.p,
.init.a = init.a, .init.scale = init.scale,
- .init.p=init.p ))),
- inverse = eval(substitute(function(eta, extra = NULL) {
- aa = eta2theta(eta[,1], .link.a, earg = .earg.a)
+ .init.p = init.p ))),
+ linkinv = eval(substitute(function(eta, extra = NULL) {
+ aa = eta2theta(eta[,1], .link.a, earg = .earg.a)
scale = eta2theta(eta[,2], .link.scale, earg = .earg.scale)
- parg = eta2theta(eta[,3], .link.p, earg = .earg.p)
+ parg = eta2theta(eta[,3], .link.p, earg = .earg.p)
qq = 1
- scale*gamma(parg + 1/aa)*gamma(qq-1/aa)/(gamma(parg)*gamma(qq))
+ scale * gamma(parg + 1/aa) *
+ gamma(qq - 1/aa) / (gamma(parg)*gamma(qq))
}, list( .link.a = link.a, .link.scale = link.scale,
- .earg.a = earg.a, .earg.scale = earg.scale,
- .earg.p=earg.p,
+ .earg.a = earg.a, .earg.scale = earg.scale,
+ .earg.p = earg.p,
.link.p = link.p ))),
last = eval(substitute(expression({
- misc$link = c(a= .link.a, scale= .link.scale, p= .link.p )
- misc$earg = list(a= .earg.a, scale= .earg.scale, p= .earg.p)
- }), list( .link.a = link.a, .link.scale = link.scale,
- .earg.a = earg.a, .earg.scale = earg.scale,
- .earg.p=earg.p,
- .link.p = link.p ))),
+ misc$link = c(a = .link.a, scale = .link.scale, p = .link.p )
+ misc$earg = list(a = .earg.a, scale = .earg.scale, p = .earg.p)
+ }), list( .link.a = link.a, .link.scale = link.scale, .link.p = link.p,
+ .earg.a = earg.a, .earg.scale = earg.scale, .earg.p = earg.p ))),
loglikelihood = eval(substitute(
function(mu, y, w, residuals = FALSE, eta, extra = NULL) {
- aa = eta2theta(eta[,1], .link.a, earg = .earg.a)
+ aa = eta2theta(eta[,1], .link.a, earg = .earg.a)
scale = eta2theta(eta[,2], .link.scale, earg = .earg.scale)
- parg = eta2theta(eta[,3], .link.p, earg = .earg.p)
+ parg = eta2theta(eta[,3], .link.p, earg = .earg.p)
qq = 1
if (residuals) stop("loglikelihood residuals ",
"not implemented yet") else {
- sum(w * ddagum(x = y, a=aa, scale = scale, p.arg=parg, log = TRUE))
+ sum(w * ddagum(x = y, a = aa, scale = scale, p.arg = parg,
+ log = TRUE))
}
}, list( .link.a = link.a, .link.scale = link.scale, .link.p = link.p,
- .earg.a = earg.a, .earg.scale = earg.scale, .earg.p=earg.p ))),
+ .earg.a = earg.a, .earg.scale = earg.scale, .earg.p = earg.p ))),
vfamily = c("dagum"),
deriv = eval(substitute(expression({
- aa = eta2theta(eta[,1], .link.a, earg = .earg.a)
+ aa = eta2theta(eta[,1], .link.a, earg = .earg.a)
scale = eta2theta(eta[,2], .link.scale, earg = .earg.scale)
- parg = eta2theta(eta[,3], .link.p, earg = .earg.p)
+ parg = eta2theta(eta[,3], .link.p, earg = .earg.p)
qq = 1
temp1 = log(y/scale)
@@ -6525,30 +6561,30 @@ dinvparalogistic <- function(x, a, scale = 1, log = FALSE)
dl.da = 1/aa + parg * temp1 - (parg+qq) * temp1 / (1+1/temp2)
dl.dscale = (aa/scale) * (-parg + (parg+qq) / (1+1/temp2))
dl.dp = aa * temp1 + digamma(parg + qq) - temp3a - log1p(temp2)
- da.deta = dtheta.deta(aa, .link.a, earg = .earg.a)
+ da.deta = dtheta.deta(aa, .link.a, earg = .earg.a)
dscale.deta = dtheta.deta(scale, .link.scale, earg = .earg.scale)
- dp.deta = dtheta.deta(parg, .link.p, earg = .earg.p)
- c(w) * cbind( dl.da * da.deta,
- dl.dscale * dscale.deta,
- dl.dp * dp.deta )
+ dp.deta = dtheta.deta(parg, .link.p, earg = .earg.p)
+ c(w) * cbind( dl.da * da.deta,
+ dl.dscale * dscale.deta,
+ dl.dp * dp.deta )
}), list( .link.a = link.a, .link.scale = link.scale,
.earg.a = earg.a, .earg.scale = earg.scale,
- .earg.p=earg.p,
+ .earg.p = earg.p,
.link.p = link.p ))),
weight = eval(substitute(expression({
- ed2l.da = (1 + parg+qq + parg * qq * (trigamma(parg) + trigamma(qq) +
+ ed2l.da = (1 + parg+qq + parg * qq * (trigamma(parg) + trigamma(qq) +
(temp3b - temp3a + (parg-qq)/(parg*qq))^2 -
(parg^2 + qq^2) / (parg*qq)^2)) / (aa^2 * (1+parg+qq))
ed2l.dscale = aa^2 * parg * qq / (scale^2 * (1+parg+qq))
- ed2l.dp = 1/parg^2
- ed2l.dascale = (parg - qq - parg*qq*(temp3a -temp3b)) /
- (scale*(1 + parg+qq))
+ ed2l.dp = 1 / parg^2
+ ed2l.dascale = (parg - qq - parg * qq *(temp3a -temp3b)
+ ) / (scale * (1 + parg+qq))
ed2l.dap= -(qq * (temp3a -temp3b) -1) / (aa*(parg+qq))
- ed2l.dscalep = aa * qq / (scale*(parg+qq))
+ ed2l.dscalep = aa * qq / (scale * (parg + qq))
wz = matrix(as.numeric(NA), n, dimm(M)) #M==3 means 6=dimm(M)
- wz[,iam(1,1,M)] = ed2l.da * da.deta^2
+ wz[,iam(1,1,M)] = ed2l.da * da.deta^2
wz[,iam(2,2,M)] = ed2l.dscale * dscale.deta^2
- wz[,iam(3,3,M)] = ed2l.dp * dp.deta^2
+ wz[,iam(3,3,M)] = ed2l.dp * dp.deta^2
wz[,iam(1,2,M)] = ed2l.dascale * da.deta * dscale.deta
wz[,iam(1,3,M)] = ed2l.dap * da.deta * dp.deta
wz[,iam(2,3,M)] = ed2l.dscalep * dscale.deta * dp.deta
@@ -6556,7 +6592,7 @@ dinvparalogistic <- function(x, a, scale = 1, log = FALSE)
wz
}), list( .link.a = link.a, .link.scale = link.scale,
.earg.a = earg.a, .earg.scale = earg.scale,
- .earg.p=earg.p,
+ .earg.p = earg.p,
.link.p = link.p ))))
}
@@ -6616,10 +6652,10 @@ dinvparalogistic <- function(x, a, scale = 1, log = FALSE)
}), list( .link.scale = link.scale,
.link.p = link.p, .link.q = link.q,
.earg.scale = earg.scale,
- .earg.p=earg.p, .earg.q=earg.q,
+ .earg.p = earg.p, .earg.q = earg.q,
.init.scale = init.scale,
- .init.p=init.p, .init.q=init.q ))),
- inverse = eval(substitute(function(eta, extra = NULL) {
+ .init.p = init.p, .init.q=init.q ))),
+ linkinv = eval(substitute(function(eta, extra = NULL) {
aa = 1
scale = eta2theta(eta[,1], .link.scale, earg = .earg.scale)
parg = eta2theta(eta[,2], .link.p, earg = .earg.p)
@@ -6627,14 +6663,14 @@ dinvparalogistic <- function(x, a, scale = 1, log = FALSE)
scale*gamma(parg + 1/aa)*gamma(qq-1/aa)/(gamma(parg)*gamma(qq))
}, list( .link.scale = link.scale,
.earg.scale = earg.scale,
- .earg.p=earg.p, .earg.q=earg.q,
+ .earg.p = earg.p, .earg.q = earg.q,
.link.p = link.p, .link.q = link.q ))),
last = eval(substitute(expression({
- misc$link = c(scale= .link.scale, p= .link.p, q= .link.q)
- misc$earg = list(scale= .earg.scale, p= .earg.p, q= .earg.q)
+ misc$link = c(scale = .link.scale, p = .link.p, q= .link.q)
+ misc$earg = list(scale = .earg.scale, p = .earg.p, q= .earg.q)
}), list( .link.scale = link.scale,
.earg.scale = earg.scale,
- .earg.p=earg.p, .earg.q=earg.q,
+ .earg.p = earg.p, .earg.q = earg.q,
.link.p = link.p, .link.q = link.q ))),
loglikelihood = eval(substitute(
function(mu, y, w, residuals = FALSE, eta, extra = NULL) {
@@ -6648,7 +6684,7 @@ dinvparalogistic <- function(x, a, scale = 1, log = FALSE)
(-lbeta(parg, qq)) - (parg+qq)*log1p((y/scale)^aa)))
}, list( .link.scale = link.scale,
.earg.scale = earg.scale,
- .earg.p=earg.p, .earg.q=earg.q,
+ .earg.p = earg.p, .earg.q = earg.q,
.link.p = link.p, .link.q = link.q ))),
vfamily = c("betaII"),
deriv = eval(substitute(expression({
@@ -6675,7 +6711,7 @@ dinvparalogistic <- function(x, a, scale = 1, log = FALSE)
dl.dq * dq.deta )
}), list( .link.scale = link.scale,
.earg.scale = earg.scale,
- .earg.p=earg.p, .earg.q=earg.q,
+ .earg.p = earg.p, .earg.q = earg.q,
.link.p = link.p, .link.q = link.q ))),
weight = eval(substitute(expression({
temp5 = trigamma(parg + qq)
@@ -6696,7 +6732,7 @@ dinvparalogistic <- function(x, a, scale = 1, log = FALSE)
wz
}), list( .link.scale = link.scale,
.earg.scale = earg.scale,
- .earg.p=earg.p, .earg.q=earg.q,
+ .earg.p = earg.p, .earg.q = earg.q,
.link.p = link.p, .link.q = link.q ))))
}
@@ -6751,19 +6787,19 @@ dinvparalogistic <- function(x, a, scale = 1, log = FALSE)
theta2eta(qq, .link.q, earg = .earg.q))
}
}), list( .link.scale = link.scale, .link.q = link.q,
- .earg.scale = earg.scale, .earg.q=earg.q,
+ .earg.scale = earg.scale, .earg.q = earg.q,
.init.scale = init.scale, .init.q=init.q ))),
- inverse = eval(substitute(function(eta, extra = NULL) {
+ linkinv = eval(substitute(function(eta, extra = NULL) {
scale = eta2theta(eta[,1], .link.scale, earg = .earg.scale)
qq = eta2theta(eta[,2], .link.q, earg = .earg.q)
scale/(qq-1)
}, list( .link.scale = link.scale, .link.q = link.q,
- .earg.scale = earg.scale, .earg.q=earg.q ))),
+ .earg.scale = earg.scale, .earg.q = earg.q ))),
last = eval(substitute(expression({
- misc$link = c(scale= .link.scale, q= .link.q)
- misc$earg = list(scale= .earg.scale, q= .earg.q)
+ misc$link = c(scale = .link.scale, q= .link.q)
+ misc$earg = list(scale = .earg.scale, q= .earg.q)
}), list( .link.scale = link.scale, .link.q = link.q,
- .earg.scale = earg.scale, .earg.q=earg.q ))),
+ .earg.scale = earg.scale, .earg.q = earg.q ))),
loglikelihood = eval(substitute(
function(mu, y, w, residuals = FALSE, eta, extra = NULL) {
aa = 1
@@ -6775,7 +6811,7 @@ dinvparalogistic <- function(x, a, scale = 1, log = FALSE)
sum(w * dlomax(x = y, scale = scale, q.arg=qq, log = TRUE))
}
}, list( .link.scale = link.scale, .link.q = link.q,
- .earg.scale = earg.scale, .earg.q=earg.q ))),
+ .earg.scale = earg.scale, .earg.q = earg.q ))),
vfamily = c("lomax"),
deriv = eval(substitute(expression({
aa = 1
@@ -6791,7 +6827,7 @@ dinvparalogistic <- function(x, a, scale = 1, log = FALSE)
c(w) * cbind( dl.dscale * dscale.deta,
dl.dq * dq.deta )
}), list( .link.scale = link.scale, .link.q = link.q,
- .earg.scale = earg.scale, .earg.q=earg.q ))),
+ .earg.scale = earg.scale, .earg.q = earg.q ))),
weight = eval(substitute(expression({
ed2l.dscale = aa^2 * parg * qq / (scale^2 * (1+parg+qq))
ed2l.dq = 1/qq^2
@@ -6803,7 +6839,7 @@ dinvparalogistic <- function(x, a, scale = 1, log = FALSE)
wz = c(w) * wz
wz
}), list( .link.scale = link.scale, .link.q = link.q,
- .earg.scale = earg.scale, .earg.q=earg.q ))))
+ .earg.scale = earg.scale, .earg.q = earg.q ))))
}
@@ -6856,7 +6892,7 @@ dinvparalogistic <- function(x, a, scale = 1, log = FALSE)
}), list( .link.a = link.a, .link.scale = link.scale,
.earg.a = earg.a, .earg.scale = earg.scale,
.init.a = init.a, .init.scale = init.scale ))),
- inverse = eval(substitute(function(eta, extra = NULL) {
+ linkinv = eval(substitute(function(eta, extra = NULL) {
aa = eta2theta(eta[,1], .link.a, earg = .earg.a)
scale = eta2theta(eta[,2], .link.scale, earg = .earg.scale)
qq = 1
@@ -6864,8 +6900,8 @@ dinvparalogistic <- function(x, a, scale = 1, log = FALSE)
}, list( .link.a = link.a, .link.scale = link.scale,
.earg.a = earg.a, .earg.scale = earg.scale ))),
last = eval(substitute(expression({
- misc$link = c(a= .link.a, scale= .link.scale)
- misc$earg = list(a= .earg.a, scale= .earg.scale)
+ misc$link = c(a = .link.a, scale = .link.scale)
+ misc$earg = list(a = .earg.a, scale = .earg.scale)
}), list( .link.a = link.a, .link.scale = link.scale,
.earg.a = earg.a, .earg.scale = earg.scale
))),
@@ -6967,21 +7003,21 @@ dinvparalogistic <- function(x, a, scale = 1, log = FALSE)
}), list( .link.scale = link.scale,
.link.p = link.p,
.earg.scale = earg.scale,
- .earg.p=earg.p,
+ .earg.p = earg.p,
.init.scale = init.scale,
- .init.p=init.p ))),
- inverse = eval(substitute(function(eta, extra = NULL) {
+ .init.p = init.p ))),
+ linkinv = eval(substitute(function(eta, extra = NULL) {
rep(as.numeric(NA), len = nrow(eta))
}, list( .link.scale = link.scale,
- .earg.scale = earg.scale,
- .earg.p=earg.p,
+ .earg.scale = earg.scale,
+ .earg.p = earg.p,
.link.p = link.p ))),
last = eval(substitute(expression({
- misc$link = c(scale= .link.scale, p= .link.p )
- misc$earg = list(scale= .earg.scale, p= .earg.p )
+ misc$link = c(scale = .link.scale, p = .link.p )
+ misc$earg = list(scale = .earg.scale, p = .earg.p )
}), list( .link.scale = link.scale,
.earg.scale = earg.scale,
- .earg.p=earg.p,
+ .earg.p = earg.p,
.link.p = link.p ))),
loglikelihood = eval(substitute(
function(mu, y, w, residuals = FALSE, eta, extra = NULL) {
@@ -6993,7 +7029,7 @@ dinvparalogistic <- function(x, a, scale = 1, log = FALSE)
sum(w * dinvlomax(x = y, scale = scale, p.arg=parg, log = TRUE))
}
}, list( .link.scale = link.scale, .link.p = link.p,
- .earg.scale = earg.scale, .earg.p=earg.p ))),
+ .earg.scale = earg.scale, .earg.p = earg.p ))),
vfamily = c("invlomax"),
deriv = eval(substitute(expression({
aa = qq = 1
@@ -7010,7 +7046,7 @@ dinvparalogistic <- function(x, a, scale = 1, log = FALSE)
c(w) * cbind( dl.dscale * dscale.deta,
dl.dp * dp.deta )
}), list( .link.scale = link.scale, .link.p = link.p,
- .earg.scale = earg.scale, .earg.p=earg.p ))),
+ .earg.scale = earg.scale, .earg.p = earg.p ))),
weight = eval(substitute(expression({
ed2l.dscale = aa^2 * parg * qq / (scale^2 * (1+parg+qq))
ed2l.dp = 1/parg^2
@@ -7022,14 +7058,14 @@ dinvparalogistic <- function(x, a, scale = 1, log = FALSE)
wz = c(w) * wz
wz
}), list( .link.scale = link.scale, .link.p = link.p,
- .earg.scale = earg.scale, .earg.p=earg.p ))))
+ .earg.scale = earg.scale, .earg.p = earg.p ))))
}
paralogistic = function(link.a = "loge",
link.scale = "loge",
earg.a = list(), earg.scale = list(),
- init.a=1.0,
+ init.a = 1.0,
init.scale = NULL,
zero = NULL)
{
@@ -7079,7 +7115,7 @@ dinvparalogistic <- function(x, a, scale = 1, log = FALSE)
.earg.a = earg.a, .earg.scale = earg.scale,
.init.a = init.a, .init.scale = init.scale
))),
- inverse = eval(substitute(function(eta, extra = NULL) {
+ linkinv = eval(substitute(function(eta, extra = NULL) {
aa = eta2theta(eta[,1], .link.a, earg = .earg.a)
scale = eta2theta(eta[,2], .link.scale, earg = .earg.scale)
qq = aa
@@ -7087,8 +7123,8 @@ dinvparalogistic <- function(x, a, scale = 1, log = FALSE)
}, list( .link.a = link.a, .link.scale = link.scale,
.earg.a = earg.a, .earg.scale = earg.scale ))),
last = eval(substitute(expression({
- misc$link = c(a= .link.a, scale= .link.scale)
- misc$earg = list(a= .earg.a, scale= .earg.scale )
+ misc$link = c(a = .link.a, scale = .link.scale)
+ misc$earg = list(a = .earg.a, scale = .earg.scale )
}), list( .link.a = link.a, .link.scale = link.scale,
.earg.a = earg.a, .earg.scale = earg.scale ))),
loglikelihood = eval(substitute(
@@ -7144,7 +7180,7 @@ dinvparalogistic <- function(x, a, scale = 1, log = FALSE)
invparalogistic = function(link.a = "loge",
link.scale = "loge",
earg.a = list(), earg.scale = list(),
- init.a=1.0,
+ init.a = 1.0,
init.scale = NULL,
zero = NULL)
{
@@ -7171,7 +7207,7 @@ dinvparalogistic <- function(x, a, scale = 1, log = FALSE)
if (ncol(cbind(y)) != 1)
stop("response must be a vector or a one-column matrix")
predictors.names =
- c(namesof("a", .link.a, earg = .earg.a, tag = FALSE),
+ c(namesof("a", .link.a, earg = .earg.a, tag = FALSE),
namesof("scale", .link.scale, earg = .earg.scale, tag = FALSE))
if (!length( .init.a) || !length( .init.scale )) {
@@ -7193,7 +7229,7 @@ dinvparalogistic <- function(x, a, scale = 1, log = FALSE)
}), list( .link.a = link.a, .link.scale = link.scale,
.earg.a = earg.a, .earg.scale = earg.scale,
.init.a = init.a, .init.scale = init.scale ))),
- inverse = eval(substitute(function(eta, extra = NULL) {
+ linkinv = eval(substitute(function(eta, extra = NULL) {
aa = eta2theta(eta[,1], .link.a, earg = .earg.a)
scale = eta2theta(eta[,2], .link.scale, earg = .earg.scale)
parg = aa
@@ -7203,8 +7239,8 @@ dinvparalogistic <- function(x, a, scale = 1, log = FALSE)
}, list( .link.a = link.a, .link.scale = link.scale,
.earg.a = earg.a, .earg.scale = earg.scale ))),
last = eval(substitute(expression({
- misc$link = c(a= .link.a, scale= .link.scale )
- misc$earg = list(a= .earg.a, scale= .earg.scale )
+ misc$link = c(a = .link.a, scale = .link.scale )
+ misc$earg = list(a = .earg.a, scale = .earg.scale )
}), list( .link.a = link.a, .link.scale = link.scale,
.earg.a = earg.a, .earg.scale = earg.scale ))),
loglikelihood = eval(substitute(
@@ -7311,7 +7347,7 @@ warning("2/4/04; doesn't work, possibly because first derivs are ",
}
}), list( .link.sigma = link.sigma, .link.r = link.r,
.init.sigma=init.sigma, .init.r=init.r ))),
- inverse = eval(substitute(function(eta, extra = NULL) {
+ linkinv = eval(substitute(function(eta, extra = NULL) {
mymu = eta2theta(eta[,1], "identity", earg = list())
sigma = eta2theta(eta[,2], .link.sigma, earg = .esigma)
r = eta2theta(eta[,3], .link.r, earg = .er)
@@ -7405,7 +7441,7 @@ warning("2/4/04; doesn't work, possibly because first derivs are ",
n,2,byrow = TRUE)
}
}), list( .link = link, .earg = earg, .i1=i1, .i2=i2 ))),
- inverse = eval(substitute(function(eta, extra = NULL) {
+ linkinv = eval(substitute(function(eta, extra = NULL) {
shapes = eta2theta(eta, .link, earg = .earg)
ifelse(shapes[,2] > 1, shapes[,1]/(shapes[,2]-1), NA)
}, list( .link = link, .earg = earg ))),
@@ -7466,6 +7502,7 @@ dmaxwell = function(x, a, log = FALSE) {
if (log.arg) logdensity else exp(logdensity)
}
+
pmaxwell = function(q, a) {
if (any(a <= 0)) stop("argument 'a' must be positive")
L = max(length(q), length(a))
@@ -7473,6 +7510,7 @@ pmaxwell = function(q, a) {
ifelse(q > 0, erf(q*sqrt(a/2)) - q*exp(-0.5*a*q^2) * sqrt(2*a/pi), 0)
}
+
rmaxwell = function(n, a) {
if (!is.Numeric(n, posit = TRUE, allow = 1))
stop("bad input for argument 'n'")
@@ -7480,11 +7518,12 @@ rmaxwell = function(n, a) {
sqrt(2 * rgamma(n = n, 1.5) / a)
}
+
qmaxwell = function(p, a) {
- if (!is.Numeric(p, posit = TRUE) || any(p>=1))
+ if (!is.Numeric(p, posit = TRUE) || any(p >= 1))
stop("bad input for argument 'p'")
if (any(a <= 0)) stop("argument 'a' must be positive")
- N = max(length(p), length(a)); p = rep(p, len=N); a = rep(a, len=N)
+ N = max(length(p), length(a)); p = rep(p, len = N); a = rep(a, len = N)
sqrt(2 * qgamma(p=p, 1.5) / a)
}
@@ -7504,16 +7543,16 @@ qmaxwell = function(p, a) {
stop("response must be a vector or a one-column matrix")
predictors.names = namesof("a", .link, earg = .earg, tag = FALSE)
if (!length(etastart)) {
- a.init = rep(8 / (pi*(y+0.1)^2), length=length(y))
+ a.init = rep(8 / (pi*(y+0.1)^2), length = length(y))
etastart = theta2eta(a.init, .link, earg = .earg)
}
}), list( .link = link, .earg = earg ))),
- inverse = eval(substitute(function(eta, extra = NULL) {
+ linkinv = eval(substitute(function(eta, extra = NULL) {
a = eta2theta(eta, .link, earg = .earg)
sqrt(8 / (a * pi))
}, list( .link = link, .earg = earg ))),
last = eval(substitute(expression({
- misc$link = c(a= .link)
+ misc$link = c(a = .link)
misc$earg = list(a = .earg)
}), list( .link = link, .earg = earg ))),
loglikelihood = eval(substitute(
@@ -7521,7 +7560,7 @@ qmaxwell = function(p, a) {
aa = eta2theta(eta, .link, earg = .earg)
if (residuals) stop("loglikelihood residuals ",
"not implemented yet") else
- sum(w * dmaxwell(x = y, a=aa, log = TRUE))
+ sum(w * dmaxwell(x = y, a = aa, log = TRUE))
}, list( .link = link, .earg = earg ))),
vfamily = c("maxwell"),
deriv = eval(substitute(expression({
@@ -7544,8 +7583,11 @@ dnaka = function(x, shape, scale = 1, log = FALSE) {
if (!is.logical(log.arg <- log))
stop("bad input for argument 'log'")
rm(log)
+
L = max(length(x), length(shape), length(scale))
- x = rep(x, len = L); shape = rep(shape, len = L); scale = rep(scale, len = L);
+ x = rep(x, len = L)
+ shape = rep(shape, len = L)
+ scale = rep(scale, len = L);
logdensity = rep(log(0), len = L)
xok = (x > 0)
@@ -7564,7 +7606,9 @@ pnaka = function(q, shape, scale = 1) {
if (!is.Numeric(scale, posit = TRUE))
stop("bad input for argument 'scale'")
L = max(length(q), length(shape), length(scale))
- q = rep(q, len = L); shape = rep(shape, len = L); scale = rep(scale, len = L);
+ q = rep(q, len = L)
+ shape = rep(shape, len = L)
+ scale = rep(scale, len = L);
ifelse(q <= 0, 0, pgamma(shape * q^2 / scale, shape))
}
@@ -7583,9 +7627,11 @@ qnaka = function(p, shape, scale = 1, ...) {
myfun = function(x, shape, scale = 1, p)
pnaka(q=x, shape = shape, scale = scale) - p
for(ii in 1:L) {
- EY = sqrt(scale[ii]/shape[ii]) * gamma(shape[ii]+0.5) / gamma(shape[ii])
+ EY = sqrt(scale[ii]/shape[ii]) *
+ gamma(shape[ii]+0.5) / gamma(shape[ii])
Upper = 5 * EY
- while(pnaka(q=Upper, shape = shape[ii], scale = scale[ii]) < p[ii])
+ while(pnaka(q = Upper, shape = shape[ii],
+ scale = scale[ii]) < p[ii])
Upper = Upper + scale[ii]
ans[ii] = uniroot(f = myfun, lower = 0, upper = Upper,
shape = shape[ii], scale = scale[ii],
@@ -7634,7 +7680,8 @@ rnaka = function(n, shape, scale = 1, Smallno=1.0e-6) {
nakagami = function(lshape = "loge", lscale = "loge",
- eshape = list(), escale = list(), ishape = NULL, iscale = 1) {
+ eshape = list(), escale = list(),
+ ishape = NULL, iscale = 1) {
if (mode(lshape) != "character" && mode(lshape) != "name")
lshape = as.character(substitute(lshape))
if (mode(lscale) != "character" && mode(lscale) != "name")
@@ -7673,14 +7720,14 @@ rnaka = function(n, shape, scale = 1, Smallno=1.0e-6) {
}), list( .lscale = lscale, .lshape = lshape,
.escale = escale, .eshape = eshape,
.ishape = ishape, .iscale = iscale ))),
- inverse = eval(substitute(function(eta, extra = NULL) {
+ linkinv = eval(substitute(function(eta, extra = NULL) {
shape = eta2theta(eta[,1], .lshape, earg = .eshape)
scale = eta2theta(eta[,2], .lscale, earg = .escale)
sqrt(scale/shape) * gamma(shape+0.5) / gamma(shape)
}, list( .lscale = lscale, .lshape = lshape,
.escale = escale, .eshape = eshape ))),
last = eval(substitute(expression({
- misc$link = c(shape= .lshape, scale= .lscale)
+ misc$link = c(shape = .lshape, scale = .lscale)
misc$earg = list(shape = .eshape, scale = .escale)
misc$expected = TRUE
}), list( .lscale = lscale, .lshape = lshape,
@@ -7786,7 +7833,7 @@ rrayleigh = function(n, scale = 1) {
etastart = theta2eta(b.init, .lscale, earg = .escale)
}
}), list( .lscale = lscale, .escale = escale ))),
- inverse = eval(substitute(function(eta, extra = NULL) {
+ linkinv = eval(substitute(function(eta, extra = NULL) {
Scale = eta2theta(eta, .lscale, earg = .escale)
Scale * sqrt(pi/2)
}, list( .lscale = lscale, .escale = escale ))),
@@ -7830,11 +7877,11 @@ dparetoIV = function(x, location = 0, scale = 1, inequality = 1, shape = 1, log
N = max(length(x), length(location), length(scale), length(inequality),
length(shape))
- x = rep(x, len=N); location = rep(location, len=N)
- scale = rep(scale, len=N); inequality = rep(inequality, len=N)
- shape = rep(shape, len=N)
+ x = rep(x, len = N); location = rep(location, len = N)
+ scale = rep(scale, len = N); inequality = rep(inequality, len = N)
+ shape = rep(shape, len = N)
- logdensity = rep(log(0), len=N)
+ logdensity = rep(log(0), len = N)
xok = (x > location)
zedd = (x - location) / scale
logdensity[xok] = log(shape[xok]) - log(scale[xok]) - log(inequality[xok])+
@@ -7843,7 +7890,7 @@ dparetoIV = function(x, location = 0, scale = 1, inequality = 1, shape = 1, log
if (log.arg) logdensity else exp(logdensity)
}
-pparetoIV = function(q, location = 0, scale = 1, inequality = 1, shape=1) {
+pparetoIV = function(q, location = 0, scale = 1, inequality = 1, shape = 1) {
if (!is.Numeric(q)) stop("bad input for argument 'q'")
if (!is.Numeric(scale, posit = TRUE))
stop("bad input for argument 'scale'")
@@ -7851,11 +7898,11 @@ pparetoIV = function(q, location = 0, scale = 1, inequality = 1, shape=1) {
stop("bad input for argument 'inequality'")
if (!is.Numeric(shape, posit = TRUE))
stop("bad input for argument 'shape'")
- N = max(length(q), length(location), length(scale), length(inequality),
- length(shape))
- q = rep(q, len=N); location = rep(location, len=N)
- scale = rep(scale, len=N); inequality = rep(inequality, len=N)
- shape = rep(shape, len=N)
+ N = max(length(q), length(location), length(scale),
+ length(inequality), length(shape))
+ q = rep(q, len = N); location = rep(location, len = N)
+ scale = rep(scale, len = N); inequality = rep(inequality, len = N)
+ shape = rep(shape, len = N)
answer = q * 0
ii = q > location
zedd = (q[ii] - location[ii]) / scale[ii]
@@ -7863,7 +7910,7 @@ pparetoIV = function(q, location = 0, scale = 1, inequality = 1, shape=1) {
answer
}
-qparetoIV = function(p, location = 0, scale = 1, inequality = 1, shape=1) {
+qparetoIV = function(p, location = 0, scale = 1, inequality = 1, shape = 1) {
if (!is.Numeric(p, posit = TRUE) || any(p >= 1))
stop("bad input for argument 'p'")
if (!is.Numeric(scale, posit = TRUE))
@@ -7875,7 +7922,7 @@ qparetoIV = function(p, location = 0, scale = 1, inequality = 1, shape=1) {
location + scale * (-1 + (1-p)^(-1/shape))^inequality
}
-rparetoIV = function(n, location = 0, scale = 1, inequality = 1, shape=1) {
+rparetoIV = function(n, location = 0, scale = 1, inequality = 1, shape = 1) {
if (!is.Numeric(n, posit = TRUE, integ = TRUE, allow = 1))
stop("bad input for argument n")
if (!is.Numeric(scale, posit = TRUE)) stop("bad input for argument 'scale'")
@@ -7892,15 +7939,15 @@ dparetoIII = function(x, location = 0, scale = 1, inequality = 1, log = FALSE)
pparetoIII = function(q, location = 0, scale = 1, inequality=1)
pparetoIV(q=q, location=location, scale = scale, inequality=inequality,
- shape=1)
+ shape = 1)
qparetoIII = function(p, location = 0, scale = 1, inequality=1)
qparetoIV(p=p, location=location, scale = scale, inequality=inequality,
- shape=1)
+ shape = 1)
rparetoIII = function(n, location = 0, scale = 1, inequality=1)
rparetoIV(n = n, location=location, scale = scale, inequality=inequality,
- shape=1)
+ shape = 1)
@@ -7909,29 +7956,29 @@ dparetoII = function(x, location = 0, scale = 1, shape = 1, log = FALSE)
inequality = 1, shape = shape,
log = log)
-pparetoII = function(q, location = 0, scale = 1, shape=1)
+pparetoII = function(q, location = 0, scale = 1, shape = 1)
pparetoIV(q=q, location=location, scale = scale,
inequality = 1, shape = shape)
-qparetoII = function(p, location = 0, scale = 1, shape=1)
+qparetoII = function(p, location = 0, scale = 1, shape = 1)
qparetoIV(p=p, location=location, scale = scale,
inequality = 1, shape = shape)
-rparetoII = function(n, location = 0, scale = 1, shape=1)
+rparetoII = function(n, location = 0, scale = 1, shape = 1)
rparetoIV(n = n, location=location, scale = scale,
inequality = 1, shape = shape)
-dparetoI = function(x, scale = 1, shape=1)
+dparetoI = function(x, scale = 1, shape = 1)
dparetoIV(x = x, location=scale, scale = scale, inequality = 1, shape = shape)
-pparetoI = function(q, scale = 1, shape=1)
+pparetoI = function(q, scale = 1, shape = 1)
pparetoIV(q=q, location=scale, scale = scale, inequality = 1, shape = shape)
-qparetoI = function(p, scale = 1, shape=1)
+qparetoI = function(p, scale = 1, shape = 1)
qparetoIV(p=p, location=scale, scale = scale, inequality = 1, shape = shape)
-rparetoI = function(n, scale = 1, shape=1)
+rparetoI = function(n, scale = 1, shape = 1)
rparetoIV(n = n, location=scale, scale = scale, inequality = 1, shape = shape)
@@ -8008,7 +8055,7 @@ rparetoI = function(n, scale = 1, shape=1)
.linequality = linequality, .lshape = lshape, .imethod = imethod,
.escale = escale, .einequality = einequality, .eshape = eshape,
.iscale = iscale, .iinequality=iinequality, .ishape = ishape ))),
- inverse = eval(substitute(function(eta, extra = NULL) {
+ linkinv = eval(substitute(function(eta, extra = NULL) {
location = extra$location
Scale = eta2theta(eta[,1], .lscale, earg = .escale)
inequality = eta2theta(eta[,2], .linequality, earg = .einequality)
@@ -8138,7 +8185,7 @@ rparetoI = function(n, scale = 1, shape=1)
}), list( .location = location, .lscale = lscale, .linequality = linequality,
.escale = escale, .einequality = einequality,
.iscale = iscale, .iinequality=iinequality ))),
- inverse = eval(substitute(function(eta, extra = NULL) {
+ linkinv = eval(substitute(function(eta, extra = NULL) {
location = extra$location
Scale = eta2theta(eta[,1], .lscale, earg = .escale)
inequality = eta2theta(eta[,2], .linequality, earg = .einequality)
@@ -8251,7 +8298,7 @@ rparetoI = function(n, scale = 1, shape=1)
}), list( .location = location, .lscale = lscale,
.escale = escale, .eshape = eshape,
.lshape = lshape, .iscale = iscale, .ishape = ishape ))),
- inverse = eval(substitute(function(eta, extra = NULL) {
+ linkinv = eval(substitute(function(eta, extra = NULL) {
location = extra$location
Scale = eta2theta(eta[,1], .lscale, earg = .escale)
shape = eta2theta(eta[,2], .lshape, earg = .eshape)
@@ -8315,7 +8362,7 @@ dpareto = function(x, location, shape, log = FALSE) {
rm(log)
L = max(length(x), length(location), length(shape))
- x = rep(x, len = L); location = rep(location, len = L); shape= rep(shape, len = L)
+ x = rep(x, len = L); location = rep(location, len = L); shape = rep(shape, len = L)
logdensity = rep(log(0), len = L)
xok = (x > location)
@@ -8328,7 +8375,7 @@ ppareto = function(q, location, shape) {
if (any(location <= 0)) stop("argument 'location' must be positive")
if (any(shape <= 0)) stop("argument 'shape' must be positive")
L = max(length(q), length(location), length(shape))
- q = rep(q, len = L); location = rep(location, len = L); shape= rep(shape, len = L)
+ q = rep(q, len = L); location = rep(location, len = L); shape = rep(shape, len = L)
ifelse(q > location, 1 - (location/q)^shape, 0)
}
@@ -8382,7 +8429,7 @@ rpareto = function(n, location, shape) {
}
}), list( .lshape = lshape, .earg = earg,
.location = location ))),
- inverse = eval(substitute(function(eta, extra = NULL) {
+ linkinv = eval(substitute(function(eta, extra = NULL) {
k = eta2theta(eta, .lshape, earg = .earg)
location = extra$location
ifelse(k > 1, k * location / (k-1), NA)
@@ -8468,7 +8515,7 @@ ptpareto = function(q, lower, upper, shape) {
L = max(length(q), length(lower), length(upper), length(shape))
q = rep(q, len = L); lower = rep(lower, len = L);
- upper = rep(upper, len = L); shape= rep(shape, len = L)
+ upper = rep(upper, len = L); shape = rep(shape, len = L)
ans = q * 0
xok <- (0 < lower) & (lower < q) & (q < upper) & (shape > 0)
@@ -8576,7 +8623,7 @@ rtpareto = function(n, lower, upper, shape) {
.ishape = ishape,
.imethod = imethod,
.lower = lower, .upper = upper ))),
- inverse = eval(substitute(function(eta, extra = NULL) {
+ linkinv = eval(substitute(function(eta, extra = NULL) {
shape = eta2theta(eta, .lshape, earg = .earg)
myratio = .lower / .upper
constprop = shape * .lower^shape / (1 - myratio^shape)
@@ -8660,7 +8707,7 @@ erfc = function(x)
}
}), list( .link.lambda = link.lambda, .earg = earg,
.init.lambda=init.lambda ))),
- inverse=function(eta, extra = NULL) {
+ linkinv = function(eta, extra = NULL) {
0*eta + 1
},
last = eval(substitute(expression({
@@ -8690,7 +8737,7 @@ erfc = function(x)
expexp = function(lshape = "loge", lscale = "loge",
eshape = list(), escale = list(),
- ishape=1.1, iscale = NULL, # ishape cannot be 1
+ ishape = 1.1, iscale = NULL, # ishape cannot be 1
tolerance = 1.0e-6,
zero = NULL) {
@@ -8737,7 +8784,7 @@ erfc = function(x)
}
}), list( .lshape = lshape, .lscale = lscale, .iscale = iscale, .ishape = ishape,
.eshape = eshape, .escale = escale ))),
- inverse = eval(substitute(function(eta, extra = NULL) {
+ linkinv = eval(substitute(function(eta, extra = NULL) {
shape = eta2theta(eta[,1], .lshape, earg = .eshape)
scale = eta2theta(eta[,2], .lscale, earg = .escale)
(digamma(shape+1)-digamma(1)) / scale
@@ -8817,7 +8864,7 @@ erfc = function(x)
expexp1 = function(lscale = "loge",
escale = list(),
iscale = NULL,
- ishape=1) {
+ ishape = 1) {
if (mode(lscale) != "character" && mode(lscale) != "name")
lscale = as.character(substitute(lscale))
if (!is.list(escale)) escale = list()
@@ -8851,7 +8898,7 @@ erfc = function(x)
}
}), list( .lscale = lscale, .iscale = iscale, .ishape = ishape,
.escale = escale ))),
- inverse = eval(substitute(function(eta, extra = NULL) {
+ linkinv = eval(substitute(function(eta, extra = NULL) {
scale = eta2theta(eta, .lscale, earg = .escale)
temp7 = -expm1(-scale*extra$yvector)
shape = -extra$sumw / sum(extra$w*log(temp7)) # \gamma(\theta)
@@ -8963,7 +9010,7 @@ betaffqn.control <- function(save.weight = TRUE, ...)
n,2,byrow = TRUE)
}
}), list( .link = link, .earg = earg, .i1=i1, .i2=i2, .trim=trim, .A = A, .B = B ))),
- inverse = eval(substitute(function(eta, extra = NULL) {
+ linkinv = eval(substitute(function(eta, extra = NULL) {
shapes = eta2theta(eta, .link, earg = .earg)
.A + ( .B-.A) * shapes[,1] / (shapes[,1] + shapes[,2])
}, list( .link = link, .earg = earg, .A = A, .B = B ))),
@@ -9053,9 +9100,11 @@ betaffqn.control <- function(save.weight = TRUE, ...)
initialize = eval(substitute(expression({
if (ncol(cbind(y)) != 1)
stop("response must be a vector or a one-column matrix")
+
predictors.names =
c(namesof("location", .llocation, earg = .elocation, tag = FALSE),
namesof("scale", .lscale, earg = .escale, tag = FALSE))
+
if (!length(etastart)) {
if ( .imethod == 1) {
location.init = y
@@ -9077,7 +9126,7 @@ betaffqn.control <- function(save.weight = TRUE, ...)
.elocation = elocation, .escale = escale,
.llocation = llocation, .lscale = lscale,
.ilocation = ilocation, .iscale = iscale ))),
- inverse = eval(substitute(function(eta, extra = NULL) {
+ linkinv = eval(substitute(function(eta, extra = NULL) {
eta2theta(eta[,1], .llocation, earg = .elocation)
}, list( .llocation = llocation,
.elocation = elocation, .escale = escale ))),
diff --git a/R/family.zeroinf.R b/R/family.zeroinf.R
index b8f44b2..ff67335 100644
--- a/R/family.zeroinf.R
+++ b/R/family.zeroinf.R
@@ -34,12 +34,12 @@ dzanegbin = function(x, p0, size, prob = NULL, munb = NULL, log = FALSE) {
if (log.arg) {
ans[ index0] = log(p0[index0])
ans[!index0] = log1p(-p0[!index0]) +
- dposnegbin(x[!index0], prob=prob[!index0],
- size=size[!index0], log = TRUE)
+ dposnegbin(x[!index0], prob = prob[!index0],
+ size = size[!index0], log = TRUE)
} else {
ans[ index0] = p0[index0]
ans[!index0] = (1-p0[!index0]) * dposnegbin(x[!index0],
- prob=prob[!index0], size=size[!index0])
+ prob = prob[!index0], size = size[!index0])
}
ans
}
@@ -62,7 +62,7 @@ pzanegbin = function(q, p0, size, prob = NULL, munb = NULL) {
if (!is.Numeric(p0) || any(p0 < 0) || any(p0 > 1))
stop("'p0' must be in [0,1]")
ans[q > 0] = p0[q > 0] + (1-p0[q > 0]) *
- pposnegbin(q[q > 0], size=size[q > 0], prob=prob[q > 0])
+ pposnegbin(q[q > 0], size = size[q > 0], prob = prob[q > 0])
ans[q < 0] = 0
ans[q == 0] = p0[q == 0]
ans
@@ -82,11 +82,11 @@ qzanegbin = function(p, p0, size, prob = NULL, munb = NULL) {
ans = rep(0.0, len = LLL)
if (!is.Numeric(p0) || any(p0 < 0) || any(p0 > 1))
- stop("'p0' must be between 0 and 1 inclusive")
+ stop("argument 'p0' must be between 0 and 1 inclusive")
ans = p
ans[p <= p0] = 0
- ans[p > p0] = qposnegbin((p[p>p0]-p0[p>p0])/(1-p0[p>p0]), prob=prob[p>p0],
- size=size[p>p0])
+ ans[p > p0] = qposnegbin((p[p>p0]-p0[p>p0])/(1-p0[p>p0]), prob = prob[p>p0],
+ size = size[p>p0])
ans
}
@@ -100,10 +100,10 @@ rzanegbin = function(n, p0, size, prob = NULL, munb = NULL) {
stop("'prob' and 'munb' both specified")
prob <- size/(size + munb)
}
- ans = rposnegbin(n=use.n, prob=prob, size=size)
- if (length(p0) != use.n) p0 = rep(p0, len=use.n)
+ ans = rposnegbin(n = use.n, prob = prob, size = size)
+ if (length(p0) != use.n) p0 = rep(p0, len = use.n)
if (!is.Numeric(p0) || any(p0 < 0) || any(p0 > 1))
- stop("'p0' must be between 0 and 1 inclusive")
+ stop("argument 'p0' must be between 0 and 1 inclusive")
ifelse(runif(use.n) < p0, 0, ans)
}
@@ -174,7 +174,7 @@ rzapois = function(n, lambda, p0=0) {
stop("bad input for argument 'n'") else n
ans = rpospois(use.n, lambda)
- if (length(p0) != use.n) p0 = rep(p0, len=use.n)
+ if (length(p0) != use.n) p0 = rep(p0, len = use.n)
if (!is.Numeric(p0) || any(p0 < 0) || any(p0 > 1))
stop("argument 'p0' must be between 0 and 1 inclusive")
ifelse(runif(use.n) < p0, 0, ans)
@@ -194,7 +194,7 @@ dzipois = function(x, lambda, phi = 0, log = FALSE) {
if (length(phi) != LLL) phi = rep(phi, len = LLL);
ans = rep(0.0, len = LLL)
if (!is.Numeric(phi) || any(phi < 0) || any(phi > 1))
- stop("'phi' must be between 0 and 1 inclusive")
+ stop("argument 'phi' must be between 0 and 1 inclusive")
index0 = (x == 0)
if (log.arg) {
@@ -210,13 +210,14 @@ dzipois = function(x, lambda, phi = 0, log = FALSE) {
ans
}
+
pzipois = function(q, lambda, phi = 0) {
ans = ppois(q, lambda)
LLL = max(length(phi), length(ans))
if (length(phi) != LLL) phi = rep(phi, len = LLL);
if (length(ans) != LLL) ans = rep(ans, len = LLL);
- ans = ifelse(q<0, 0, phi + (1-phi) * ans)
+ ans = ifelse(q < 0, 0, phi + (1-phi) * ans)
ans[phi < 0] = NaN
ans[phi > 1] = NaN
ans
@@ -289,11 +290,11 @@ rzipois = function(n, lambda, phi = 0) {
}
if (length(extra)) {
extra$sumw = sum(w)
- extra$narg = narg # For @inverse
+ extra$narg = narg # For @linkinv
} else
extra = list(sumw=sum(w), narg = narg)
}), list( .link.lambda = link.lambda, .n.arg = n.arg ))),
- inverse = eval(substitute(function(eta, extra = NULL) {
+ linkinv = eval(substitute(function(eta, extra = NULL) {
lambda = eta2theta(eta, .link.lambda)
temp5 = exp(-lambda)
phi = (1 - temp5 - extra$sumw/extra$narg) / (1 - temp5)
@@ -395,7 +396,7 @@ rzipois = function(n, lambda, phi = 0) {
}
}), list( .lp0 = lp0, .llambda = llambda,
.ep0 = ep0, .elambda = elambda ))),
- inverse = eval(substitute(function(eta, extra = NULL) {
+ linkinv = eval(substitute(function(eta, extra = NULL) {
NOS = extra$NOS
@@ -628,7 +629,7 @@ rzipois = function(n, lambda, phi = 0) {
.ep0 = ep0, .emunb = emunb, .esize = esize,
.ipnb0 = ipnb0, .isize = isize,
.imethod = imethod, .sinit = shrinkage.init ))),
- inverse = eval(substitute(function(eta, extra = NULL) {
+ linkinv = eval(substitute(function(eta, extra = NULL) {
NOS <- extra$NOS
p0 <- eta2theta(eta[,3*(1:NOS)-2],
.lp0, earg = .ep0 )
@@ -799,7 +800,7 @@ dposnegbin = function(x, munb, k, log = FALSE) {
stop("argument 'k' must be positive")
if (!is.Numeric(munb, posit = TRUE))
stop("argument 'munb' must be positive")
- ans = dnbinom(x=x, mu=munb, size=k, log=log)
+ ans = dnbinom(x = x, mu=munb, size=k, log=log)
ans0 = dnbinom(x=0, mu=munb, size=k, log = FALSE)
ans = if (log) ans - log1p(-ans0) else ans/(1-ans0)
ans[x == 0] = if (log) -Inf else 0
@@ -841,7 +842,7 @@ dposnegbin = function(x, munb, k, log = FALSE) {
"Mean: (1-phi)*lambda"),
constraints = eval(substitute(expression({
constraints <- cm.zero.vgam(constraints, x, .zero, M)
- }), list( .zero=zero ))),
+ }), list( .zero = zero ))),
initialize = eval(substitute(expression({
if (ncol(as.matrix(y)) != 1)
stop("multivariate responses not allowed")
@@ -898,7 +899,7 @@ dposnegbin = function(x, munb, k, log = FALSE) {
.ephi = ephi, .elambda = elambda,
.iphi = iphi, .ilambda = ilambda,
.imethod = imethod, .sinit = shrinkage.init ))),
- inverse = eval(substitute(function(eta, extra = NULL) {
+ linkinv = eval(substitute(function(eta, extra = NULL) {
phivec = eta2theta(eta[, 1], .lphi, earg = .ephi )
lambda = eta2theta(eta[, 2], .llambda, earg = .elambda )
(1 - phivec) * lambda
@@ -969,9 +970,16 @@ dposnegbin = function(x, munb, k, log = FALSE) {
+
+
+
+
+
+
zibinomial = function(lphi = "logit", lmu = "logit",
ephi = list(), emu = list(),
- iphi = NULL, zero = 1, mv = FALSE)
+ iphi = NULL, zero = 1, mv = FALSE,
+ imethod = 1)
{
if (as.logical(mv)) stop("argument 'mv' must be FALSE")
if (mode(lphi) != "character" && mode(lphi) != "name")
@@ -983,6 +991,10 @@ dposnegbin = function(x, munb, k, log = FALSE) {
stop("'iphi' values must be inside the interval (0,1)")
if (!is.list(ephi)) ephi = list()
if (!is.list(emu)) emu = list()
+ if (!is.Numeric(imethod, allow = 1, integ = TRUE, posit = TRUE) ||
+ imethod > 2)
+ stop("argument 'imethod' must be 1 or 2")
+
new("vglmff",
blurb = c("Zero-inflated binomial\n\n",
@@ -992,7 +1004,7 @@ dposnegbin = function(x, munb, k, log = FALSE) {
"Mean: (1-phi) * mu / (1 - (1-mu)^w)"),
constraints = eval(substitute(expression({
constraints <- cm.zero.vgam(constraints, x, .zero, M)
- }), list( .zero=zero ))),
+ }), list( .zero = zero ))),
initialize = eval(substitute(expression({
if (!all(w == 1))
extra$orig.w = w
@@ -1009,7 +1021,7 @@ dposnegbin = function(x, munb, k, log = FALSE) {
if (!all(y >= 0 & y <= 1))
stop("response values must be in [0, 1]")
if (!length(mustart) && !length(etastart))
- mustart = (0.5 + w * y) / (1 + w)
+ mustart = (0.5 + w * y) / (1.0 + w)
no.successes = y
@@ -1032,87 +1044,124 @@ dposnegbin = function(x, munb, k, log = FALSE) {
} else {
stop("for the binomialff family, response 'y' must be a ",
"vector of 0 and 1's\n",
- "or a factor (first level = fail, other levels = success),\n",
+ "or a factor ",
+ "(first level = fail, other levels = success),\n",
"or a 2-column matrix where col 1 is the no. of ",
"successes and col 2 is the no. of failures")
}
}
+
+
+
+
predictors.names =
c(namesof("phi", .lphi, earg = .ephi, tag = FALSE),
namesof("mu", .lmu, earg = .emu, tag = FALSE))
+
+
phi.init = if (length( .iphi )) .iphi else {
- sum(w[y == 0]) / sum(w)
+ prob0.est = sum(w[y == 0]) / sum(w)
+ if ( .imethod == 1) {
+ (prob0.est - (1 - mustart)^w) / (1 - (1 - mustart)^w)
+ } else {
+ prob0.est
+ }
}
- phi.init[phi.init <= 0.0] = 0.1 # Last resort
- phi.init[phi.init >= 1.0] = 0.9 # Last resort
+
+ phi.init[phi.init <= -0.10] = 0.50 # Lots of sample variation
+ phi.init[phi.init <= 0.01] = 0.05 # Last resort
+ phi.init[phi.init >= 0.99] = 0.95 # Last resort
+
if ( length(mustart) && !length(etastart))
mustart = cbind(rep(phi.init, len = n),
mustart) # 1st coln not a real mu
}), list( .lphi = lphi, .lmu = lmu,
- .ephi = ephi, .emu=emu,
- .iphi = iphi ))),
- inverse = eval(substitute(function(eta, extra = NULL) {
+ .ephi = ephi, .emu = emu,
+ .iphi = iphi,
+ .imethod = imethod ))),
+ linkinv = eval(substitute(function(eta, extra = NULL) {
phi = eta2theta(eta[, 1], .lphi, earg = .ephi )
mubin = eta2theta(eta[, 2], .lmu, earg = .emu )
(1-phi) * mubin
}, list( .lphi = lphi, .lmu = lmu,
- .ephi = ephi, .emu=emu ))),
+ .ephi = ephi, .emu = emu ))),
last = eval(substitute(expression({
misc$link = c("phi" = .lphi, "mu" = .lmu)
misc$earg = list("phi" = .ephi, "mu" = .emu )
+ misc$imethod = .imethod
+
+
if (intercept.only && all(w == w[1])) {
phi = eta2theta(eta[1,1], .lphi, earg = .ephi )
mubin = eta2theta(eta[1,2], .lmu, earg = .emu )
misc$p0 = phi + (1-phi) * (1-mubin)^w[1] # P(Y=0)
}
}), list( .lphi = lphi, .lmu = lmu,
- .ephi = ephi, .emu = emu ))),
- link = eval(substitute(function(mu, extra = NULL) {
+ .ephi = ephi, .emu = emu,
+ .imethod = imethod ))),
+ linkfun = eval(substitute(function(mu, extra = NULL) {
cbind(theta2eta(mu[, 1], .lphi, earg = .ephi ),
theta2eta(mu[, 2], .lmu, earg = .emu ))
}, list( .lphi = lphi, .lmu = lmu,
- .ephi = ephi, .emu=emu ))),
+ .ephi = ephi, .emu = emu ))),
loglikelihood = eval(substitute(
function(mu, y, w, residuals = FALSE, eta, extra = NULL) {
phi = eta2theta(eta[, 1], .lphi, earg = .ephi )
mubin = eta2theta(eta[, 2], .lmu, earg = .emu )
if (residuals) stop("loglikelihood residuals not ",
"implemented yet") else {
- sum(dzibinom(x=round(w*y), size=w, prob=mubin, log = TRUE, phi = phi))
+ sum(dzibinom(x = round(w * y), size = w, prob = mubin,
+ log = TRUE, phi = phi))
}
}, list( .lphi = lphi, .lmu = lmu,
- .ephi = ephi, .emu=emu ))),
+ .ephi = ephi, .emu = emu ))),
vfamily = c("zibinomial"),
deriv = eval(substitute(expression({
- phi = eta2theta(eta[, 1], .lphi, earg = .ephi )
- mubin = eta2theta(eta[, 2], .lmu, earg = .emu )
- prob0 = (1-mubin)^w # Actually q^w
- tmp8 = phi + (1-phi)*prob0
+ phi = eta2theta(eta[, 1], .lphi, earg = .ephi )
+ mubin = eta2theta(eta[, 2], .lmu, earg = .emu )
+
+ prob0 = (1 - mubin)^w # Actually q^w
+ tmp8 = phi + (1 - phi) * prob0
index = (y == 0)
- dl.dphi = (1-prob0) / tmp8
- dl.dphi[!index] = -1 / (1-phi[!index])
- dl.dmubin = -w * (1-phi) * (1-mubin)^(w-1) / tmp8
- dl.dmubin[!index] = w[!index] * (y[!index]/mubin[!index] -
- (1-y[!index]) / (1-mubin[!index]))
- dphi.deta = dtheta.deta(phi, .lphi, earg = .ephi )
- dmubin.deta = dtheta.deta(mubin, .lmu, earg = .emu )
- ans = cbind(dl.dphi * dphi.deta, dl.dmubin * dmubin.deta)
- if (.lmu == "logit") {
+ dl.dphi = (1 - prob0) / tmp8
+ dl.dphi[!index] = -1 / (1 - phi[!index])
+ dl.dmubin = -w * (1 - phi) * (1 - mubin)^(w - 1) / tmp8
+ dl.dmubin[!index] = w[!index] *
+ (y[!index] / mubin[!index] -
+ (1 - y[!index]) / (1 - mubin[!index]))
+ dphi.deta = dtheta.deta(phi, .lphi, earg = .ephi )
+ dmubin.deta = dtheta.deta(mubin, .lmu, earg = .emu )
+ ans = cbind(dl.dphi * dphi.deta,
+ dl.dmubin * dmubin.deta)
+ if ( .lmu == "logit") {
ans[!index,2] = w[!index] * (y[!index] - mubin[!index])
}
ans
}), list( .lphi = lphi, .lmu = lmu,
- .ephi = ephi, .emu=emu ))),
+ .ephi = ephi, .emu = emu ))),
weight = eval(substitute(expression({
wz = matrix(as.numeric(NA), nrow = n, ncol = dimm(M))
- d2l.dphi2 = (1-mubin^w) / ((1-phi) * tmp8)
- d2l.dmubin2 = w * (1-phi) * ((1 - mubin * (1-mubin)^(w-1)) /
- (mubin*(1-mubin)) - mubin^(w-2) * (w*phi-tmp8) / tmp8)
- d2l.dphimubin = -w * (1-mubin)^(w-1) / tmp8
- wz[,iam(1,1,M)] = d2l.dphi2 * dphi.deta^2
- wz[,iam(2,2,M)] = d2l.dmubin2 * dmubin.deta^2
+
+
+
+ d2l.dphi2 = (1 - prob0) / ((1 - phi) * tmp8)
+
+
+ d2l.dphimubin = -w * (1 - mubin)^(w - 1) / tmp8
+
+
+
+
+ d2l.dmubin2 = w * (1 - phi) *
+ (1 / (mubin * (1 - mubin)) -
+ (tmp8 * (w - 1) * (1 - mubin)^(w - 2) -
+ (1 - phi) * w * (1 - mubin)^(2*(w - 1))) / tmp8)
+
+
+ wz[,iam(1,1,M)] = d2l.dphi2 * dphi.deta^2
+ wz[,iam(2,2,M)] = d2l.dmubin2 * dmubin.deta^2
wz[,iam(1,2,M)] = d2l.dphimubin * dphi.deta * dmubin.deta
if (TRUE) {
ind6 = (wz[,iam(2,2,M)] < .Machine$double.eps)
@@ -1121,7 +1170,7 @@ dposnegbin = function(x, munb, k, log = FALSE) {
}
wz
}), list( .lphi = lphi, .lmu = lmu,
- .ephi = ephi, .emu=emu ))))
+ .ephi = ephi, .emu = emu ))))
}
@@ -1135,9 +1184,9 @@ dzibinom = function(x, size, prob, log = FALSE, phi = 0) {
if (length(size) != LLL) size = rep(size, len = LLL);
if (length(prob) != LLL) prob = rep(prob, len = LLL);
if (length(phi) != LLL) phi = rep(phi, len = LLL);
- ans = dbinom(x=x, size=size, prob=prob, log = TRUE)
+ ans = dbinom(x = x, size = size, prob = prob, log = TRUE)
if (!is.Numeric(phi) || any(phi < 0) || any(phi > 1))
- stop("'phi' must be between 0 and 1 inclusive")
+ stop("argument 'phi' must be between 0 and 1 inclusive")
if (log.arg) {
ifelse(x == 0, log(phi + (1-phi) * exp(ans)), log1p(-phi) + ans)
} else {
@@ -1145,14 +1194,16 @@ dzibinom = function(x, size, prob, log = FALSE, phi = 0) {
}
}
+
pzibinom = function(q, size, prob, lower.tail = TRUE, log.p = FALSE, phi = 0) {
ans = pbinom(q, size, prob, lower.tail = lower.tail, log.p = log.p)
phi = rep(phi, length=length(ans))
if (!is.Numeric(phi) || any(phi < 0) || any(phi > 1))
- stop("'phi' must be between 0 and 1 inclusive")
+ stop("argument 'phi' must be between 0 and 1 inclusive")
phi + (1-phi) * ans
}
+
qzibinom = function(p, size, prob, lower.tail = TRUE, log.p = FALSE, phi = 0) {
nn = max(length(p), length(size), length(prob), length(phi))
p = rep(p, len=nn)
@@ -1160,7 +1211,7 @@ qzibinom = function(p, size, prob, lower.tail = TRUE, log.p = FALSE, phi = 0) {
prob = rep(prob, len=nn)
phi = rep(phi, len=nn)
if (!is.Numeric(phi) || any(phi < 0) || any(phi > 1))
- stop("'phi' must be between 0 and 1 inclusive")
+ stop("argument 'phi' must be between 0 and 1 inclusive")
ans = p
ans[p<=phi] = 0
ans[p>phi] = qbinom((p[p>phi]-phi[p>phi])/(1-phi[p>phi]), size[p>phi],
@@ -1168,13 +1219,14 @@ qzibinom = function(p, size, prob, lower.tail = TRUE, log.p = FALSE, phi = 0) {
ans
}
+
rzibinom = function(n, size, prob, phi = 0) {
if (!is.Numeric(n, positive = TRUE, integer = TRUE, allow = 1))
stop("n must be a single positive integer")
ans = rbinom(n, size, prob)
phi = rep(phi, len=length(ans))
if (!is.Numeric(phi) || any(phi < 0) || any(phi > 1))
- stop("'phi' must be between 0 and 1 inclusive")
+ stop("argument 'phi' must be between 0 and 1 inclusive")
ifelse(runif(n) < phi, 0, ans)
}
@@ -1199,9 +1251,9 @@ dzinegbin = function(x, phi, size, prob = NULL, munb = NULL, log = FALSE) {
rm(log)
if (!is.logical(log.arg) || length(log.arg) != 1)
stop("bad input for 'log.arg'")
- ans = dnbinom(x=x, size=size, prob=prob, log = log.arg)
+ ans = dnbinom(x = x, size = size, prob = prob, log = log.arg)
if (!is.Numeric(phi) || any(phi < 0) || any(phi > 1))
- stop("'phi' must be between 0 and 1 inclusive")
+ stop("argument 'phi' must be between 0 and 1 inclusive")
phi = rep(phi, length=length(ans))
if (log.arg)
ifelse(x == 0, log(phi+(1-phi)*exp(ans)), log1p(-phi) + ans) else
@@ -1215,9 +1267,9 @@ pzinegbin = function(q, phi, size, prob = NULL, munb = NULL) {
stop("'prob' and 'munb' both specified")
prob <- size/(size + munb)
}
- ans = pnbinom(q=q, size=size, prob=prob)
+ ans = pnbinom(q=q, size = size, prob = prob)
if (!is.Numeric(phi) || any(phi < 0) || any(phi > 1))
- stop("'phi' must be between 0 and 1 inclusive")
+ stop("argument 'phi' must be between 0 and 1 inclusive")
phi + (1-phi) * ans
}
@@ -1235,12 +1287,12 @@ qzinegbin = function(p, phi, size, prob = NULL, munb = NULL) {
if (length(size) != LLL) size = rep(size, len = LLL);
if (!is.Numeric(phi) || any(phi < 0) || any(phi > 1))
- stop("'phi' must be between 0 and 1 inclusive")
+ stop("argument 'phi' must be between 0 and 1 inclusive")
ans = p
ind4 = (p > phi)
ans[!ind4] = 0
ans[ ind4] = qnbinom(p = (p[ind4]-phi[ind4])/(1-phi[ind4]),
- size=size[ind4], prob=prob[ind4])
+ size = size[ind4], prob = prob[ind4])
ans
}
@@ -1256,9 +1308,9 @@ rzinegbin = function(n, phi, size, prob = NULL, munb = NULL) {
if (!is.Numeric(n, integ = TRUE, allow = 1, posit = TRUE))
stop("bad input for argument 'n'") else n
- ans = rnbinom(n=use.n, size=size, prob=prob)
+ ans = rnbinom(n = use.n, size = size, prob = prob)
if (!is.Numeric(phi) || any(phi < 0) || any(phi > 1))
- stop("'phi' must be between 0 and 1 inclusive")
+ stop("'argument phi' must be between 0 and 1 inclusive")
phi = rep(phi, len=length(ans))
ifelse(runif(use.n) < phi, rep(0, use.n), ans)
}
@@ -1396,7 +1448,7 @@ zinegbinomial.control <- function(save.weight = TRUE, ...)
.ephi = ephi, .emunb = emunb, .esize = esize,
.iphi = iphi, .isize = isize,
.sinit = shrinkage.init, .imethod = imethod ))),
- inverse = eval(substitute(function(eta, extra = NULL) {
+ linkinv = eval(substitute(function(eta, extra = NULL) {
NOS = extra$NOS
phi = eta2theta(eta[,3*(1:NOS)-2, drop = FALSE],
.lphi, earg = .ephi )
@@ -1676,7 +1728,7 @@ zinegbinomial.control <- function(save.weight = TRUE, ...)
.eprobp. = eprobp., .elambda = elambda,
.iprobp. = iprobp., .ilambda = ilambda,
.imethod = imethod, .sinit = shrinkage.init ))),
- inverse = eval(substitute(function(eta, extra = NULL) {
+ linkinv = eval(substitute(function(eta, extra = NULL) {
ncoly <- extra$ncoly
lambda <- eta2theta(eta[, 2*(1:ncoly) - 1], .llambda, earg = .elambda )
probp. <- eta2theta(eta[, 2*(1:ncoly) ], .lprobp., earg = .eprobp. )
@@ -1793,3 +1845,288 @@ zinegbinomial.control <- function(save.weight = TRUE, ...)
+
+
+
+
+dzigeom = function(x, prob, pszero = 0, log = FALSE) {
+ if (!is.logical(log.arg <- log))
+ stop("bad input for argument 'log'")
+ rm(log)
+
+ LLL = max(length(x), length(prob), length(pszero))
+ if (length(x) != LLL) x = rep(x, len = LLL);
+ if (length(prob) != LLL) prob = rep(prob, len = LLL);
+ if (length(pszero) != LLL) pszero = rep(pszero, len = LLL);
+
+
+ ans = dgeom(x = x, prob = prob, log = TRUE)
+
+ ans[pszero < 0] = NaN
+ ans[pszero > 1] = NaN
+
+ if (log.arg) {
+ ifelse(x == 0, log(pszero + (1-pszero) * exp(ans)),
+ log1p(-pszero) + ans)
+ } else {
+ ifelse(x == 0, pszero + (1-pszero) * exp(ans) ,
+ (1-pszero) * exp(ans))
+ }
+}
+
+
+
+pzigeom = function(q, prob, pszero = 0) {
+ answer = pgeom(q, prob)
+ LLL = max(length(pszero), length(answer))
+ if (length(pszero) != LLL) pszero = rep(pszero, len = LLL);
+ if (length(answer) != LLL) answer = rep(answer, len = LLL);
+
+ answer = ifelse(q < 0, 0, pszero + (1-pszero) * answer)
+ answer[pszero < 0] = NaN
+ answer[pszero > 1] = NaN
+ answer
+}
+
+
+
+qzigeom = function(p, prob, pszero = 0) {
+ LLL = max(length(p), length(prob), length(pszero))
+ answer = p = rep(p, len = LLL)
+ prob = rep(prob, len = LLL)
+ pszero = rep(pszero, len = LLL)
+ answer[p <= pszero] = 0
+ ind1 = (p > pszero)
+ answer[ind1] =
+ qgeom((p[ind1] - pszero[ind1]) / (1 - pszero[ind1]),
+ prob = prob[ind1])
+ answer[pszero < 0] = NaN
+ answer[pszero > 1] = NaN
+ answer
+}
+
+
+
+rzigeom = function(n, prob, pszero = 0) {
+ use.n = if ((length.n <- length(n)) > 1) length.n else
+ if (!is.Numeric(n, integ = TRUE, allow = 1, posit = TRUE))
+ stop("bad input for argument 'n'") else n
+
+ ans = rgeom(use.n, prob)
+ pszero = rep(pszero, len = length(ans))
+ if (!is.Numeric(pszero) || any(pszero < 0) || any(pszero > 1))
+ stop("argument 'pszero' must be between 0 and 1 inclusive")
+
+ ans[runif(use.n) < pszero] = 0
+ ans
+}
+
+
+
+
+
+ zigeometric = function(lprob = "logit", eprob = list(),
+ lpszero = "logit", epszero = list(),
+ iprob = NULL, ipszero = NULL,
+ imethod = 1,
+ bias.red = 0.5,
+ zero = 2)
+{
+
+
+ expected = TRUE
+
+ if (mode(lprob) != "character" && mode(lprob) != "name")
+ lprob = as.character(substitute(lprob))
+ if (mode(lpszero) != "character" && mode(lpszero) != "name")
+ lpszero = as.character(substitute(lpszero))
+
+ if (!is.list(eprob)) eprob = list()
+ if (!is.list(epszero)) epszero = list()
+
+
+ if (length(iprob))
+ if (!is.Numeric(iprob, posit = TRUE) ||
+ iprob >= 1)
+ stop("argument 'iprob' is out of range")
+ if (length(ipszero))
+ if (!is.Numeric(ipszero, posit = TRUE) ||
+ ipszero >= 1)
+ stop("argument 'ipszero' is out of range")
+
+ if (!is.Numeric(bias.red, allow = 1, posit = TRUE) ||
+ bias.red > 1)
+ stop("argument 'bias.red' must be between 0 and 1")
+
+
+ if (!is.Numeric(imethod, allow = 1, integ = TRUE, posit = TRUE) ||
+ imethod > 3)
+ stop("argument 'imethod' must be 1 or 2 or 3")
+
+
+ new("vglmff",
+ blurb = c("Zero-inflated geometric distribution,\n",
+ "P[Y = 0] = pszero + (1 - pszero) * prob,\n",
+ "P[Y = y] = (1 - pszero) * prob * (1 - prob)^y, ",
+ "y = 1, 2, ...\n\n",
+ "Link: ",
+ namesof("prob", lprob, earg = eprob), ", ",
+ namesof("pszero", lpszero, earg = epszero), "\n",
+ "Mean: (1 - pszero) * (1 - prob) / prob"),
+ constraints = eval(substitute(expression({
+ constraints <- cm.zero.vgam(constraints, x, .zero, M)
+ }), list( .zero = zero ))),
+ initialize = eval(substitute(expression({
+ if (ncol(cbind(y)) != 1)
+ stop("response must be a vector or a 1-column matrix")
+
+ if (any(y < 0))
+ stop("all responses must be >= 0")
+ if (any(y != round(y)))
+ stop("response should be integer-valued")
+
+ predictors.names =
+ c(namesof("prob", .lprob, earg = .earg, tag = FALSE),
+ namesof("pszero", .lpszero, earg = .epszero, tag = FALSE))
+
+ if (!length(etastart)) {
+ prob.init = if ( .imethod == 3)
+ .bias.red / (1 + y + 1/8) else
+ if ( .imethod == 2)
+ .bias.red / (1 + mean(y) + 1/8) else
+ .bias.red / (1 + weighted.mean(y, w) + 1/8)
+ prob.init = if(length( .iprob )) {
+ rep( .iprob, len = n)
+ } else {
+ rep(prob.init, len = n)
+ }
+
+
+ prob0.est = sum(w[y == 0]) / sum(w)
+ psze.init = if ( .imethod == 3)
+ prob0.est / 2 else
+ if ( .imethod == 1)
+ max(0.05, (prob0.est - median(prob.init))) else
+ prob0.est / 5
+ psze.init = if(length( .ipszero )) {
+ rep( .ipszero, len = n)
+ } else {
+ rep( psze.init, len = n)
+ }
+
+
+
+ etastart =
+ cbind(theta2eta(prob.init, .lprob, earg = .eprob),
+ theta2eta(psze.init, .lpszero, earg = .epszero))
+
+ }
+ }), list( .lprob = lprob, .lpszero = lpszero,
+ .eprob = eprob, .epszero = epszero,
+ .iprob = iprob, .ipszero = ipszero,
+ .bias.red = bias.red,
+ .imethod = imethod ))),
+ linkinv = eval(substitute(function(eta, extra = NULL) {
+ prob = eta2theta(eta[, 1], .lprob, earg = .eprob)
+ pszero = eta2theta(eta[, 2], .lpszero , earg = .epszero )
+ (1 - pszero) * (1 - prob) / prob
+ }, list( .lprob = lprob, .lpszero = lpszero,
+ .eprob = eprob, .epszero = epszero ))),
+ last = eval(substitute(expression({
+ misc$link = c(prob = .lprob, pszero = .lpszero )
+ misc$earg = list(prob = .eprob, pszero = .epszero )
+ misc$imethod = .imethod
+ misc$zero = .zero
+ misc$bias.red = .bias.red
+ misc$expected = .expected
+
+
+ }), list( .lprob = lprob, .lpszero = lpszero,
+ .eprob = eprob, .epszero = epszero,
+ .zero = zero,
+ .expected = expected,
+ .bias.red = bias.red,
+ .imethod = imethod ))),
+ loglikelihood = eval(substitute(
+ function(mu, y, w, residuals = FALSE, eta, extra = NULL) {
+ prob = eta2theta(eta[, 1], .lprob, earg = .eprob)
+ pszero = eta2theta(eta[, 2], .lpszero , earg = .epszero )
+ if (residuals) stop("loglikelihood residuals not ",
+ "implemented yet") else {
+ sum(w * dzigeom(x = y, prob = prob, pszero = pszero, log = TRUE))
+ }
+ }, list( .lprob = lprob, .lpszero = lpszero,
+ .eprob = eprob, .epszero = epszero ))),
+ vfamily = c("zigeometric"),
+
+ deriv = eval(substitute(expression({
+ prob = eta2theta(eta[, 1], .lprob, earg = .eprob)
+ pszero = eta2theta(eta[, 2], .lpszero , earg = .epszero )
+
+
+ prob0 = prob # P(Y == 0)
+ tmp8 = pszero + (1 - pszero) * prob0
+ index0 = (y == 0)
+
+ dl.dpszero = (1 - prob0) / tmp8
+ dl.dpszero[!index0] = -1 / (1 - pszero[!index0])
+
+ dl.dprob = (1 - pszero) / tmp8
+ dl.dprob[!index0] = 1 / prob[!index0] -
+ y[!index0] / (1 - prob[!index0])
+
+ dprob.deta = dtheta.deta(prob, .lprob, earg = .eprob )
+ dpszero.deta = dtheta.deta(pszero , .lpszero , earg = .epszero )
+
+ myderiv =
+ c(w) * cbind(dl.dprob * dprob.deta,
+ dl.dpszero * dpszero.deta)
+ myderiv
+ }), list( .lprob = lprob, .lpszero = lpszero,
+ .eprob = eprob, .epszero = epszero ))),
+ weight = eval(substitute(expression({
+ ed2l.dprob2 = (1 - pszero) * (1 / (prob^2 * (1 - prob)) +
+ (1 - pszero) / tmp8)
+ ed2l.dpszero.prob = 1 / tmp8
+ ed2l.dpszero2 = (1 - prob0) / ((1 - pszero) * tmp8)
+
+ od2l.dprob2 = ((1 - pszero) / tmp8)^2
+ od2l.dprob2[!index0] = 1 / (prob[!index0])^2 +
+ y[!index0] / (1 - prob[!index0])^2
+ od2l.dpszero.prob = (tmp8 + (1 - prob0) * (1 - pszero)) / tmp8^2
+ od2l.dpszero.prob[!index0] = 0
+
+
+ od2l.dpszero2 = ((1 - prob0) / tmp8)^2
+ od2l.dpszero2[!index0] = 1 / (1 - pszero[!index0])^2
+
+
+ wz = matrix(as.numeric(NA), nrow = n, ncol = dimm(M))
+ if ( .expected ) {
+ wz[,iam(1,1,M)] = ed2l.dprob2 * dprob.deta^2
+ wz[,iam(2,2,M)] = ed2l.dpszero2 * dpszero.deta^2
+ wz[,iam(1,2,M)] = ed2l.dpszero.prob * dprob.deta * dpszero.deta
+ } else {
+ wz[,iam(1,1,M)] = od2l.dprob2 * dprob.deta^2
+ wz[,iam(2,2,M)] = od2l.dpszero2 * dpszero.deta^2
+ wz[,iam(1,2,M)] = od2l.dpszero.prob * dprob.deta * dpszero.deta
+ }
+
+
+
+ c(w) * wz
+ }), list( .lprob = lprob, .lpszero = lpszero,
+ .expected = expected,
+ .eprob = eprob, .epszero = epszero ))))
+}
+
+
+
+
+
+
+
+
+
+
+
diff --git a/R/fitted.vlm.R b/R/fittedvlm.R
similarity index 86%
rename from R/fitted.vlm.R
rename to R/fittedvlm.R
index e8d618f..88180f6 100644
--- a/R/fitted.vlm.R
+++ b/R/fittedvlm.R
@@ -4,7 +4,16 @@
-fitted.vlm <- function(object, matrix.arg=TRUE, ...)
+
+
+
+
+
+
+
+
+
+fittedvlm <- function(object, matrix.arg=TRUE, ...)
{
answer =
@@ -27,21 +36,31 @@ fitted.vlm <- function(object, matrix.arg=TRUE, ...)
}
}
+
+
+if(!isGeneric("fitted"))
+ setGeneric("fitted", function(object, ...) standardGeneric("fitted"))
+
+
+
+
+
+
setMethod("fitted.values", "vlm",
function(object, ...)
- fitted.vlm(object, ...))
+ fittedvlm(object, ...))
setMethod("fitted", "vlm",
function(object, ...)
- fitted.vlm(object, ...))
+ fittedvlm(object, ...))
setMethod("fitted.values", "vglm",
function(object, ...)
- fitted.vlm(object, ...))
+ fittedvlm(object, ...))
setMethod("fitted", "vglm",
function(object, ...)
- fitted.vlm(object, ...))
+ fittedvlm(object, ...))
predictors.vglm <- function(object, matrix=TRUE, ...)
diff --git a/R/links.q b/R/links.q
index e456aba..2922af8 100644
--- a/R/links.q
+++ b/R/links.q
@@ -151,7 +151,8 @@ TypicalVGAMlinkFunction <- function(theta,
theta[theta <= 1.0] <- earg$bval
if (inverse) {
if (deriv > 0) {
- 1 / Recall(theta = theta, earg = earg, inverse = FALSE, deriv = deriv)
+ 1 / Recall(theta = theta, earg = earg,
+ inverse = FALSE, deriv = deriv)
} else {
exp(exp(theta))
}
@@ -162,7 +163,7 @@ TypicalVGAMlinkFunction <- function(theta,
{ junk <- log(theta)
-junk^2 / (1 + junk)
},
- stop("'deriv' unmatched"))
+ stop("argument 'deriv' unmatched"))
}
}
@@ -186,19 +187,20 @@ TypicalVGAMlinkFunction <- function(theta,
}
if (inverse) {
if (deriv > 0) {
- 1 / Recall(theta = theta, earg = earg, inverse = FALSE, deriv = deriv)
+ 1 / Recall(theta = theta, earg = earg,
+ inverse = FALSE, deriv = deriv)
} else {
junk <- exp(theta)
-expm1(-junk)
}
} else {
switch(deriv+1, {
- log(-log1p(-theta))},
- -(1-theta) * log1p(-theta),
+ log(-log1p(-theta)) },
+ -(1 - theta) * log1p(-theta),
{ junk <- log1p(-theta)
- -(1-theta) * (1 + junk) * junk
+ -(1 - theta) * (1 + junk) * junk
},
- stop("'deriv' unmatched"))
+ stop("argument 'deriv' unmatched"))
}
}
@@ -222,7 +224,8 @@ TypicalVGAMlinkFunction <- function(theta,
}
if (inverse) {
if (deriv > 0) {
- 1/Recall(theta = theta, earg = earg, inverse = FALSE, deriv = deriv)
+ 1 / Recall(theta = theta, earg = earg,
+ inverse = FALSE, deriv = deriv)
} else {
ans <- pnorm(theta)
if (is.matrix(theta))
@@ -266,6 +269,39 @@ TypicalVGAMlinkFunction <- function(theta,
+ explink <- function(theta, earg = list(), inverse = FALSE, deriv = 0,
+ short = TRUE, tag = FALSE)
+{
+ if (is.character(theta)) {
+ string <- if (short)
+ paste("exp(", theta, ")", sep = "") else
+ paste("exp(", theta, ")", sep = "")
+ if (tag)
+ string <- paste("Exp:", string)
+ return(string)
+ }
+ if (!inverse && is.list(earg) && length(earg$bval))
+ theta[theta <= 0.0] <- earg$bval
+ if (inverse) {
+ if (deriv > 0) {
+ 1 / Recall(theta = theta, earg = earg,
+ inverse = FALSE, deriv = deriv)
+ } else {
+ log(theta)
+ }
+ } else {
+ switch(deriv+1, {
+ exp(theta)},
+ 1 / exp(theta),
+ -1 / exp(theta * 2))
+ }
+}
+
+
+
+
+
+
loge <- function(theta, earg = list(), inverse = FALSE, deriv = 0,
short = TRUE, tag = FALSE)
{
@@ -281,7 +317,8 @@ TypicalVGAMlinkFunction <- function(theta,
theta[theta <= 0.0] <- earg$bval
if (inverse) {
if (deriv > 0) {
- 1/Recall(theta = theta, earg = earg, inverse = FALSE, deriv = deriv)
+ 1 / Recall(theta = theta, earg = earg,
+ inverse = FALSE, deriv = deriv)
} else {
exp(theta)
}
@@ -296,6 +333,8 @@ TypicalVGAMlinkFunction <- function(theta,
+
+
identity <- function(theta, earg = list(), inverse = FALSE, deriv = 0,
short = TRUE, tag = FALSE) {
if (is.character(theta)) {
@@ -306,7 +345,8 @@ TypicalVGAMlinkFunction <- function(theta,
}
if (inverse) {
if (deriv > 0) {
- 1 / Recall(theta = theta, earg = earg, inverse = FALSE, deriv = deriv)
+ 1 / Recall(theta = theta, earg = earg,
+ inverse = FALSE, deriv = deriv)
} else {
theta
}
@@ -329,7 +369,8 @@ TypicalVGAMlinkFunction <- function(theta,
}
if (inverse) {
if (deriv > 0) {
- 1 / Recall(theta = theta, earg = earg, inverse = FALSE, deriv = deriv)
+ 1 / Recall(theta = theta, earg = earg,
+ inverse = FALSE, deriv = deriv)
} else {
-theta
}
@@ -355,7 +396,8 @@ TypicalVGAMlinkFunction <- function(theta,
theta[theta == 0.0] <- earg$bval
if (inverse.arg) {
if (deriv > 0) {
- 1 / Recall(theta = theta, earg = earg, inverse.arg = FALSE, deriv = deriv)
+ 1 / Recall(theta = theta, earg = earg,
+ inverse.arg = FALSE, deriv = deriv)
} else {
1/theta
}
@@ -382,7 +424,8 @@ TypicalVGAMlinkFunction <- function(theta,
theta[theta <= 0.0] <- earg$bval
if (inverse) {
if (deriv > 0) {
- 1/Recall(theta = theta, earg = earg, inverse = FALSE, deriv = deriv)
+ 1 / Recall(theta = theta, earg = earg,
+ inverse = FALSE, deriv = deriv)
} else {
exp(-theta)
}
@@ -396,8 +439,8 @@ TypicalVGAMlinkFunction <- function(theta,
- nreciprocal <- function(theta, earg = list(), inverse.arg = FALSE, deriv = 0,
- short = TRUE, tag = FALSE)
+ nreciprocal <- function(theta, earg = list(), inverse.arg = FALSE,
+ deriv = 0, short = TRUE, tag = FALSE)
{
if (is.character(theta)) {
string <- paste("-1/", theta, sep = "")
@@ -436,13 +479,13 @@ TypicalVGAMlinkFunction <- function(theta,
if (deriv > 0) {
1 / nreciprocal(theta, earg = earg, inverse = FALSE, deriv)
} else {
- 1/ sqrt(-2*theta)
+ 1 / sqrt(-2*theta)
}
} else {
switch(deriv+1,
- -1/(2*theta^2),
+ -1 / (2 * theta^2),
theta^3,
- 3*theta^5)
+ 3 * theta^5)
}
}
@@ -471,7 +514,8 @@ TypicalVGAMlinkFunction <- function(theta,
if (inverse) {
if (deriv > 0) {
- 1/Recall(theta = theta, earg = earg, inverse = FALSE, deriv = deriv)
+ 1 / Recall(theta = theta, earg = earg,
+ inverse = FALSE, deriv = deriv)
} else {
junk <- exp(theta)
expm1(theta) / (junk+1.0)
@@ -507,7 +551,8 @@ TypicalVGAMlinkFunction <- function(theta,
if (inverse) {
if (deriv > 0) {
- 1/Recall(theta = theta, earg = earg, inverse = FALSE, deriv = deriv)
+ 1 / Recall(theta = theta, earg = earg,
+ inverse = FALSE, deriv = deriv)
} else {
junk <- exp(2*theta)
expm1(2*theta) / (junk+1.0)
@@ -550,7 +595,8 @@ fsqrt <- function(theta, earg = list(min = 0, max = 1, mux=sqrt(2)),
if (inverse) {
if (deriv > 0) {
- 1/Recall(theta = theta, earg = earg, inverse = FALSE, deriv = deriv)
+ 1 / Recall(theta = theta, earg = earg,
+ inverse = FALSE, deriv = deriv)
} else {
mid = (min + max) / 2
boundary = mux * sqrt(max - min)
@@ -582,7 +628,7 @@ fsqrt <- function(theta, earg = list(min = 0, max = 1, mux=sqrt(2)),
if (exponent == 0)
stop("use the 'loge' link")
} else {
- stop("'earg' must be a list or NULL")
+ stop("argument 'earg' must be a list or NULL")
}
if (is.character(theta)) {
@@ -596,7 +642,8 @@ fsqrt <- function(theta, earg = list(min = 0, max = 1, mux=sqrt(2)),
}
if (inverse) {
if (deriv > 0) {
- 1/Recall(theta = theta, earg = earg, inverse = FALSE, deriv = deriv)
+ 1 / Recall(theta = theta, earg = earg,
+ inverse = FALSE, deriv = deriv)
} else {
theta^(1/exponent)
}
@@ -625,7 +672,7 @@ fsqrt <- function(theta, earg = list(min = 0, max = 1, mux=sqrt(2)),
if (!inverse && length(bminvalue)) theta[theta <= A] <- bminvalue
if (!inverse && length(bmaxvalue)) theta[theta >= B] <- bmaxvalue
} else {
- stop("'earg' must be a list or NULL")
+ stop("argument 'earg' must be a list or NULL")
}
if (is.character(theta)) {
string <- if (short) {
@@ -641,7 +688,8 @@ fsqrt <- function(theta, earg = list(min = 0, max = 1, mux=sqrt(2)),
}
if (inverse) {
if (deriv > 0) {
- 1/Recall(theta = theta, earg = earg, inverse = FALSE, deriv = deriv)
+ 1 / Recall(theta = theta, earg = earg,
+ inverse = FALSE, deriv = deriv)
} else {
junk <- if (is.R()) care.exp(theta) else care.exp(theta)
(A + B*junk) / (1.0 + junk)
@@ -674,7 +722,8 @@ fsqrt <- function(theta, earg = list(min = 0, max = 1, mux=sqrt(2)),
}
if (inverse) {
if (deriv > 0) {
- 1/Recall(theta = theta, earg = earg, inverse = FALSE, deriv = deriv)
+ 1 / Recall(theta = theta, earg = earg,
+ inverse = FALSE, deriv = deriv)
} else {
eta <- care.exp(theta)
eta / (1.0 + eta)
@@ -709,7 +758,8 @@ fsqrt <- function(theta, earg = list(min = 0, max = 1, mux=sqrt(2)),
}
if (inverse) {
if (deriv > 0) {
- 1 / Recall(theta = theta, earg = earg, inverse = FALSE, deriv = deriv)
+ 1 / Recall(theta = theta, earg = earg,
+ inverse = FALSE, deriv = deriv)
} else {
-expm1(theta)
}
@@ -728,7 +778,7 @@ fsqrt <- function(theta, earg = list(min = 0, max = 1, mux=sqrt(2)),
if (!length(earg) || is.list(earg)) {
offset = if (length(earg$offset)) earg$offset else 0
} else {
- stop("'earg' must be a list or NULL")
+ stop("argument 'earg' must be a list or NULL")
}
if (!is.Numeric(offset))
@@ -745,7 +795,8 @@ fsqrt <- function(theta, earg = list(min = 0, max = 1, mux=sqrt(2)),
}
if (inverse) {
if (deriv > 0) {
- 1/Recall(theta = theta, earg = earg, inverse = FALSE, deriv = deriv)
+ 1 / Recall(theta = theta, earg = earg,
+ inverse = FALSE, deriv = deriv)
} else {
exp(theta) - offset
}
@@ -764,7 +815,7 @@ nlogoff <- function(theta, earg = 0, inverse = FALSE, deriv = 0,
{
offset = earg
if (!is.Numeric(offset))
- stop("bad input for argument earg")
+ stop("bad input for argument 'earg'")
if (is.character(theta)) {
string <- if (short)
paste("nlogoff(", theta, ", ",as.character(offset), ")", sep = "") else
@@ -775,7 +826,8 @@ nlogoff <- function(theta, earg = 0, inverse = FALSE, deriv = 0,
}
if (inverse) {
if (deriv > 0) {
- 1/Recall(theta = theta, earg = earg, inverse = FALSE, deriv = deriv)
+ 1 / Recall(theta = theta, earg = earg,
+ inverse = FALSE, deriv = deriv)
} else {
offset - exp(theta)
}
@@ -807,7 +859,8 @@ nlogoff <- function(theta, earg = 0, inverse = FALSE, deriv = 0,
}
if (inverse) {
if (deriv > 0) {
- 1/Recall(theta = theta, earg = earg, inverse = FALSE, deriv = deriv)
+ 1 / Recall(theta = theta, earg = earg,
+ inverse = FALSE, deriv = deriv)
} else {
0.5 + atan(theta)/pi
}
@@ -834,7 +887,7 @@ nlogoff <- function(theta, earg = 0, inverse = FALSE, deriv = 0,
lambda = earg$lambda
cutpoint = earg$cutpoint # Optional; if so then is a NULL
} else
- stop("'earg' must be a list")
+ stop("argument 'earg' must be a list")
if (!is.Numeric(lambda, posit = TRUE))
stop('could not determine lambda or lambda has negative values')
if (is.Numeric(cutpoint))
@@ -885,7 +938,8 @@ nlogoff <- function(theta, earg = 0, inverse = FALSE, deriv = 0,
answer =
if (inverse) {
if (deriv > 0) {
- 1 / Recall(theta = theta, earg = earg, inverse = FALSE, deriv = deriv)
+ 1 / Recall(theta = theta, earg = earg,
+ inverse = FALSE, deriv = deriv)
} else {
if (is.Numeric(cutpoint)) {
pnorm((1-care.exp(-(theta-log(cutpoint))/3)) * 3 * sqrt(lambda))
@@ -905,22 +959,23 @@ nlogoff <- function(theta, earg = 0, inverse = FALSE, deriv = 0,
-3*log1p(-temp) + if (is.Numeric(cutpoint)) log(cutpoint) else 0},
(1 - Ql / (3*sqrt(lambda))) * sqrt(lambda) * dnorm(Ql),
{ stop('cannot handle deriv = 2') },
- stop("'deriv' unmatched"))
+ stop("argument 'deriv' unmatched"))
}
if (!is.Numeric(answer)) stop("the answer contains some NAs")
answer
}
- polf <- function(theta, earg=stop("'earg' must be given"),
+ polf <- function(theta, earg = stop("argument 'earg' must be given"),
inverse = FALSE, deriv = 0, short = TRUE, tag = FALSE)
{
cutpoint = NULL
if (is.Numeric(earg)) cutpoint = earg
if (is.list(earg)) cutpoint = earg$cutpoint
if (!is.Numeric(cutpoint))
- stop('could not determine the cutpoint')
- if (any(cutpoint < 0) || !is.Numeric(cutpoint, integer = TRUE))
+ stop("could not determine the cutpoint")
+ if (any(cutpoint < 0) ||
+ !is.Numeric(cutpoint, integer = TRUE))
warning("argument 'cutpoint' should",
" contain non-negative integer values")
@@ -947,24 +1002,27 @@ nlogoff <- function(theta, earg = 0, inverse = FALSE, deriv = 0,
cutpoint = rep(cutpoint, len=ncol(thmat)) # Reqd for the for loop
for(ii in 1:ncol(thmat))
answer[,ii] = Recall(theta = thmat[,ii], earg=cutpoint[ii],
- inverse=inverse, deriv = deriv)
+ inverse = inverse, deriv = deriv)
return(answer)
}
answer =
if (inverse) {
if (deriv > 0) {
- 1 / Recall(theta = theta, earg = earg, inverse = FALSE, deriv = deriv)
+ 1 / Recall(theta = theta, earg = earg,
+ inverse = FALSE, deriv = deriv)
} else {
if (cutpoint == 0) {
- cloglog(theta = theta, earg = earg, inverse=inverse, deriv = deriv)
+ cloglog(theta = theta, earg = earg,
+ inverse = inverse, deriv = deriv)
} else {
pnorm(2 * exp(theta/2) - 2 * sqrt(cutpoint + 7/8))
}
}
} else {
if (cutpoint == 0) {
- cloglog(theta = theta, earg = earg, inverse=inverse, deriv = deriv)
+ cloglog(theta = theta, earg = earg,
+ inverse = inverse, deriv = deriv)
} else {
smallno = 1 * .Machine$double.eps
SMALLNO = 1 * .Machine$double.xmin
@@ -978,7 +1036,7 @@ nlogoff <- function(theta, earg = 0, inverse = FALSE, deriv = 0,
2 * log(temp)},
(Ql/2 + sqrt(cutpoint + 7/8)) * dnorm(Ql),
{ stop('cannot handle deriv = 2') },
- stop("'deriv' unmatched"))
+ stop("argument 'deriv' unmatched"))
}
}
if (!is.Numeric(answer)) stop("the answer contains some NAs")
@@ -986,7 +1044,7 @@ nlogoff <- function(theta, earg = 0, inverse = FALSE, deriv = 0,
}
- nbolf <- function(theta, earg=stop("'earg' must be given"),
+ nbolf <- function(theta, earg = stop("argument 'earg' must be given"),
inverse = FALSE, deriv = 0, short = TRUE, tag = FALSE) {
cutpoint = kay = NULL
@@ -1038,7 +1096,8 @@ nlogoff <- function(theta, earg = 0, inverse = FALSE, deriv = 0,
answer =
if (inverse) {
if (deriv > 0) {
- 1 / Recall(theta = theta, earg = earg, inverse = FALSE, deriv = deriv)
+ 1 / Recall(theta = theta, earg = earg,
+ inverse = FALSE, deriv = deriv)
} else {
if (cutpoint == 0) {
1.0 - (kay / (kay + care.exp(theta)))^kay
@@ -1060,7 +1119,7 @@ nlogoff <- function(theta, earg = 0, inverse = FALSE, deriv = 0,
log(kay) + log(temp)},
(kay / (1 - Theta)^(1/kay) - kay) * (1 - Theta)^(kay+1/kay),
{ stop('cannot handle deriv = 2') },
- stop("'deriv' unmatched"))
+ stop("argument 'deriv' unmatched"))
} else {
Ql = qnorm(Theta)
switch(deriv+1, {
@@ -1071,7 +1130,7 @@ nlogoff <- function(theta, earg = 0, inverse = FALSE, deriv = 0,
arg1 = (Ql/(2*sqrt(kay)) + asinh(sqrt(cutpoint/kay)))
sqrt(kay) * tanh(arg1) * dnorm(Ql) },
{ stop('cannot handle deriv = 2') },
- stop("'deriv' unmatched"))
+ stop("argument 'deriv' unmatched"))
}
}
if (!is.Numeric(answer)) stop("the answer contains some NAs")
@@ -1082,7 +1141,7 @@ nlogoff <- function(theta, earg = 0, inverse = FALSE, deriv = 0,
- nbolf2 <- function(theta, earg=stop("'earg' must be given"),
+ nbolf2 <- function(theta, earg = stop("argument 'earg' must be given"),
inverse = FALSE, deriv = 0, short = TRUE, tag = FALSE) {
cutpoint = kay = NULL
@@ -1091,7 +1150,7 @@ nlogoff <- function(theta, earg = 0, inverse = FALSE, deriv = 0,
kay = earg$k
}
if (!is.Numeric(kay, positive = TRUE))
- stop("could not determine 'k' or it is not positive-valued")
+ stop("could not determine argument 'k' or it is not positive-valued")
if (!is.Numeric(cutpoint))
stop("could not determine the cutpoint")
if (any(cutpoint < 0) || !is.Numeric(cutpoint, integer = TRUE))
@@ -1132,7 +1191,8 @@ nlogoff <- function(theta, earg = 0, inverse = FALSE, deriv = 0,
answer =
if (inverse) {
if (deriv > 0) {
- 1 / Recall(theta = theta, earg = earg, inverse = FALSE, deriv = deriv)
+ 1 / Recall(theta = theta, earg = earg,
+ inverse = FALSE, deriv = deriv)
} else {
if (cutpoint == 0) {
1.0 - (kay / (kay + care.exp(theta)))^kay
@@ -1229,7 +1289,7 @@ nlogoff <- function(theta, earg = 0, inverse = FALSE, deriv = 0,
checkCut = function(y) {
if (!is.Numeric(y, posi = TRUE, integ = TRUE))
- stop("'y' must contain positive integers only")
+ stop("argument 'y' must contain positive integers only")
uy = unique(y)
L = max(uy)
oklevels = 1:L
diff --git a/R/model.matrix.vglm.q b/R/model.matrix.vglm.q
index 4e806b6..49168c3 100644
--- a/R/model.matrix.vglm.q
+++ b/R/model.matrix.vglm.q
@@ -352,5 +352,30 @@ setMethod("model.frame", "vlm", function(formula, ...)
+depvar.vlm <- function(object, ...) {
+ object at y
+}
+
+
+
+if (!isGeneric("depvar"))
+ setGeneric("depvar", function(object, ...) standardGeneric("depvar"),
+ package = "VGAM")
+
+
+setMethod("depvar", "vlm", function(object, ...)
+ depvar.vlm(object, ...))
+setMethod("depvar", "rrvglm", function(object, ...)
+ depvar.vlm(object, ...))
+setMethod("depvar", "qrrvglm", function(object, ...)
+ depvar.vlm(object, ...))
+setMethod("depvar", "cao", function(object, ...)
+ depvar.vlm(object, ...))
+setMethod("depvar", "rcam", function(object, ...)
+ depvar.vlm(object, ...))
+
+
+
+
diff --git a/R/nobs.R b/R/nobs.R
new file mode 100644
index 0000000..6926846
--- /dev/null
+++ b/R/nobs.R
@@ -0,0 +1,207 @@
+# These functions are Copyright (C) 1998-2011 T. W. Yee All rights reserved.
+
+# nobs.R
+
+# Notes.
+# 1. 20110711 Looked at "NEWS" and found out about nobs().
+# Adding nvar() too while I am at it.
+
+
+# ======================================================================
+# 20110711
+
+nobs.vlm <- function(object, type = c("lm", "vlm"), ...) {
+
+# Notes:
+# 1. with type = "vlm" this is n * M.
+
+ if(mode(type) != "character" && mode(type) != "name")
+ type <- as.character(substitute(type))
+ type <- match.arg(type,
+ c("lm", "vlm"))[1]
+
+
+ if (type == "lm") {
+ object at misc$n
+ } else {
+ object at misc$nrow_X_vlm
+ }
+}
+
+
+setMethod("nobs", "vlm",
+ function(object, ...)
+ nobs.vlm(object, ...))
+
+
+
+
+
+
+# ======================================================================
+# 20110711
+# Here is the 'nvar' methods functions.
+# Tricky for "vgam", "rrvglm", "qrrvglm", "cao", "rcam" objects?
+
+nvar.vlm <- function(object, type = c("vlm", "lm"), ...) {
+
+ if(mode(type) != "character" && mode(type) != "name")
+ type <- as.character(substitute(type))
+ type <- match.arg(type,
+ c("vlm", "lm"))[1]
+
+
+ if (type == "lm") {
+ object at misc$p
+ } else {
+ object at misc$ncol_X_vlm
+ }
+}
+
+
+
+nvar.vgam <- function(object, type = c("vgam", "zz"), ...) {
+# 20110711
+# Uses the effective dof, or edof, or edf zz??
+
+ if(mode(type) != "character" && mode(type) != "name")
+ type <- as.character(substitute(type))
+ type <- match.arg(type,
+ c("vgam", "zz"))[1]
+
+ stop("function nvar.vgam() has not been written yet")
+
+ if (type == "vgam") {
+ object at misc$p
+ } else {
+ object at misc$ncol_X_vlm
+ }
+}
+
+
+nvar.rrvglm <- function(object, type = c("rrvglm", "zz"), ...) {
+# 20110711
+# Uses the effective dof, or edof, or edf zz??
+
+ if(mode(type) != "character" && mode(type) != "name")
+ type <- as.character(substitute(type))
+ type <- match.arg(type,
+ c("rrvglm", "zz"))[1]
+
+ stop("function nvar.rrvglm() has not been written yet")
+
+ if (type == "vgam") {
+ object at misc$p
+ } else {
+ object at misc$ncol_X_vlm
+ }
+}
+
+
+
+nvar.qrrvglm <- function(object, type = c("qrrvglm", "zz"), ...) {
+# 20110711
+# Uses the effective dof, or edof, or edf zz??
+
+ if(mode(type) != "character" && mode(type) != "name")
+ type <- as.character(substitute(type))
+ type <- match.arg(type,
+ c("qrrvglm", "zz"))[1]
+
+ stop("function nvar.qrrvglm() has not been written yet")
+
+ if (type == "qrrvglm") {
+ object at misc$p
+ } else {
+ object at misc$ncol_X_vlm
+ }
+}
+
+
+
+nvar.cao <- function(object, type = c("cao", "zz"), ...) {
+# 20110711
+# Uses the effective dof, or edof, or edf zz??
+
+ if(mode(type) != "character" && mode(type) != "name")
+ type <- as.character(substitute(type))
+ type <- match.arg(type,
+ c("rrvglm", "zz"))[1]
+
+ stop("function nvar.cao() has not been written yet")
+
+ if (type == "cao") {
+ object at misc$p
+ } else {
+ object at misc$ncol_X_vlm
+ }
+}
+
+
+
+nvar.rcam <- function(object, type = c("rcam", "zz"), ...) {
+# 20110711
+# Uses the effective dof, or edof, or edf zz??
+
+ if(mode(type) != "character" && mode(type) != "name")
+ type <- as.character(substitute(type))
+ type <- match.arg(type,
+ c("rcam", "zz"))[1]
+
+ stop("function nvar.rcam() has not been written yet")
+
+ if (type == "rcam") {
+ object at misc$p
+ } else {
+ object at misc$ncol_X_vlm
+ }
+}
+
+
+
+
+
+if (!isGeneric("nvar"))
+setGeneric("nvar", function(object, ...)
+ standardGeneric("nvar"),
+ package = "VGAM")
+
+
+setMethod("nvar", "vlm",
+ function(object, ...)
+ nvar.vlm(object, ...))
+
+
+
+setMethod("nvar", "vgam",
+ function(object, ...)
+ nvar.vgam(object, ...))
+
+
+setMethod("nvar", "rrvglm",
+ function(object, ...)
+ nvar.rrvglm(object, ...))
+
+
+
+setMethod("nvar", "qrrvglm",
+ function(object, ...)
+ nvar.qrrvglm(object, ...))
+
+
+
+setMethod("nvar", "cao",
+ function(object, ...)
+ nvar.cao(object, ...))
+
+
+
+setMethod("nvar", "rcam",
+ function(object, ...)
+ nvar.rcam(object, ...))
+
+
+# ======================================================================
+
+
+
diff --git a/R/plot.vglm.q b/R/plot.vglm.q
index 69e05cf..8a0ccd8 100644
--- a/R/plot.vglm.q
+++ b/R/plot.vglm.q
@@ -865,3 +865,20 @@ setMethod("plot", "qrrvglm", function(x, y, ...)
+
+
+put.caption = function(text.arg = "(a)",
+ w.x = c(0.50, 0.50),
+ w.y = c(0.07, 0.93), ...) {
+ text(text.arg,
+ x = weighted.mean(par()$usr[1:2], w = w.x),
+ y = weighted.mean(par()$usr[3:4], w = w.y), ...)
+}
+
+
+
+
+
+
+
+
diff --git a/R/predict.vgam.q b/R/predict.vgam.q
index d6e5ed8..982a091 100644
--- a/R/predict.vgam.q
+++ b/R/predict.vgam.q
@@ -4,11 +4,13 @@
+
+
predict.vgam <- function(object, newdata=NULL,
type=c("link", "response", "terms"),
- se.fit=FALSE, deriv.arg=0, terms.arg=NULL,
- raw=FALSE,
- all=TRUE, offset=0,
+ se.fit = FALSE, deriv.arg=0, terms.arg=NULL,
+ raw = FALSE,
+ all = TRUE, offset=0,
untransform = FALSE,
dispersion=NULL, ...)
{
@@ -29,7 +31,7 @@ predict.vgam <- function(object, newdata=NULL,
if (untransform &&
(type != "link" || se.fit || deriv.arg != 0 || offset != 0))
- stop("argument 'untransform=TRUE' only if type='link', ",
+ stop("argument 'untransform = TRUE' only if type='link', ",
"se.fit = FALSE, deriv = 0")
if (raw && type!="terms")
@@ -43,10 +45,10 @@ predict.vgam <- function(object, newdata=NULL,
stop("'deriv>0' can only be specified if 'type=\"terms\"'")
if (deriv.arg != 0 && !(type!="response" && !se.fit))
- stop("'deriv=' only works with type!='response' and se.fit=FALSE")
+ stop("'deriv=' only works with type!='response' and se.fit = FALSE")
if (se.fit && length(newdata))
- stop("cannot specify 'se.fit=TRUE' when 'newdata' is assigned")
+ stop("cannot specify 'se.fit = TRUE' when 'newdata' is assigned")
tt <- terms(object) # 11/8/03; object at terms$terms
@@ -70,7 +72,7 @@ predict.vgam <- function(object, newdata=NULL,
if (!length(newdata)) {
if (type=="link") {
if (se.fit) {
- stop("cannot handle this option (se.fit=TRUE) currently")
+ stop("cannot handle this option (se.fit = TRUE) currently")
} else {
if (length(na.act)) {
answer = napredict(na.act[[1]], object at predictors)
@@ -83,7 +85,7 @@ predict.vgam <- function(object, newdata=NULL,
} else
if (type=="response") {
if (se.fit) {
- stop("cannot handle this option (se.fit=TRUE) currently")
+ stop("cannot handle this option (se.fit = TRUE) currently")
} else {
if (length(na.act)) {
return(napredict(na.act[[1]], object at fitted.values))
@@ -134,8 +136,8 @@ predict.vgam <- function(object, newdata=NULL,
dnames2 <- dimnames(newdata)[[2]]
- index1 <- match(s.xargument, dnames2, nomatch=FALSE)
- index2 <- match(names(s.xargument), dnames2, nomatch=FALSE)
+ index1 <- match(s.xargument, dnames2, nomatch = FALSE)
+ index2 <- match(names(s.xargument), dnames2, nomatch = FALSE)
index <- index1 | index2
if (!length(index) || any(!index))
stop("required variables not found in newdata")
@@ -189,7 +191,7 @@ predict.vgam <- function(object, newdata=NULL,
temp.var <- if (raw) {
tmp7 <- object at misc$varassign
tmp7 <- tmp7[[ii]]
- object at var[, tmp7, drop=FALSE]
+ object at var[, tmp7, drop = FALSE]
} else
stop("cannot handle se's with raw = FALSE")
@@ -225,7 +227,7 @@ predict.vgam <- function(object, newdata=NULL,
}
} else
if (type=="response") {
- fv <- object at family@inverse(if(se.fit) predictor$fitted.values else
+ fv <- object at family@linkinv(if(se.fit) predictor$fitted.values else
predictor, object at extra)
if (is.matrix(fv) && is.matrix(object at fitted.values))
dimnames(fv) <- list(dimnames(fv)[[1]],
@@ -256,7 +258,7 @@ predict.vgam <- function(object, newdata=NULL,
v = attr(if(se.fit) predictor$fitted.values else
predictor, "vterm.assign")
is.lin <- is.linear.term(names(v))
- coefmat <- coefvlm(object, matrix=TRUE)
+ coefmat <- coefvlm(object, matrix = TRUE)
ord <- 0
for(ii in names(v)) {
ord <- ord + 1
@@ -273,11 +275,12 @@ predict.vgam <- function(object, newdata=NULL,
} else {
ans <- coefmat[ii, 1:lindex]
if (se.fit) {
- predictor$fitted.values[,index] = if (deriv.arg==1)
- matrix(ans, ncol=lindex, byrow=TRUE) else 0
+ predictor$fitted.values[,index] =
+ if (deriv.arg == 1)
+ matrix(ans, ncol = lindex, byrow = TRUE) else 0
} else {
predictor[,index] <- if (deriv.arg==1)
- matrix(ans, ncol=lindex, byrow=TRUE) else 0
+ matrix(ans, ncol=lindex, byrow = TRUE) else 0
}
}
} else
@@ -288,15 +291,15 @@ predict.vgam <- function(object, newdata=NULL,
predictor$fitted.values[,index] +
(if(deriv.arg == 1)
matrix(ans, nrow=nrow(predictor$fitted.values),
- ncol=lindex, byrow=TRUE) else 0)
+ ncol=lindex, byrow = TRUE) else 0)
} else {
predictor[, index] <- predictor[, index] +
(if(deriv.arg == 1)
matrix(ans, nrow=nrow(predictor),
- ncol=lindex, byrow=TRUE) else 0)
+ ncol=lindex, byrow = TRUE) else 0)
}
} else {
- cat("Derivatives of term ", i, "are unknown\n")
+ cat("Derivatives of term ", ii, "are unknown\n")
if (se.fit) {
predictor$fitted.values[,index] <- NA
} else {
diff --git a/R/predict.vglm.q b/R/predict.vglm.q
index ea5d6d0..617ff79 100644
--- a/R/predict.vglm.q
+++ b/R/predict.vglm.q
@@ -6,7 +6,7 @@
-predict.vglm = function(object,
+predictvglm = function(object,
newdata=NULL,
type=c("link", "response", "terms"),
se.fit=FALSE,
@@ -21,7 +21,7 @@ predict.vglm = function(object,
}
if (deriv != 0)
- stop("'deriv' must be 0 for predict.vglm()")
+ stop("'deriv' must be 0 for predictvglm()")
if (mode(type) != "character" && mode(type) != "name")
type = as.character(substitute(type))
@@ -44,7 +44,7 @@ predict.vglm = function(object,
type=type, se.fit=se.fit,
deriv=deriv,
dispersion=dispersion, ...)
- fv = object at family@inverse(predictor, extra)
+ fv = object at family@linkinv(predictor, extra)
dimnames(fv) = list(dimnames(fv)[[1]],
dimnames(object at fitted.values)[[2]])
fv
@@ -87,7 +87,7 @@ predict.vglm = function(object,
M = object at misc$M
- fv = object at family@inverse(predictor, extra)
+ fv = object at family@linkinv(predictor, extra)
if (M > 1 && is.matrix(fv)) {
dimnames(fv) = list(dimnames(fv)[[1]],
dimnames(object at fitted.values)[[2]])
@@ -128,7 +128,7 @@ predict.vglm = function(object,
setMethod("predict", "vglm", function(object, ...)
- predict.vglm(object, ...))
+ predictvglm(object, ...))
@@ -155,7 +155,7 @@ predict.rrvglm = function(object,
type=type, se.fit=se.fit,
deriv=deriv,
dispersion=dispersion, ...)
- fv = object at family@inverse(predictor, extra)
+ fv = object at family@linkinv(predictor, extra)
dimnames(fv) = list(dimnames(fv)[[1]],
dimnames(object at fitted.values)[[2]])
fv
@@ -173,7 +173,7 @@ predict.rrvglm = function(object,
}
)
} else {
- return(predict.vglm(object, newdata=newdata,
+ return(predictvglm(object, newdata=newdata,
type=type, se.fit=se.fit,
deriv=deriv,
dispersion=dispersion, ...))
diff --git a/R/qtplot.q b/R/qtplot.q
index 11f3732..c426e84 100644
--- a/R/qtplot.q
+++ b/R/qtplot.q
@@ -310,7 +310,7 @@ qtplot.gumbel <-
extra$mpv = mpv # Overwrite if necessary
extra$R = R
extra$percentiles = percentiles
- fitted.values = object at family@inverse(eta = eta, extra = extra)
+ fitted.values = object at family@linkinv(eta = eta, extra = extra)
answer = list(fitted.values = fitted.values,
percentiles = percentiles)
@@ -704,7 +704,7 @@ rlplot.gev <-
extra2 = object at extra
extra2$percentiles = 100 * probability # Overwrite
- zp = object at family@inverse(eta = predict(object)[1:2,],
+ zp = object at family@linkinv(eta = predict(object)[1:2,],
extra = extra2)[1,]
yp = -log(probability)
ydata = sort(object at y[, 1])
@@ -751,7 +751,7 @@ rlplot.gev <-
teta = eval(newcall) # The transformed parameter
peta = eta
peta[, ii] = teta
- zpp[, ii] = object at family@inverse(eta = peta,
+ zpp[, ii] = object at family@linkinv(eta = peta,
extra = extra2)[1,]
zpp[, ii] = (zpp[, ii] - zp) / epsilon # On the transformed scale
}
diff --git a/R/rrvglm.R b/R/rrvglm.R
index f1fd7ca..2e7a3db 100644
--- a/R/rrvglm.R
+++ b/R/rrvglm.R
@@ -10,16 +10,16 @@
rrvglm <- function(formula,
family, data=list(),
- weights=NULL, subset=NULL, na.action=na.fail,
- etastart=NULL, mustart=NULL, coefstart=NULL,
+ weights = NULL, subset = NULL, na.action=na.fail,
+ etastart = NULL, mustart = NULL, coefstart = NULL,
control=rrvglm.control(...),
- offset=NULL,
+ offset = NULL,
method="rrvglm.fit",
- model=FALSE, x.arg=TRUE, y.arg=TRUE,
- contrasts=NULL,
- constraints=NULL,
- extra=NULL,
- qr.arg=FALSE, smart=TRUE, ...)
+ model = FALSE, x.arg = TRUE, y.arg = TRUE,
+ contrasts = NULL,
+ constraints = NULL,
+ extra = NULL,
+ qr.arg = FALSE, smart = TRUE, ...)
{
dataname <- as.character(substitute(data)) # "list" if no data=
function.name <- "rrvglm"
@@ -33,7 +33,7 @@ rrvglm <- function(formula,
if (missing(data))
data <- environment(formula)
- mf <- match.call(expand=FALSE)
+ mf <- match.call(expand = FALSE)
mf$family <- mf$method <- mf$model <- mf$x.arg <- mf$y.arg <- mf$control <-
mf$contrasts <- mf$constraints <- mf$extra <- mf$qr.arg <- NULL
mf$coefstart <- mf$etastart <- mf$... <- NULL
@@ -150,7 +150,7 @@ rrvglm <- function(formula,
"smart.prediction" = as.list(fit$smart.prediction),
"terms" = list(terms=mt))
- if (!smart) answer at smart.prediction <- list(smart.arg=FALSE)
+ if (!smart) answer at smart.prediction <- list(smart.arg = FALSE)
if (qr.arg) {
class(fit$qr) = "list"
diff --git a/R/rrvglm.fit.q b/R/rrvglm.fit.q
index 91b45f6..3bf9e8d 100644
--- a/R/rrvglm.fit.q
+++ b/R/rrvglm.fit.q
@@ -43,7 +43,7 @@ rrvglm.fit <- function(x, y, w=rep(1, length(x[, 1])),
eta <- fv + offset
- mu <- family at inverse(eta, extra)
+ mu <- family at linkinv(eta, extra)
if (length(family at middle2))
eval(family at middle2)
@@ -102,7 +102,7 @@ rrvglm.fit <- function(x, y, w=rep(1, length(x[, 1])),
eta <- fv + offset
- mu <- family at inverse(eta, extra)
+ mu <- family at linkinv(eta, extra)
if (length(family at middle2))
eval(family at middle2)
@@ -206,16 +206,16 @@ rrvglm.fit <- function(x, y, w=rep(1, length(x[, 1])),
if (length(etastart)) {
eta <- etastart
mu <- if (length(mustart)) mustart else
- if (length(body(slot(family, "inverse"))))
- slot(family, "inverse")(eta, extra) else
+ if (length(body(slot(family, "linkinv"))))
+ slot(family, "linkinv")(eta, extra) else
warning("argument 'etastart' assigned a value ",
- "but there is no 'inverse' slot to use it")
+ "but there is no 'linkinv' slot to use it")
}
if (length(mustart)) {
mu <- mustart
- if (length(body(slot(family, "link")))) {
- eta <- slot(family, "link")(mu, extra)
+ if (length(body(slot(family, "linkfun")))) {
+ eta <- slot(family, "linkfun")(mu, extra)
} else {
warning("argument 'mustart' assigned a value ",
"but there is no 'link' slot to use it")
@@ -353,7 +353,7 @@ rrvglm.fit <- function(x, y, w=rep(1, length(x[, 1])),
eta <- if (M > 1) matrix(eta, ncol=M, byrow = TRUE) else c(eta)
- mu <- family at inverse(eta, extra)
+ mu <- family at linkinv(eta, extra)
}
if (criterion != "coefficients") {
diff --git a/R/s.q b/R/s.q
index aa80db9..875a6e1 100644
--- a/R/s.q
+++ b/R/s.q
@@ -5,34 +5,35 @@
-s <- function(x, df=4, spar=0, ...)
-{
-
- xs <- substitute(x)
- ans <- as.character(xs)
- if (length(ans) > 1)
- stop("x argument must be of length one")
-
- call <- deparse(sys.call())
-
- if (ncol(as.matrix(x)) > 1)
- stop("x must be a vector")
- if (!is.null(levels(x))) {
- x <- if (inherits(x, "ordered")) codes(x) else
- stop("unordered factors cannot be used as smoothing variables")
- }
- attr(x, "spar") <- spar
- attr(x, "df") <- df
- attr(x, "call") <- call
- attr(x, "class") <- "smooth"
- attr(x, "s.xargument") <- ans # Needed for prediction and constraints
+s <- function(x, df = 4, spar = 0, ...) {
+
+ xs <- substitute(x)
+ ans <- as.character(xs)
+ if (length(ans) > 1)
+ stop("x argument must be of length one")
+
+ call <- deparse(sys.call())
+
+ if (ncol(as.matrix(x)) > 1)
+ stop("x must be a vector")
+ if (!is.null(levels(x))) {
+ x <- if (is.ordered(x)) {
+ as.vector(x)
+ } else
+ stop("unordered factors cannot be used as smoothing variables")
+ }
+ attr(x, "spar") <- spar
+ attr(x, "df") <- df
+ attr(x, "call") <- call
+ attr(x, "class") <- "smooth"
+ attr(x, "s.xargument") <- ans # Needed for prediction and constraints
- a <- is.na(x)
- if (any(a))
- attr(x, "NAs") <- seq(along = x)[a]
+ a <- is.na(x)
+ if (any(a))
+ attr(x, "NAs") <- seq(along = x)[a]
- x
+ x
}
diff --git a/R/summary.vgam.q b/R/summary.vgam.q
index dcca22b..6c68720 100644
--- a/R/summary.vgam.q
+++ b/R/summary.vgam.q
@@ -6,26 +6,25 @@
-summaryvgam <- function(object, dispersion=NULL, digits=options()$digits-2)
-{
-
- if (length(dispersion) && dispersion == 0 &&
- length(object at family@summary.dispersion) &&
- !object at family@summary.dispersion) {
- stop("cannot use the general VGLM formula (based on a residual ",
- "sum of squares) for computing the dispersion parameter")
- }
+summaryvgam <- function(object, dispersion = NULL,
+ digits = options()$digits-2) {
- newobject <- object
- class(newobject) <- "vglm"
- stuff <- summaryvglm(newobject, dispersion=dispersion)
- rdf <- stuff at df[2] <- object at df.residual # NA
+ if (length(dispersion) && dispersion == 0 &&
+ length(object at family@summary.dispersion) &&
+ !object at family@summary.dispersion) {
+ stop("cannot use the general VGLM formula (based on a residual ",
+ "sum of squares) for computing the dispersion parameter")
+ }
- M <- object at misc$M
- nrow_X_vlm <- object at misc$nrow_X_vlm
- rank <- if (is.null(object at qr$rank)) length(object at coefficients) else
- object at qr$rank
+ newobject <- object
+ class(newobject) <- "vglm"
+ stuff <- summaryvglm(newobject, dispersion = dispersion)
+ rdf <- stuff at df[2] <- object at df.residual # NA
+ M <- object at misc$M
+ nrow_X_vlm <- object at misc$nrow_X_vlm
+ rank <- if (is.null(object at qr$rank)) length(object at coefficients) else
+ object at qr$rank
@@ -33,148 +32,153 @@ summaryvgam <- function(object, dispersion=NULL, digits=options()$digits-2)
- useF <- object at misc$useF
- if (is.null(useF))
- useF <- FALSE
- df <- unlist(lapply(object at misc$new.assign, length))
- nldf <- object at nl.df
+ useF <- object at misc$useF
+ if (is.null(useF))
+ useF <- FALSE
- if (length(df)) {
- aod <- as.matrix(round(df, 1))
- dimnames(aod) <- list(names(df), "Df")
- if (!is.null(object at nl.chisq)) {
- aod <- cbind(aod, NA, NA, NA)
- nl.chisq <- object at nl.chisq / object at dispersion
+ df <- unlist(lapply(object at misc$new.assign, length))
+ nldf <- object at nl.df
- special = abs(nldf) < 0.1 # This was the quick fix in s.vam()
- nldf[special] = 1 # Give it a plausible value for pchisq & pf
+ if (length(df)) {
+ aod <- as.matrix(round(df, 1))
+ dimnames(aod) <- list(names(df), "Df")
+ if (!is.null(object at nl.chisq)) {
+ aod <- cbind(aod, NA, NA, NA)
+ nl.chisq <- object at nl.chisq / object at dispersion
- snames <- names(nldf)
- aod[snames, 2] <- round(nldf, 1)
- aod[snames, 3] <- if (useF) nl.chisq/nldf else nl.chisq
- aod[snames, 4] <- if (useF) pf(nl.chisq/nldf, nldf, rdf, lower.tail=FALSE) else
- pchisq(nl.chisq, nldf, lower.tail=FALSE)
+ special = abs(nldf) < 0.1 # This was the quick fix in s.vam()
+ nldf[special] = 1 # Give it a plausible value for pchisq & pf
- if (any(special)) {
- aod[snames[special], 2:4] = NA
- }
+ snames <- names(nldf)
+ aod[snames, 2] <- round(nldf, 1)
+ aod[snames, 3] <- if (useF) nl.chisq/nldf else nl.chisq
+ aod[snames, 4] <- if (useF) pf(nl.chisq/nldf, nldf, rdf, lower.tail=FALSE) else
+ pchisq(nl.chisq, nldf, lower.tail=FALSE)
- rnames <- c("Df", "Npar Df", "Npar Chisq", "P(Chi)")
- if (useF)
- rnames[3:4] <- c("Npar F", "Pr(F)")
- dimnames(aod) <- list(names(df), rnames)
- heading <- if (useF)
- "\nDF for Terms and Approximate F-values for Nonparametric Effects\n"
- else
- "\nDF for Terms and Approximate Chi-squares for Nonparametric Effects\n"
- } else heading <- "DF for Terms\n\n"
- aod <- as.vanova(data.frame(aod, check.names=FALSE), heading)
+ if (any(special)) {
+ aod[snames[special], 2:4] = NA
+ }
- if (is.R()) class(aod) = "data.frame"
+ rnames <- c("Df", "Npar Df", "Npar Chisq", "P(Chi)")
+ if (useF)
+ rnames[3:4] <- c("Npar F", "Pr(F)")
+ dimnames(aod) <- list(names(df), rnames)
+ heading <- if (useF)
+ "\nDF for Terms and Approximate F-values for Nonparametric Effects\n"
+ else
+ "\nDF for Terms and Approximate Chi-squares for Nonparametric Effects\n"
+ } else {
+ heading <- "DF for Terms\n\n"
}
- else aod <- if (is.R()) data.frame() else NULL
+ aod <- as.vanova(data.frame(aod, check.names=FALSE), heading)
- answer <-
- new("summary.vgam",
- object,
- call=stuff at call,
- cov.unscaled=stuff at cov.unscaled,
- correlation=stuff at correlation,
- df=stuff at df,
- sigma=stuff at sigma)
+ if (is.R()) class(aod) = "data.frame"
+ }
+ else aod <- if (is.R()) data.frame() else NULL
- slot(answer, "coefficients") = stuff at coefficients # Replace
- if (is.numeric(stuff at dispersion))
- slot(answer, "dispersion") = stuff at dispersion
+ answer <-
+ new("summary.vgam",
+ object,
+ call=stuff at call,
+ cov.unscaled=stuff at cov.unscaled,
+ correlation=stuff at correlation,
+ df=stuff at df,
+ sigma=stuff at sigma)
- presid = residuals(object, type="pearson")
- if (length(presid))
- answer at pearson.resid= as.matrix(presid)
+ slot(answer, "coefficients") = stuff at coefficients # Replace
+ if (is.numeric(stuff at dispersion))
+ slot(answer, "dispersion") = stuff at dispersion
- slot(answer, "anova") = aod
+ presid = residuals(object, type = "pearson")
+ if (length(presid))
+ answer at pearson.resid= as.matrix(presid)
- answer
-}
+ slot(answer, "anova") = aod
+ answer
+}
-printsummary.vgam <- function(x, quote=TRUE, prefix="", digits=options()$digits-2)
-{
- M <- x at misc$M
+printsummary.vgam <- function(x, quote = TRUE, prefix = "",
+ digits = options()$digits-2) {
+ M <- x at misc$M
- cat("\nCall:\n")
- dput(x at call)
- presid <- x at pearson.resid
- rdf <- x at df[2]
- if (FALSE && !is.null(presid) && all(!is.na(presid))) {
- cat("\nPearson Residuals:\n")
- if (rdf/M > 5) {
- rq <- apply(as.matrix(presid), 2, quantile) # 5 x M
- dimnames(rq) <- list(c("Min", "1Q", "Median", "3Q", "Max"),
- x at misc$predictors.names)
- print(t(rq), digits=digits)
- } else
- if (rdf > 0) {
- print(presid, digits=digits)
- }
- }
+ cat("\nCall:\n")
+ dput(x at call)
- cat("\nNumber of linear predictors: ", M, "\n")
-
- if (!is.null(x at misc$predictors.names))
- if (M==1)
- cat("\nName of linear predictor:",
- paste(x at misc$predictors.names, collapse=", "), "\n") else if (M<=5)
- cat("\nNames of linear predictors:",
- paste(x at misc$predictors.names, collapse=", "), "\n")
-
- prose <- ""
- if (length(x at dispersion)) {
- if (is.logical(x at misc$estimated.dispersion) &&
- x at misc$estimated.dispersion)
- prose <- "(Estimated) " else {
-
- if (is.numeric(x at misc$default.dispersion) &&
- x at dispersion==x at misc$default.dispersion)
- prose <- "(Default) "
-
- if (is.numeric(x at misc$default.dispersion) &&
- x at dispersion!=x at misc$default.dispersion)
- prose <- "(Pre-specified) "
- }
- cat(paste("\n", prose, "Dispersion Parameter for ",
- x at family@vfamily[1],
- " family: ", format(round(x at dispersion, digits)), "\n", sep=""))
+ presid <- x at pearson.resid
+ rdf <- x at df[2]
+ if (FALSE && !is.null(presid) && all(!is.na(presid))) {
+ cat("\nPearson Residuals:\n")
+ if (rdf/M > 5) {
+ rq <- apply(as.matrix(presid), 2, quantile) # 5 x M
+ dimnames(rq) <- list(c("Min", "1Q", "Median", "3Q", "Max"),
+ x at misc$predictors.names)
+ print(t(rq), digits=digits)
+ } else
+ if (rdf > 0) {
+ print(presid, digits=digits)
}
+ }
+
+ cat("\nNumber of linear predictors: ", M, "\n")
+
+ if (!is.null(x at misc$predictors.names))
+ if (M == 1)
+ cat("\nName of linear predictor:",
+ paste(x at misc$predictors.names, collapse = ", "), "\n") else
+ if (M<=5)
+ cat("\nNames of linear predictors:",
+ paste(x at misc$predictors.names, collapse = ", "), "\n")
+
+ prose <- ""
+ if (length(x at dispersion)) {
+ if (is.logical(x at misc$estimated.dispersion) &&
+ x at misc$estimated.dispersion)
+ prose <- "(Estimated) " else {
+
+ if (is.numeric(x at misc$default.dispersion) &&
+ x at dispersion==x at misc$default.dispersion)
+ prose <- "(Default) "
+
+ if (is.numeric(x at misc$default.dispersion) &&
+ x at dispersion!=x at misc$default.dispersion)
+ prose <- "(Pre-specified) "
+ }
+ cat(paste("\n", prose, "Dispersion Parameter for ",
+ x at family@vfamily[1],
+ " family: ",
+ format(round(x at dispersion, digits)), "\n", sep = ""))
+ }
if (length(deviance(x)))
- cat("\nResidual Deviance: ", format(round(deviance(x), digits)),
- "on", format(round(rdf, 3)), "degrees of freedom\n")
-
- if (length(logLik.vlm(x)))
- cat("\nLog-likelihood:", format(round(logLik.vlm(x), digits)),
- "on", format(round(rdf, 3)), "degrees of freedom\n")
-
- if (length(x at criterion)) {
- ncrit <- names(x at criterion)
- for(i in ncrit)
- if (i!="loglikelihood" && i!="deviance")
- cat(paste(i, ":", sep=""), format(x at criterion[[i]]), "\n")
- }
+ cat("\nResidual Deviance: ", format(round(deviance(x), digits)),
+ "on", format(round(rdf, 3)), "degrees of freedom\n")
+ if (length(logLik.vlm(x)))
+ cat("\nLog-likelihood:", format(round(logLik.vlm(x), digits)),
+ "on", format(round(rdf, 3)), "degrees of freedom\n")
- cat("\nNumber of Iterations: ", x at iter, "\n")
+ if (length(x at criterion)) {
+ ncrit <- names(x at criterion)
+ for(ii in ncrit)
+ if (ii != "loglikelihood" && ii != "deviance")
+ cat(paste(ii, ":", sep = ""), format(x at criterion[[ii]]), "\n")
+ }
- if (length(x at anova)) {
- printvanova(x at anova, dig=digits) # ".vanova" for Splus6
- }
- invisible(NULL)
+ cat("\nNumber of Iterations: ", x at iter, "\n")
+
+ if (length(x at anova)) {
+ printvanova(x at anova, dig = digits) # ".vanova" for Splus6
+ }
+
+ invisible(NULL)
}
@@ -197,51 +201,38 @@ printsummary.vgam <- function(x, quote=TRUE, prefix="", digits=options()$digits-
-printvanova <- function(x, digits=.Options$digits, ...)
-{
- rrr <- row.names(x)
- heading <- attr(x, "heading")
- if (!is.null(heading))
- cat(heading, sep="\n")
- attr(x, "heading") <- NULL
- for(i in 1:length(x)) {
- xx <- x[[i]]
- xna <- is.na(xx)
- xx <- format(zapsmall(xx, digits))
- xx[xna] <- ""
- x[[i]] <- xx
- }
- if (is.R()) {
- print.data.frame(as.data.frame(x, row.names=rrr))
- invisible(x)
- } else {
- print.data.frame(as.data.frame(x, row.names=rrr))
- invisible(x)
- }
+printvanova <- function(x, digits=.Options$digits, ...) {
+ rrr <- row.names(x)
+ heading <- attr(x, "heading")
+ if (!is.null(heading))
+ cat(heading, sep = "\n")
+ attr(x, "heading") <- NULL
+ for(i in 1:length(x)) {
+ xx <- x[[i]]
+ xna <- is.na(xx)
+ xx <- format(zapsmall(xx, digits))
+ xx[xna] <- ""
+ x[[i]] <- xx
+ }
+ print.data.frame(as.data.frame(x, row.names = rrr))
+ invisible(x)
}
-as.vanova <- function(x, heading)
-{
- if (!is.data.frame(x))
- stop("x must be a data frame")
- rrr <- row.names(x)
- attr(x, "heading") <- heading
- if (is.R()) {
- x <- as.data.frame(x, row.names=rrr)
- } else {
- x <- as.data.frame(x, row.names=rrr)
- }
- x
+
+
+
+as.vanova <- function(x, heading) {
+ if (!is.data.frame(x))
+ stop("x must be a data frame")
+ rrr <- row.names(x)
+ attr(x, "heading") <- heading
+ x <- as.data.frame(x, row.names = rrr)
+ x
}
-if(!is.R()) {
-setMethod("print", "vanova",
- function(x, ...)
- printvanova(x, ...))
-}
diff --git a/R/summary.vglm.q b/R/summary.vglm.q
index db3e71f..cf8a01a 100644
--- a/R/summary.vglm.q
+++ b/R/summary.vglm.q
@@ -8,50 +8,50 @@
-yformat = function(x, digits=options()$digits) {
- format(ifelse(abs(x)<0.001, signif(x, digits), round(x, digits)))
+yformat = function(x, digits = options()$digits) {
+ format(ifelse(abs(x) < 0.001, signif(x, digits), round(x, digits)))
}
-summaryvglm <- function(object, correlation=FALSE, dispersion=NULL, digits=NULL)
-{
+summaryvglm <- function(object, correlation = FALSE,
+ dispersion = NULL, digits = NULL) {
- if (length(dispersion) && dispersion == 0 &&
- length(object at family@summary.dispersion) &&
- !object at family@summary.dispersion) {
- stop("cannot use the general VGLM formula (based on a residual ",
- "sum of squares) for computing the dispersion parameter")
- }
+ if (length(dispersion) && dispersion == 0 &&
+ length(object at family@summary.dispersion) &&
+ !object at family@summary.dispersion) {
+ stop("cannot use the general VGLM formula (based on a residual ",
+ "sum of squares) for computing the dispersion parameter")
+ }
- stuff <- summaryvlm(as(object, "vlm"),
- correlation=correlation,
- dispersion=dispersion)
+ stuff <- summaryvlm(as(object, "vlm"),
+ correlation = correlation,
+ dispersion = dispersion)
- answer <-
- new("summary.vglm",
- object,
- coef3=stuff at coef3,
- cov.unscaled=stuff at cov.unscaled,
- correlation=stuff at correlation,
- df=stuff at df,
- sigma=stuff at sigma)
+ answer <-
+ new("summary.vglm",
+ object,
+ coef3 = stuff at coef3,
+ cov.unscaled = stuff at cov.unscaled,
+ correlation = stuff at correlation,
+ df = stuff at df,
+ sigma = stuff at sigma)
- presid = resid(object, type="pearson")
- if (length(presid))
- answer at pearson.resid = as.matrix(presid)
+ presid = resid(object, type = "pearson")
+ if (length(presid))
+ answer at pearson.resid = as.matrix(presid)
- slot(answer, "misc") = stuff at misc # Replace
+ slot(answer, "misc") = stuff at misc # Replace
- if (is.numeric(stuff at dispersion))
- slot(answer, "dispersion") = stuff at dispersion
+ if (is.numeric(stuff at dispersion))
+ slot(answer, "dispersion") = stuff at dispersion
- answer
+ answer
}
@@ -64,104 +64,107 @@ setMethod("logLik", "summary.vglm", function(object, ...)
printsummary.vglm <- function(x, digits = NULL, quote = TRUE, prefix = "",
- presid = TRUE)
-{
-
- M <- x at misc$M
- coef <- x at coef3 # icients
- correl <- x at correlation
-
- digits <- if (is.null(digits)) options()$digits - 2 else digits
-
- cat("\nCall:\n")
- dput(x at call)
-
- Presid <- x at pearson.resid
- rdf <- x at df[2]
- if (presid && length(Presid) && all(!is.na(Presid)) && is.finite(rdf))
- {
- cat("\nPearson Residuals:\n")
- if (rdf/M > 5)
- {
- rq <- apply(as.matrix(Presid), 2, quantile) # 5 x M
- dimnames(rq) <- list(c("Min", "1Q", "Median", "3Q", "Max"),
- x at misc$predictors.names)
- print(t(rq), digits = digits)
- } else
- if (rdf > 0) {
- print(Presid, digits = digits)
- }
- }
-
- cat("\nCoefficients:\n")
- print.default(coef, digits = digits)
-
- cat("\nNumber of linear predictors: ", M, "\n")
-
- if (!is.null(x at misc$predictors.names))
- if (M==1)
- cat("\nName of linear predictor:",
- paste(x at misc$predictors.names, collapse=", "), "\n") else if (M<=5)
- cat("\nNames of linear predictors:",
- paste(x at misc$predictors.names, collapse=", "), fill=TRUE)
-
- prose <- ""
- if (length(x at dispersion)) {
- if (is.logical(x at misc$estimated.dispersion) &&
- x at misc$estimated.dispersion)
- prose <- "(Estimated) " else {
-
- if (is.numeric(x at misc$default.dispersion) &&
- x at dispersion==x at misc$default.dispersion)
- prose <- "(Default) "
-
- if (is.numeric(x at misc$default.dispersion) &&
- x at dispersion!=x at misc$default.dispersion)
- prose <- "(Pre-specified) "
- }
- cat(paste("\n", prose, "Dispersion Parameter for ",
- x at family@vfamily[1],
- " family: ", yformat(x at dispersion, digits), "\n", sep=""))
- }
-
- if (length(deviance(x))) {
- cat("\nResidual Deviance:", yformat(deviance(x), digits))
- if (is.finite(rdf))
- cat(" on", round(rdf, digits), "degrees of freedom\n") else
- cat("\n")
- }
- if (length(vll <- logLik.vlm(x))) {
- cat("\nLog-likelihood:", yformat(vll, digits))
- if (is.finite(rdf))
- cat(" on", round(rdf, digits), "degrees of freedom\n") else
- cat("\n")
+ presid = TRUE) {
+
+ M <- x at misc$M
+ coef <- x at coef3 # icients
+ correl <- x at correlation
+
+ digits <- if (is.null(digits)) options()$digits - 2 else digits
+
+ cat("\nCall:\n")
+ dput(x at call)
+
+ Presid <- x at pearson.resid
+ rdf <- x at df[2]
+ if (presid &&
+ length(Presid) &&
+ all(!is.na(Presid)) &&
+ is.finite(rdf)) {
+ cat("\nPearson Residuals:\n")
+ if (rdf/M > 5) {
+ rq <- apply(as.matrix(Presid), 2, quantile) # 5 x M
+ dimnames(rq) <- list(c("Min", "1Q", "Median", "3Q", "Max"),
+ x at misc$predictors.names)
+ print(t(rq), digits = digits)
+ } else
+ if (rdf > 0) {
+ print(Presid, digits = digits)
+ }
+ }
+
+ cat("\nCoefficients:\n")
+ print.default(coef, digits = digits)
+
+ cat("\nNumber of linear predictors: ", M, "\n")
+
+ if (!is.null(x at misc$predictors.names))
+ if (M == 1)
+ cat("\nName of linear predictor:",
+ paste(x at misc$predictors.names, collapse = ", "), "\n") else
+ if (M <= 5)
+ cat("\nNames of linear predictors:",
+ paste(x at misc$predictors.names, collapse = ", "), fill = TRUE)
+
+ prose <- ""
+ if (length(x at dispersion)) {
+ if (is.logical(x at misc$estimated.dispersion) &&
+ x at misc$estimated.dispersion)
+ prose <- "(Estimated) " else {
+
+ if (is.numeric(x at misc$default.dispersion) &&
+ x at dispersion==x at misc$default.dispersion)
+ prose <- "(Default) "
+
+ if (is.numeric(x at misc$default.dispersion) &&
+ x at dispersion!=x at misc$default.dispersion)
+ prose <- "(Pre-specified) "
+ }
+ cat(paste("\n", prose, "Dispersion Parameter for ",
+ x at family@vfamily[1],
+ " family: ", yformat(x at dispersion, digits), "\n", sep = ""))
+ }
+
+
+ if (length(deviance(x))) {
+ cat("\nResidual Deviance:", yformat(deviance(x), digits))
+ if (is.finite(rdf))
+ cat(" on", round(rdf, digits), "degrees of freedom\n") else
+ cat("\n")
+ }
+
+
+ if (length(vll <- logLik.vlm(x))) {
+ cat("\nLog-likelihood:", yformat(vll, digits))
+ if (is.finite(rdf))
+ cat(" on", round(rdf, digits), "degrees of freedom\n") else
+ cat("\n")
+ }
+
+
+ if (length(x at criterion)) {
+ ncrit <- names(x at criterion)
+ for(ii in ncrit)
+ if (ii != "loglikelihood" && ii != "deviance")
+ cat(paste(ii, ":", sep = ""), yformat(x at criterion[[ii]], digits),
+ "\n")
+ }
+
+
+ cat("\nNumber of Iterations:", format(trunc(x at iter)), "\n")
+
+ if (!is.null(correl)) {
+ ncol_X_vlm <- dim(correl)[2]
+ if (ncol_X_vlm > 1) {
+ cat("\nCorrelation of Coefficients:\n")
+ ll <- lower.tri(correl)
+ correl[ll] <- format(round(correl[ll], digits))
+ correl[!ll] <- ""
+ print(correl[-1, -ncol_X_vlm, drop = FALSE], quote = FALSE,
+ digits = digits)
}
-
- if (length(x at criterion)) {
- ncrit <- names(x at criterion)
- for(i in ncrit)
- if (i!="loglikelihood" && i!="deviance")
- cat(paste(i, ":", sep=""), yformat(x at criterion[[i]], digits),
- "\n")
- }
-
-
- cat("\nNumber of Iterations:", format(trunc(x at iter)), "\n")
-
- if (!is.null(correl))
- {
- ncol_X_vlm <- dim(correl)[2]
- if (ncol_X_vlm > 1)
- {
- cat("\nCorrelation of Coefficients:\n")
- ll <- lower.tri(correl)
- correl[ll] <- format(round(correl[ll], digits))
- correl[!ll] <- ""
- print(correl[-1, -ncol_X_vlm, drop = FALSE], quote = FALSE,
- digits = digits)
- }
- }
- invisible(NULL)
+ }
+ invisible(NULL)
}
@@ -185,13 +188,16 @@ printsummary.vglm <- function(x, digits = NULL, quote = TRUE, prefix = "",
vcovdefault <- function(object, ...) {
- if (is.null(object at vcov))
- stop("no default")
- object at vcov
+ if (is.null(object at vcov))
+ stop("no default")
+ object at vcov
}
-vcovvlm <- function(object, dispersion=NULL, untransform=FALSE) {
- so <- summaryvlm(object, corr=FALSE, dispersion=dispersion)
+
+
+
+ vcovvlm <- function(object, dispersion = NULL, untransform = FALSE) {
+ so <- summaryvlm(object, corr = FALSE, dispersion = dispersion)
d = if (any(slotNames(so) == "dispersion") &&
is.Numeric(so at dispersion)) so at dispersion else 1
answer = d * so at cov.unscaled
@@ -200,7 +206,8 @@ vcovvlm <- function(object, dispersion=NULL, untransform=FALSE) {
warning("MLE regularity conditions were violated ",
"at the final iteration of the fitted object")
- if (!untransform) return(answer)
+ if (!untransform)
+ return(answer)
if (!is.logical(object at misc$intercept.only))
stop("cannot determine whether the object is",
@@ -222,18 +229,19 @@ vcovvlm <- function(object, dispersion=NULL, untransform=FALSE) {
etavector = predict(object)[1,] # Contains transformed parameters
earg = object at misc$earg # This could be a NULL
if (!is.null(earg) && M > 1 && (!is.list(earg) || length(earg) != M))
- stop("the 'earg' component of 'object at misc' should be of length ", M)
+ stop("the 'earg' component of 'object at misc' should be of length ", M)
for(ii in 1:M) {
TTheta = etavector[ii] # Transformed theta
use.earg = if (M == 1 || is.null(earg)) earg else earg[[ii]]
if (is.list(use.earg) && !length(use.earg))
use.earg = NULL
newcall = paste(Links[ii],
- "(theta=TTheta, earg=use.earg, inverse=TRUE)", sep="")
+ "(theta = TTheta, earg = use.earg, inverse = TRUE)",
+ sep = "")
newcall = parse(text=newcall)[[1]]
Theta = eval(newcall) # Theta, the untransformed parameter
newcall = paste(Links[ii],
- "(theta=Theta, earg=use.earg, deriv=1)", sep="")
+ "(theta=Theta, earg = use.earg, deriv=1)", sep = "")
newcall = parse(text=newcall)[[1]]
tvector[ii] = eval(newcall)
}
@@ -244,6 +252,10 @@ vcovvlm <- function(object, dispersion=NULL, untransform=FALSE) {
answer
}
+
+
+
+
setMethod("vcov", "vlm",
function(object, ...)
vcovvlm(object, ...))
diff --git a/R/summary.vlm.q b/R/summary.vlm.q
index 7ee03cd..a6253de 100644
--- a/R/summary.vlm.q
+++ b/R/summary.vlm.q
@@ -7,8 +7,10 @@
-summaryvlm <- function(object, correlation = FALSE, dispersion = NULL)
-{
+
+
+
+summaryvlm <- function(object, correlation = FALSE, dispersion = NULL) {
if (is.logical(object at misc$BFGS) && object at misc$BFGS)
@@ -72,12 +74,12 @@ summaryvlm <- function(object, correlation = FALSE, dispersion = NULL)
dimnames(coef) <- list(cnames, c("Value", "Std. Error", "t value"))
if (length(sigma) == 1 && is.Numeric(ncol_X_vlm)) {
coef[, 2] <- rowlen %o% sigma # Fails here when sigma is a vector
- coef[, 3] <- coef[, 1]/coef[, 2]
+ coef[, 3] <- coef[, 1] / coef[, 2]
} else {
coef[,1] = coef[,2] = coef[,3] = NA
}
if (correlation) {
- correl <- covun * outer(1/rowlen, 1/rowlen)
+ correl <- covun * outer(1 / rowlen, 1 / rowlen)
dimnames(correl) <- list(cnames, cnames)
} else {
correl <- matrix(0, 0, 0) # was NULL, but now a special matrix
@@ -89,10 +91,10 @@ summaryvlm <- function(object, correlation = FALSE, dispersion = NULL)
answer <-
new("summary.vlm",
object,
- coef3=coef,
- correlation=correl,
- df=c(ncol_X_vlm, rdf),
- sigma=sigma)
+ coef3 = coef,
+ correlation = correl,
+ df = c(ncol_X_vlm, rdf),
+ sigma = sigma)
if (is.Numeric(ncol_X_vlm)) answer at cov.unscaled = covun
answer at dispersion = dispersion # Overwrite this
@@ -107,8 +109,8 @@ summaryvlm <- function(object, correlation = FALSE, dispersion = NULL)
-printsummary.vlm <- function(x, digits = NULL, quote = TRUE, prefix = "")
-{
+printsummary.vlm <- function(x, digits = NULL, quote = TRUE,
+ prefix = "") {
M <- x at misc$M
@@ -127,8 +129,7 @@ printsummary.vlm <- function(x, digits = NULL, quote = TRUE, prefix = "")
presid <- x at pearson.resid
rdf <- x at df[2]
- if (length(presid) && all(!is.na(presid)))
- {
+ if (length(presid) && all(!is.na(presid))) {
cat("\nPearson residuals:\n")
if (rdf/M > 5) {
rq <- apply(as.matrix(presid), 2, quantile) # 5 x M
@@ -148,8 +149,9 @@ printsummary.vlm <- function(x, digits = NULL, quote = TRUE, prefix = "")
cat("\nNumber of responses: ", M, "\n")
+
if (length(x at misc$predictors.names))
- if (M==1) {
+ if (M == 1) {
cat("\nName of response:",
paste(x at misc$predictors.names, collapse = ", "), "\n")
} else {
@@ -159,10 +161,12 @@ printsummary.vlm <- function(x, digits = NULL, quote = TRUE, prefix = "")
cat(UUU, fill = TRUE, sep = ", ")
}
+
if (!is.null(x at rss))
cat("\nResidual Sum of Squares:", format(round(x at rss, digits)),
"on", round(rdf, digits), "degrees of freedom\n")
+
if (length(correl)) {
ncol_X_vlm <- dim(correl)[2]
if (ncol_X_vlm > 1) {
@@ -173,6 +177,8 @@ printsummary.vlm <- function(x, digits = NULL, quote = TRUE, prefix = "")
print(correl[-1, -ncol_X_vlm, drop = FALSE], quote = FALSE, digits=digits)
}
}
+
+
invisible(NULL)
}
diff --git a/R/uqo.R b/R/uqo.R
index 9585148..403af66 100644
--- a/R/uqo.R
+++ b/R/uqo.R
@@ -262,7 +262,7 @@ calluqof = function(sitescores, etamat, ymat, wvec, modelno, nice31, xmat,
- sdnumat = sd(numat)
+ sdnumat = apply(numat, 2, sd)
for(lookat in 1:Rank)
if (sdnumat[lookat]>control$MUXfactor[lookat]*control$isdlv[lookat]){
muxer = control$isdlv[lookat] * control$MUXfactor[lookat] /
@@ -336,7 +336,7 @@ callduqof = function(sitescores, etamat, ymat, wvec, modelno, nice31, xmat,
numat = numat %*% evnu$vector
}
- sdnumat = sd(numat)
+ sdnumat = apply(numat, 2, sd)
for(lookat in 1:Rank)
if (sdnumat[lookat]>control$MUXfactor[lookat]*control$isdlv[lookat]){
muxer = control$isdlv[lookat] * control$MUXfactor[lookat] /
@@ -426,7 +426,7 @@ uqo.fit <- function(x, y, w=rep(1, len=nrow(x)),
if (length(etastart)) {
eta <- etastart
- mu <- if (length(mustart)) mustart else family at inverse(eta, extra)
+ mu <- if (length(mustart)) mustart else family at linkinv(eta, extra)
} else {
if (length(mustart))
mu <- mustart
@@ -756,7 +756,7 @@ setMethod("predict", "uqo", function(object, ...)
setMethod("persp", "uqo", function(x, ...)
- persp.qrrvglm(x, ...))
+ perspqrrvglm(x, ...))
setMethod("trplot", "uqo", function(object, ...)
trplot.qrrvglm(object, check.ok=FALSE, ...))
diff --git a/R/vgam.R b/R/vgam.R
index 87c1a5b..b9da9f3 100644
--- a/R/vgam.R
+++ b/R/vgam.R
@@ -11,18 +11,18 @@
vgam <- function(formula,
family,
data=list(),
- weights=NULL,
- subset=NULL,
+ weights = NULL,
+ subset = NULL,
na.action=na.fail,
- etastart=NULL, mustart=NULL, coefstart=NULL,
+ etastart = NULL, mustart = NULL, coefstart = NULL,
control=vgam.control(...),
- offset=NULL,
- method="vgam.fit",
- model=FALSE, x.arg=TRUE, y.arg=TRUE,
- contrasts=NULL,
- constraints=NULL,
+ offset = NULL,
+ method = "vgam.fit",
+ model = FALSE, x.arg = TRUE, y.arg = TRUE,
+ contrasts = NULL,
+ constraints = NULL,
extra=list(),
- qr.arg=FALSE, smart=TRUE,
+ qr.arg = FALSE, smart = TRUE,
...)
{
dataname <- as.character(substitute(data)) # "list" if no data=
@@ -95,7 +95,7 @@ vgam <- function(formula,
if (is.function(family))
family <- family()
if (!inherits(family, "vglmff")) {
- stop("'family=", family, "' is not a VGAM family function")
+ stop("'family = ", family, "' is not a VGAM family function")
}
eval(vcontrol.expression)
@@ -103,7 +103,7 @@ vgam <- function(formula,
n <- dim(x)[1]
if (FALSE && is.R()) {
- family at inverse <- eval(family at inverse)
+ family at linkinv <- eval(family at linkinv)
family at link <- eval(family at link)
for (ii in names(.min.criterion.VGAM))
@@ -126,7 +126,7 @@ vgam <- function(formula,
nonparametric <- length(smoothers$s) > 0
if (nonparametric) {
- ff <- apply(aa$factors[smoothers[["s"]],,drop=FALSE], 2, any)
+ ff <- apply(aa$factors[smoothers[["s"]],,drop = FALSE], 2, any)
smoothers[["s"]] <- if (any(ff))
seq(along=ff)[aa$order==1 & ff] else NULL
@@ -197,7 +197,7 @@ vgam <- function(formula,
"smart.prediction" = as.list(fit$smart.prediction),
"terms" = list(terms=fit$terms))
- if (!smart) answer at smart.prediction <- list(smart.arg=FALSE)
+ if (!smart) answer at smart.prediction <- list(smart.arg = FALSE)
if (qr.arg) {
class(fit$qr) = "list"
diff --git a/R/vgam.fit.q b/R/vgam.fit.q
index b0ce491..1a55829 100644
--- a/R/vgam.fit.q
+++ b/R/vgam.fit.q
@@ -40,7 +40,7 @@ vgam.fit <- function(x, y, w, mf,
eval(family at middle)
eta <- fv + offset
- mu <- family at inverse(eta, extra)
+ mu <- family at linkinv(eta, extra)
if (length(family at middle2))
eval(family at middle2)
@@ -108,16 +108,16 @@ vgam.fit <- function(x, y, w, mf,
if (length(etastart)) {
eta <- etastart
mu <- if (length(mustart)) mustart else
- if (length(body(slot(family, "inverse"))))
- slot(family, "inverse")(eta, extra) else
+ if (length(body(slot(family, "linkinv"))))
+ slot(family, "linkinv")(eta, extra) else
warning("argument 'etastart' assigned a value ",
- "but there is no 'inverse' slot to use it")
+ "but there is no 'linkinv' slot to use it")
}
if (length(mustart)) {
mu <- mustart
- if (length(body(slot(family, "link")))) {
- eta <- slot(family, "link")(mu, extra)
+ if (length(body(slot(family, "linkfun")))) {
+ eta <- slot(family, "linkfun")(mu, extra)
} else {
warning("argument 'mustart' assigned a value ",
"but there is no 'link' slot to use it")
@@ -175,7 +175,7 @@ vgam.fit <- function(x, y, w, mf,
eta <- if (ncol(X_vlm_save) > 1) X_vlm_save %*% coefstart +
offset else X_vlm_save * coefstart + offset
eta <- if (M > 1) matrix(eta, ncol=M, byrow = TRUE) else c(eta)
- mu <- family at inverse(eta, extra)
+ mu <- family at linkinv(eta, extra)
}
diff --git a/R/vglm.R b/R/vglm.R
index 19f1364..cea7790 100644
--- a/R/vglm.R
+++ b/R/vglm.R
@@ -193,9 +193,13 @@ if (!is.null(form2)) {
} else list() # R-1.5.0
slot(answer, "iter") = fit$iter
slot(answer, "post") = fit$post
+
+
fit$predictors = as.matrix(fit$predictors) # Must be a matrix
- dimnames(fit$predictors) = list(dimnames(fit$predictors)[[1]],
- fit$misc$predictors.names)
+
+ if (length(fit$misc$predictors.names) == ncol(fit$predictors))
+ dimnames(fit$predictors) = list(dimnames(fit$predictors)[[1]],
+ fit$misc$predictors.names)
slot(answer, "predictors") = fit$predictors
if (length(fit$prior.weights))
slot(answer, "prior.weights") = as.matrix(fit$prior.weights)
diff --git a/R/vglm.fit.q b/R/vglm.fit.q
index c8f2b8b..3f392e3 100644
--- a/R/vglm.fit.q
+++ b/R/vglm.fit.q
@@ -39,7 +39,7 @@ vglm.fit <- function(x, y, w=rep(1, length(x[, 1])),
eval(slot(family, "middle"))
eta <- fv + offset
- mu <- slot(family, "inverse")(eta, extra)
+ mu <- slot(family, "linkinv")(eta, extra)
if (length(slot(family, "middle2")))
eval(slot(family, "middle2"))
@@ -98,7 +98,7 @@ vglm.fit <- function(x, y, w=rep(1, length(x[, 1])),
fv <- matrix(fv, n, M, byrow = TRUE)
eta <- fv + offset
- mu <- slot(family, "inverse")(eta, extra)
+ mu <- slot(family, "linkinv")(eta, extra)
if (length(slot(family, "middle2")))
eval(slot(family, "middle2"))
@@ -191,16 +191,16 @@ vglm.fit <- function(x, y, w=rep(1, length(x[, 1])),
if (length(etastart)) {
eta <- etastart
mu <- if (length(mustart)) mustart else
- if (length(body(slot(family, "inverse"))))
- slot(family, "inverse")(eta, extra) else
+ if (length(body(slot(family, "linkinv"))))
+ slot(family, "linkinv")(eta, extra) else
warning("argument 'etastart' assigned a value ",
- "but there is no 'inverse' slot to use it")
+ "but there is no 'linkinv' slot to use it")
}
if (length(mustart)) {
mu <- mustart
- if (length(body(slot(family, "link")))) {
- eta <- slot(family, "link")(mu, extra)
+ if (length(body(slot(family, "linkfun")))) {
+ eta <- slot(family, "linkfun")(mu, extra)
} else {
warning("argument 'mustart' assigned a value ",
"but there is no 'link' slot to use it")
@@ -230,7 +230,7 @@ vglm.fit <- function(x, y, w=rep(1, length(x[, 1])),
eta <- if (ncol(X_vlm_save)>1) X_vlm_save %*% coefstart +
offset else X_vlm_save * coefstart + offset
eta <- if (M > 1) matrix(eta, ncol = M, byrow = TRUE) else c(eta)
- mu <- slot(family, "inverse")(eta, extra)
+ mu <- slot(family, "linkinv")(eta, extra)
}
diff --git a/data/alclevels.rda b/data/alclevels.rda
index 2a0009f..a0ed2e3 100644
Binary files a/data/alclevels.rda and b/data/alclevels.rda differ
diff --git a/data/alcoff.rda b/data/alcoff.rda
index 291d0e2..89847ff 100644
Binary files a/data/alcoff.rda and b/data/alcoff.rda differ
diff --git a/data/auuc.rda b/data/auuc.rda
index 7761c87..a0d31bc 100644
Binary files a/data/auuc.rda and b/data/auuc.rda differ
diff --git a/data/azprocedure.rda b/data/azprocedure.rda
index a947f80..c1f21b2 100644
Binary files a/data/azprocedure.rda and b/data/azprocedure.rda differ
diff --git a/data/backPain.rda b/data/backPain.rda
index 3e1a07a..0d11079 100644
Binary files a/data/backPain.rda and b/data/backPain.rda differ
diff --git a/data/car.all.rda b/data/car.all.rda
index 486cad7..980046c 100644
Binary files a/data/car.all.rda and b/data/car.all.rda differ
diff --git a/data/chestnz.txt.gz b/data/chestnz.txt.gz
index 4e16957..a460183 100644
Binary files a/data/chestnz.txt.gz and b/data/chestnz.txt.gz differ
diff --git a/data/crashbc.rda b/data/crashbc.rda
index 4fb11f7..d50332a 100644
Binary files a/data/crashbc.rda and b/data/crashbc.rda differ
diff --git a/data/crashf.rda b/data/crashf.rda
index c2dabbb..538d3d7 100644
Binary files a/data/crashf.rda and b/data/crashf.rda differ
diff --git a/data/crashi.rda b/data/crashi.rda
index 8232120..977f7e5 100644
Binary files a/data/crashi.rda and b/data/crashi.rda differ
diff --git a/data/crashmc.rda b/data/crashmc.rda
index d3ba0d9..5fca503 100644
Binary files a/data/crashmc.rda and b/data/crashmc.rda differ
diff --git a/data/crashp.rda b/data/crashp.rda
index 0591fdc..81ca3b5 100644
Binary files a/data/crashp.rda and b/data/crashp.rda differ
diff --git a/data/crashtr.rda b/data/crashtr.rda
index ea6e873..87d2093 100644
Binary files a/data/crashtr.rda and b/data/crashtr.rda differ
diff --git a/data/fibre15.rda b/data/fibre15.rda
index ba252fc..161323f 100644
Binary files a/data/fibre15.rda and b/data/fibre15.rda differ
diff --git a/data/fibre1dot5.rda b/data/fibre1dot5.rda
index 3fe73a7..5f507d0 100644
Binary files a/data/fibre1dot5.rda and b/data/fibre1dot5.rda differ
diff --git a/data/finney44.rda b/data/finney44.rda
new file mode 100644
index 0000000..1828aec
Binary files /dev/null and b/data/finney44.rda differ
diff --git a/data/gala.rda b/data/gala.rda
index d1637ec..3580f83 100644
Binary files a/data/gala.rda and b/data/gala.rda differ
diff --git a/data/gew.txt.gz b/data/gew.txt.gz
index 3f51f76..0653af6 100644
Binary files a/data/gew.txt.gz and b/data/gew.txt.gz differ
diff --git a/data/hspider.rda b/data/hspider.rda
index 9bb6717..7347100 100644
Binary files a/data/hspider.rda and b/data/hspider.rda differ
diff --git a/data/hued.rda b/data/hued.rda
index 27342b9..29f3c5e 100644
Binary files a/data/hued.rda and b/data/hued.rda differ
diff --git a/data/huie.rda b/data/huie.rda
index 32ae9c3..9d98fe0 100644
Binary files a/data/huie.rda and b/data/huie.rda differ
diff --git a/data/hunua.txt.gz b/data/hunua.txt.gz
index 84c7377..9ecb4b2 100644
Binary files a/data/hunua.txt.gz and b/data/hunua.txt.gz differ
diff --git a/data/huse.rda b/data/huse.rda
index f0e461c..d2db92f 100644
Binary files a/data/huse.rda and b/data/huse.rda differ
diff --git a/data/leukemia.rda b/data/leukemia.rda
index cc0b3b3..51bfd1e 100644
Binary files a/data/leukemia.rda and b/data/leukemia.rda differ
diff --git a/data/mmt.rda b/data/mmt.rda
index 9ec1dcb..ee5a72f 100644
Binary files a/data/mmt.rda and b/data/mmt.rda differ
diff --git a/data/nzmarital.rda b/data/nzmarital.rda
index 12bd5ea..11718ce 100644
Binary files a/data/nzmarital.rda and b/data/nzmarital.rda differ
diff --git a/data/pneumo.rda b/data/pneumo.rda
index c28e52e..d450d98 100644
Binary files a/data/pneumo.rda and b/data/pneumo.rda differ
diff --git a/data/rainfall.rda b/data/rainfall.rda
index f727243..b99a6e7 100644
Binary files a/data/rainfall.rda and b/data/rainfall.rda differ
diff --git a/data/ruge.rda b/data/ruge.rda
index e31cabc..db5a77e 100644
Binary files a/data/ruge.rda and b/data/ruge.rda differ
diff --git a/data/toxop.rda b/data/toxop.rda
index 3f6a9a8..6642d43 100644
Binary files a/data/toxop.rda and b/data/toxop.rda differ
diff --git a/data/ugss.rda b/data/ugss.rda
index 17defc8..a162e4c 100644
Binary files a/data/ugss.rda and b/data/ugss.rda differ
diff --git a/data/uscrime.rda b/data/uscrime.rda
index e680068..6aaceb2 100644
Binary files a/data/uscrime.rda and b/data/uscrime.rda differ
diff --git a/data/usgrain.txt.gz b/data/usgrain.txt.gz
index d12d350..a6b643c 100644
Binary files a/data/usgrain.txt.gz and b/data/usgrain.txt.gz differ
diff --git a/data/venice.rda b/data/venice.rda
index b67b7fc..9fce965 100644
Binary files a/data/venice.rda and b/data/venice.rda differ
diff --git a/data/venice90.rda b/data/venice90.rda
index ddb10ef..7d87be2 100644
Binary files a/data/venice90.rda and b/data/venice90.rda differ
diff --git a/data/waitakere.txt.gz b/data/waitakere.txt.gz
index 775e45a..1971b3f 100644
Binary files a/data/waitakere.txt.gz and b/data/waitakere.txt.gz differ
diff --git a/data/wffc.indiv.rda b/data/wffc.indiv.rda
index 5f03639..6c195a6 100644
Binary files a/data/wffc.indiv.rda and b/data/wffc.indiv.rda differ
diff --git a/data/wffc.nc.rda b/data/wffc.nc.rda
index 8d16499..8d17a51 100644
Binary files a/data/wffc.nc.rda and b/data/wffc.nc.rda differ
diff --git a/data/wffc.rda b/data/wffc.rda
index 7d9906a..2edf8ae 100644
Binary files a/data/wffc.rda and b/data/wffc.rda differ
diff --git a/data/wffc.teams.rda b/data/wffc.teams.rda
index d810566..5f8e595 100644
Binary files a/data/wffc.teams.rda and b/data/wffc.teams.rda differ
diff --git a/inst/doc/categoricalVGAM.pdf b/inst/doc/categoricalVGAM.pdf
index 8bb3f9a..b796de0 100644
Binary files a/inst/doc/categoricalVGAM.pdf and b/inst/doc/categoricalVGAM.pdf differ
diff --git a/man/BratUC.Rd b/man/BratUC.Rd
index cb2f47e..d917c2c 100644
--- a/man/BratUC.Rd
+++ b/man/BratUC.Rd
@@ -6,31 +6,37 @@
Takes in a square matrix of counts and outputs
them in a form that is accessible to the \code{\link{brat}}
and \code{\link{bratt}} family functions.
+
}
\usage{
-Brat(mat, ties=0*mat, string=c(" > "," == "))
+Brat(mat, ties = 0 * mat, string = c(" > "," == "))
}
%- maybe also 'usage' for other objects documented here.
\arguments{
\item{mat}{ Matrix of counts,
-which is considered \eqn{M} by \eqn{M} in dimension when
-there are ties, and \eqn{M+1} by \eqn{M+1}
-when there are no ties.
-The rows are winners and the columns are losers, e.g.,
-the 2-1 element is now many times Competitor 2 has beaten
-Competitor 1.
-The matrices are best labelled with the competitors' names.
+ which is considered \eqn{M} by \eqn{M} in dimension when
+ there are ties, and \eqn{M+1} by \eqn{M+1}
+ when there are no ties.
+ The rows are winners and the columns are losers, e.g.,
+ the 2-1 element is now many times Competitor 2 has beaten
+ Competitor 1.
+ The matrices are best labelled with the competitors' names.
+
+
}
\item{ties}{ Matrix of counts. This should be the same
-dimension as \code{mat}. By default, there are no ties.
-The matrix must be symmetric, and the diagonal should contain
-\code{NA}s.
+ dimension as \code{mat}. By default, there are no ties.
+ The matrix must be symmetric, and the diagonal should contain
+ \code{NA}s.
+
+
}
\item{string}{ Character.
-The matrices are labelled with the first value of the descriptor, e.g.,
-\code{"NZ > Oz"} `means' NZ beats Australia in rugby.
-Suggested alternatives include \code{" beats "} or \code{" wins against "}.
-The second value is used to handle ties.
+ The matrices are labelled with the first value of the descriptor, e.g.,
+ \code{"NZ > Oz"} `means' NZ beats Australia in rugby.
+ Suggested alternatives include \code{" beats "} or \code{" wins against "}.
+ The second value is used to handle ties.
+
}
}
@@ -42,26 +48,40 @@ The second value is used to handle ties.
while if there are ties, the non-diagonal elements of the \eqn{M}
by \eqn{M} matrix are concatenated into \eqn{M(M-1)} values.
+
}
\value{
A matrix with 1 row and either \eqn{M(M+1)} or \eqn{M(M-1)} columns.
+
+
}
\references{
+
+
Agresti, A. (2002)
\emph{Categorical Data Analysis},
2nd ed. New York: Wiley.
+
+
}
\author{ T. W. Yee }
\note{
+
+
This is a data preprocessing function for
\code{\link{brat}} and \code{\link{bratt}}.
+
Yet to do: merge \code{InverseBrat} into \code{brat}.
+
+
}
\seealso{
-\code{\link{brat}},
-\code{\link{bratt}},
-\code{InverseBrat}.
+
+ \code{\link{brat}},
+ \code{\link{bratt}},
+ \code{InverseBrat}.
+
}
\examples{
journal = c("Biometrika", "Comm Statist", "JASA", "JRSS-B")
@@ -69,7 +89,7 @@ m = matrix(c( NA, 33, 320, 284, 730, NA, 813, 276,
498, 68, NA, 325, 221, 17, 142, NA), 4, 4)
dimnames(m) = list(winner = journal, loser = journal)
Brat(m)
-vglm(Brat(m) ~ 1, brat, trace=TRUE)
+vglm(Brat(m) ~ 1, brat, trace = TRUE)
}
\keyword{models}
\keyword{regression}
diff --git a/man/Coef.Rd b/man/Coef.Rd
index 5647df4..b89d025 100644
--- a/man/Coef.Rd
+++ b/man/Coef.Rd
@@ -5,47 +5,60 @@
\description{
\code{Coef} is a generic function which computes model
coefficients from objects returned by modelling functions.
- It is an auxiliary function to \code{\link[stats]{coef}}
- that enables extra capabilities for some specific models.
+ It is an auxiliary function to \code{\link[stats]{coef}} that
+ enables extra capabilities for some specific models.
+
}
\usage{
Coef(object, ...)
}
%- maybe also 'usage' for other objects documented here.
\arguments{
- \item{object}{ An object for which the computation of other
- types of model coefficients or quantities is meaningful.
- }
- \item{\dots}{ Other arguments fed into the specific
- methods function of the model.
- }
+\item{object}{
+ An object for which the computation of other types of model
+ coefficients or quantities is meaningful.
+
+
+}
+\item{\dots}{
+ Other arguments fed into the specific methods function of
+ the model.
+
+
+}
}
\details{
- This function can often be useful for \code{\link{vglm}}
- objects with just an intercept term in the RHS of
- the formula, e.g., \code{y ~ 1}. Then often this function
- will apply the inverse link functions to the parameters.
- See the example below.
+ This function can often be useful for \code{\link{vglm}} objects
+ with just an intercept term in the RHS of the formula, e.g.,
+ \code{y ~ 1}. Then often this function will apply the inverse
+ link functions to the parameters. See the example below.
+
+
+ For reduced-rank VGLMs, this function can return the \bold{A},
+ \bold{C} matrices, etc.
- For reduced-rank VGLMs, this function can return the
- \bold{A}, \bold{C} matrices, etc.
For quadratic and additive ordination models, this function
- can return
- ecological meaningful quantities such as tolerances,
+ can return ecological meaningful quantities such as tolerances,
optima, maxima.
+
}
\value{
- The value returned depends specifically on the methods
- function invoked.
+ The value returned depends specifically on the methods function
+ invoked.
+
+
}
\references{
+
+
Yee, T. W. and Hastie, T. J. (2003)
Reduced-rank vector generalized linear models.
\emph{Statistical Modelling},
\bold{3}, 15--41.
+
}
\author{ Thomas W. Yee }
@@ -53,25 +66,28 @@ Reduced-rank vector generalized linear models.
%}
\section{Warning }{
- This function may not work for \emph{all} \pkg{VGAM}
- family functions. You should check your results on some
- artificial data before applying it to models fitted to
- real data.
+ This function may not work for \emph{all} \pkg{VGAM} family
+ functions. You should check your results on some artificial
+ data before applying it to models fitted to real data.
+
+
}
\seealso{
- \code{\link[stats]{coef}},
- \code{\link{Coef.vlm}},
- \code{\link{Coef.rrvglm}},
- \code{\link{Coef.qrrvglm}}.
+ \code{\link[stats]{coef}},
+ \code{\link{Coef.vlm}},
+ \code{\link{Coef.rrvglm}},
+ \code{\link{Coef.qrrvglm}},
+ \code{\link{depvar}}.
+
+
}
\examples{
-set.seed(123)
-nn = 1000
-y = rbeta(nn, shape1=1, shape2=3) # Original scale
+set.seed(123); nn = 1000
+mydata = data.frame(y = rbeta(nn, shape1 = 1, shape2 = 3)) # Original scale
# parameters are estimated on a log scale:
-fit = vglm(y ~ 1, betaff, tr=TRUE, crit="c") # intercept-only model
-coef(fit, matrix=TRUE) # log scale
+fit = vglm(y ~ 1, betaff, mydata, trace = TRUE, crit = "c") # Intercept-only model
+coef(fit, matrix = TRUE) # log scale
Coef(fit) # On the original scale
}
\keyword{models}
diff --git a/man/Coef.qrrvglm-class.Rd b/man/Coef.qrrvglm-class.Rd
index 71a0ad4..63d6a0e 100644
--- a/man/Coef.qrrvglm-class.Rd
+++ b/man/Coef.qrrvglm-class.Rd
@@ -84,11 +84,15 @@ The tolerance matrices satisfy
%No methods defined with class "Coef.qrrvglm" in the signature.
%}
\references{
+
+
Yee, T. W. (2004)
A new technique for maximum-likelihood
canonical Gaussian ordination.
\emph{Ecological Monographs},
\bold{74}, 685--701.
+
+
}
\author{ Thomas W. Yee }
%\note{ ~~further notes~~ }
@@ -100,6 +104,8 @@ canonical Gaussian ordination.
\code{\link{cqo}},
% \code{qrrvglm-class},
\code{print.Coef.qrrvglm}.
+
+
}
\examples{
@@ -116,7 +122,7 @@ y3 = rpois(n, lambda3)
yy = cbind(y1,y2,y3)
# vvv p1 = cqo(yy ~ x2 + x3 + x4, fam=poissonff, trace=FALSE)
\dontrun{
-lvplot(p1, y=TRUE, lcol=1:3, pch=1:3, pcol=1:3)
+lvplot(p1, y = TRUE, lcol = 1:3, pch = 1:3, pcol = 1:3)
}
# vvv print(Coef(p1), digits=3)
}
diff --git a/man/Coef.rrvglm-class.Rd b/man/Coef.rrvglm-class.Rd
index 2aaac11..c67ae1c 100644
--- a/man/Coef.rrvglm-class.Rd
+++ b/man/Coef.rrvglm-class.Rd
@@ -59,11 +59,10 @@ Reduced-rank vector generalized linear models.
\examples{
# Rank-1 stereotype model of Anderson (1984)
-n = nrow(pneumo)
-pneumo = transform(pneumo, let=log(exposure.time), x1=runif(n), x2=runif(n))
-fit = rrvglm(cbind(normal,mild,severe) ~ let + x1 + x2, multinomial, pneumo)
-coef(fit, mat=TRUE)
+pneumo = transform(pneumo, let = log(exposure.time), x3 = runif(nrow(pneumo)))
+fit = rrvglm(cbind(normal, mild, severe) ~ let + x3, multinomial, pneumo)
+coef(fit, matrix = TRUE)
Coef(fit)
-print(Coef(fit), digits=3)
+print(Coef(fit), digits = 3)
}
\keyword{classes}
diff --git a/man/Coef.rrvglm.Rd b/man/Coef.rrvglm.Rd
index e3dbf1b..5d3af9f 100644
--- a/man/Coef.rrvglm.Rd
+++ b/man/Coef.rrvglm.Rd
@@ -18,16 +18,22 @@ Coef.rrvglm(object, ...)
The \bold{A}, \bold{B1}, \bold{C} matrices are returned,
along with other slots.
See \code{\link{rrvglm}} for details about RR-VGLMs.
+
+
}
\value{
An object of class \code{"Coef.rrvglm"}
(see \code{\link{Coef.rrvglm-class}}).
+
+
}
\references{
Yee, T. W. and Hastie, T. J. (2003)
Reduced-rank vector generalized linear models.
\emph{Statistical Modelling},
\bold{3}, 15--41.
+
+
}
\author{ Thomas W. Yee }
\note{ This function is an alternative to \code{coef.rrvglm}. }
@@ -37,16 +43,17 @@ Reduced-rank vector generalized linear models.
\code{\link{Coef.rrvglm-class}},
\code{print.Coef.rrvglm},
\code{\link{rrvglm}}.
+
+
}
\examples{
# Rank-1 stereotype model of Anderson (1984)
-n = nrow(pneumo)
-pneumo = transform(pneumo, let=log(exposure.time), x1=runif(n), x2=runif(n))
-fit = rrvglm(cbind(normal,mild,severe) ~ let + x1 + x2, multinomial, pneumo)
-coef(fit, matrix=TRUE)
+pneumo = transform(pneumo, let = log(exposure.time), x3 = runif(nrow(pneumo)))
+fit = rrvglm(cbind(normal, mild, severe) ~ let + x3, multinomial, pneumo)
+coef(fit, matrix = TRUE)
Coef(fit)
-print(Coef(fit), digits=3)
+print(Coef(fit), digits = 3)
}
\keyword{models}
\keyword{regression}
diff --git a/man/Qvar.Rd b/man/Qvar.Rd
new file mode 100644
index 0000000..5760eb7
--- /dev/null
+++ b/man/Qvar.Rd
@@ -0,0 +1,233 @@
+\name{Qvar}
+\alias{Qvar}
+%- Also NEED an '\alias' for EACH other topic documented here.
+\title{
+Quasi-variances Preprocessing Function
+
+%% ~~function to do ... ~~
+}
+\description{
+ Takes a \code{\link{vglm}} fit or a variance-covariance matrix,
+ and preprocesses it for \code{\link{rcam}} and
+ \code{\link{normal1}} so that quasi-variances can be computed.
+
+
+%% ~~ A concise (1-5 lines) description of what the function does. ~~
+}
+\usage{
+Qvar(object, factorname = NULL, coef.indices = NULL,
+ labels = NULL, dispersion = NULL, reference.name = "(reference)",
+ estimates = NULL)
+}
+%- maybe also 'usage' for other objects documented here.
+\arguments{
+ \item{object}{
+ A \code{"\link[=vglmff-class]{vglm}"} object or a variance-covariance
+ matrix, e.g., \code{vcov(vglm.object)}.
+ The former is preferred since it contains all the information
+ needed.
+ If a matrix then \code{factorname} and/or \code{coef.indices}
+ should be specified to identify the factor.
+
+
+%% ~~Describe \code{object} here~~
+}
+\item{factorname}{
+ Character.
+ If the \code{\link{vglm}} object contains more than one
+ factor as explanatory variable then this argument should
+ be the name of the factor of interest.
+ If \code{object} is a variance-covariance matrix then
+ this argument should also be specified.
+
+
+%% ~~Describe \code{factor.name} here~~
+}
+\item{labels}{
+ Character.
+ Optional, for labelling the variance-covariance matrix.
+
+%% ~~Describe \code{level1.name} here~~
+}
+\item{dispersion}{
+ Numeric.
+ Optional, passed into \code{vcov()} with the same argument name.
+
+%% ~~Describe \code{level1.name} here~~
+}
+\item{reference.name}{
+ Character.
+ Label for for the reference level.
+
+%% ~~Describe \code{level1.name} here~~
+}
+\item{coef.indices}{
+ Optional numeric vector of length at least 3 specifying
+ the indices of the factor from the variance-covariance
+ matrix.
+
+
+}
+\item{estimates}{
+ an optional vector of estimated coefficients
+ (redundant if \code{object} is a model).
+
+}
+}
+\details{
+
+
+ Suppose a factor with \eqn{L} levels is an explanatory variable in a
+ regression model. By default, R treats the first level as baseline so
+ that its coefficient is set to zero. It estimates the other \eqn{L-1}
+ coefficients, and with its associated standard errors, this is the
+ conventional output. From the complete variance-covariance matrix one
+ can compute \eqn{L} quasi-variances based on all pairwise difference
+ of the coefficients. They are based on an approximation, and can be
+ treated as uncorrelated. In minimizing the relative (not absolute)
+ errors it is not hard to see that the estimation involves a RCAM
+ (\code{\link{rcam}}) with an exponential link function
+ (\code{\link{explink}}).
+
+
+ If \code{object} is a model, then at least one of \code{factorname} or
+ \code{coef.indices} must be non-\code{NULL}. The value of
+ \code{coef.indices}, if non-\code{NULL}, determines which rows and
+ columns of the model's variance-covariance matrix to use. If
+ \code{coef.indices} contains a zero, an extra row and column are
+ included at the indicated position, to represent the zero variances
+ and covariances associated with a reference level. If
+ \code{coef.indices} is \code{NULL}, then \code{factorname} should be
+ the name of a factor effect in the model, and is used in order to
+ extract the necessary variance-covariance estimates.
+
+
+ Quasi-variances were first implemented in R with \pkg{qvcalc}.
+ This implementation draws heavily from that.
+
+
+
+%% ~~ If necessary, more details than the description above ~~
+}
+\value{
+ A \eqn{L} by \eqn{L} matrix whose \eqn{i}-\eqn{j} element
+ is the logarithm of the variance of the \eqn{i}th coefficient
+ minus the \eqn{j}th coefficient, for all values of \eqn{i}
+ and \eqn{j}. The diagonal elements are abitrary and are set
+ to zero.
+
+
+ The matrix has an attribute that corresponds to the prior
+ weight matrix; it is accessed by \code{\link{normal1}}
+ and replaces the usual \code{weights} argument.
+ of \code{\link{vglm}}. This weight matrix has ones on
+ the off-diagonals and some small positive number on
+ the diagonals.
+
+
+}
+\references{
+
+
+ Firth, D. (2003)
+ Overcoming the reference category problem in the
+ presentation of statistical models.
+ \emph{Sociological Methodology} \bold{33}, 1--18.
+
+
+ Firth, D. and Menezes, R. X. de (2004)
+ Quasi-variances.
+ \emph{Biometrika} \bold{91}, 65--80.
+
+
+}
+
+\author{
+
+
+ T. W. Yee, based heavily on \code{qvcalc()} in \pkg{qvcalc}
+ written by David Firth.
+
+
+}
+
+\note{
+ This is an adaptation of \code{qvcalc()} in \pkg{qvcalc}.
+ It should work for all \code{\link{vglm}}
+ models with one linear predictor, i.e., \eqn{M = 1}.
+ For \eqn{M > 1} the factor should appear only in one of the
+ linear predictors.
+
+
+ It is important to set \code{maxit} to be larger than usual for
+ \code{\link{rcam}} since convergence is slow. Upon successful
+ convergence the \eqn{i}th row effect and the \eqn{i}th column effect
+ should be equal. A simple computation involving the fitted and
+ predicted values allows the quasi-variances to be extracted (see
+ example below).
+
+
+ A function to plot \emph{comparison intervals} has not been
+ written here.
+
+}
+
+\section{Warning }{
+ Negative quasi-variances may occur (one of them and
+ only one), though they are rare in practice. If
+ so then numerical problems may occur. See
+ \code{qvcalc()} for more information.
+
+
+
+}
+
+
+\seealso{
+ \code{\link{rcam}},
+ \code{\link{vglm}},
+ \code{\link{normal1}},
+ \code{\link{explink}},
+ \code{qvcalc()} in \pkg{qvcalc},
+ \code{\link[MASS]{ships}}.
+
+
+%% ~~objects to See Also as \code{\link{help}}, ~~~
+}
+\examples{
+library(MASS) # Get the "ships" data frame
+data(ships)
+ships = ships
+detach("package:MASS")
+
+Shipmodel <- vglm(incidents ~ type + year + period,
+ quasipoissonff, offset = log(service),
+# trace = TRUE, model = TRUE,
+ data = ships, subset = (service > 0))
+
+# Easiest form of input
+fit1 <- rcam(Qvar(Shipmodel, "type"), normal1("explink"), maxit = 99)
+(quasiVar <- exp(diag(fitted(fit1))) / 2) # Version 1
+(quasiVar <- diag(predict(fit1)[, c(TRUE, FALSE)]) / 2) # Version 2
+(quasiSE <- sqrt(quasiVar))
+
+# Another form of input
+fit2 <- rcam(Qvar(Shipmodel, coef.ind = c(0,2:5), reference.name = "typeA"),
+ normal1("explink"), maxit = 99)
+\dontrun{ plotqvar(fit2, lcol = "blue", llwd = 2, las = 1) }
+
+# The variance-covariance matrix is another form of input (not recommended)
+fit3 <- rcam(Qvar(cbind(0, rbind(0, vcov(Shipmodel)[2:5, 2:5])),
+ labels = c("typeA", "typeB", "typeC", "typeD", "typeE"),
+ estimates = c(typeA = 0, coef(Shipmodel)[2:5])),
+ normal1("explink"), maxit = 99)
+(QuasiVar <- exp(diag(fitted(fit3))) / 2) # Version 1
+(QuasiVar <- diag(predict(fit3)[, c(TRUE, FALSE)]) / 2) # Version 2
+(QuasiSE <- sqrt(quasiVar))
+\dontrun{ plotqvar(fit3) }
+}
+% Add one or more standard keywords, see file 'KEYWORDS' in the
+% R documentation directory.
+\keyword{models}
+\keyword{regression}
+% \code{\link[qvcalc:qvcalc]{qvcalc}} in \pkg{qvcalc}
diff --git a/man/VGAM-package.Rd b/man/VGAM-package.Rd
index 72a0afd..d830e1c 100644
--- a/man/VGAM-package.Rd
+++ b/man/VGAM-package.Rd
@@ -6,14 +6,13 @@
Vector Generalized Linear and Additive Models
}
\description{
-\pkg{VGAM} provides functions for fitting
-vector generalized linear and additive models (VGLMs and VGAMs),
-and associated models
-(Reduced-Rank VGLMs, Quadratic RR-VGLMs, Reduced-Rank VGAMs).
-This package fits many models and distributions by maximum likelihood
-estimation (MLE) or penalized MLE.
-Also fits constrained ordination models in ecology such as constrained
-quadratic ordination (CQO).
+ \pkg{VGAM} provides functions for fitting vector generalized
+ linear and additive models (VGLMs and VGAMs), and associated
+ models (Reduced-Rank VGLMs, Quadratic RR-VGLMs, Reduced-Rank
+ VGAMs). This package fits many models and distributions by
+ maximum likelihood estimation (MLE) or penalized MLE. Also fits
+ constrained ordination models in ecology such as constrained
+ quadratic ordination (CQO).
}
\details{
@@ -67,14 +66,21 @@ will not be finished for a while.
}
\author{
-Thomas W. Yee <t.yee at auckland.ac.nz>
+Thomas W. Yee, \email{t.yee at auckland.ac.nz}.
-Maintainer: Thomas Yee <t.yee at auckland.ac.nz>
+
+Maintainer: Thomas Yee \email{t.yee at auckland.ac.nz}.
}
\references{
+Yee, T. W.
+Vector Generalized Linear and Additive Models.
+\emph{Monograph in preparation}.
+
+
+
Yee, T. W. (2010)
The \pkg{VGAM} package for categorical data analysis.
\emph{Journal of Statistical Software},
@@ -127,8 +133,12 @@ contains further information and examples.
\keyword{models}
\keyword{regression}
\seealso{
- \code{\link{TypicalVGAMfamilyFunction}},
- \code{\link{CommonVGAMffArguments}}.
+ \code{\link{vglm}},
+ \code{\link{vgam}},
+ \code{\link{rrvglm}},
+ \code{\link{TypicalVGAMfamilyFunction}},
+ \code{\link{CommonVGAMffArguments}}.
+
%~~ Optional links to other man pages, e.g. ~~
%~~ \code{\link[<pkg>:<pkg>-package]{<pkg>}} ~~
@@ -137,7 +147,8 @@ contains further information and examples.
# Example 1; proportional odds model
pneumo = transform(pneumo, let = log(exposure.time))
(fit = vglm(cbind(normal, mild, severe) ~ let, propodds, pneumo))
-fit at y # Sample proportions
+fit at y # Sample proportions
+depvar(fit) # Better than using fit at y; dependent variable (response)
weights(fit, type = "prior") # Number of observations
coef(fit, matrix = TRUE) # p.179, in McCullagh and Nelder (1989)
constraints(fit) # Constraint matrices
@@ -146,8 +157,8 @@ summary(fit)
# Example 2; zero-inflated Poisson model
zipdat = data.frame(x = runif(nn <- 2000))
-zipdat = transform(zipdat, phi = logit(-0.5 + 1*x, inverse=TRUE),
- lambda = loge( 0.5 + 2*x, inverse=TRUE))
+zipdat = transform(zipdat, phi = logit(-0.5 + 1*x, inverse = TRUE),
+ lambda = loge( 0.5 + 2*x, inverse = TRUE))
zipdat = transform(zipdat, y = rzipois(nn, lambda, phi))
with(zipdat, table(y))
fit = vglm(y ~ x, zipoisson, zipdat, trace = TRUE)
@@ -155,46 +166,46 @@ coef(fit, matrix = TRUE) # These should agree with the above values
# Example 3; fit a two species GAM simultaneously
-fit2 = vgam(cbind(agaaus, kniexc) ~ s(altitude, df = c(2,3)),
+fit2 = vgam(cbind(agaaus, kniexc) ~ s(altitude, df = c(2, 3)),
binomialff(mv = TRUE), hunua)
coef(fit2, matrix = TRUE) # Not really interpretable
-\dontrun{
-plot(fit2, se = TRUE, overlay = TRUE, lcol = 1:2, scol = 1:2)
+\dontrun{ plot(fit2, se = TRUE, overlay = TRUE, lcol = 1:2, scol = 1:2)
ooo = with(hunua, order(altitude))
with(hunua, matplot(altitude[ooo], fitted(fit2)[ooo,], type = "l", lwd = 2,
xlab = "Altitude (m)", ylab = "Probability of presence", las = 1,
- main = "Two plant species' response curves", ylim = c(0,.8)))
+ main = "Two plant species' response curves", ylim = c(0, 0.8)))
with(hunua, rug(altitude)) }
# Example 4; LMS quantile regression
-fit = vgam(BMI ~ s(age, df=c(4,2)), lms.bcn(zero=1), dat=bminz, trac=TRUE)
+fit = vgam(BMI ~ s(age, df = c(4, 2)), lms.bcn(zero = 1), dat = bminz,
+ trace = TRUE)
head(predict(fit))
head(fitted(fit))
head(bminz) # Person 1 is near the lower quartile among people his age
head(cdf(fit))
-\dontrun{
-par(mfrow=c(1,1), bty="l", mar=c(5,4,4,3)+0.1, xpd=TRUE)
-qtplot(fit, percentiles=c(5,50,90,99), main="Quantiles",
- xlim=c(15,90), las=1, ylab="BMI", lwd=2, lcol=4) # Quantile plot
+\dontrun{ par(mfrow = c(1, 1), bty = "l", mar = c(5,4,4,3)+0.1, xpd = TRUE)
+qtplot(fit, percentiles = c(5,50,90,99), main = "Quantiles", las = 1,
+ xlim = c(15, 90), ylab = "BMI", lwd = 2, lcol = 4) # Quantile plot
-ygrid = seq(15, 43, len=100) # BMI ranges
-par(mfrow=c(1,1), lwd=2) # Density plot
-aa = deplot(fit, x0=20, y=ygrid, xlab="BMI", col="black",
- main="Density functions at Age = 20 (black), 42 (red) and 55 (blue)")
+ygrid = seq(15, 43, len = 100) # BMI ranges
+par(mfrow = c(1, 1), lwd = 2) # Density plot
+aa = deplot(fit, x0 = 20, y = ygrid, xlab = "BMI", col = "black",
+ main = "Density functions at Age = 20 (black), 42 (red) and 55 (blue)")
aa
-aa = deplot(fit, x0=42, y=ygrid, add=TRUE, llty=2, col="red")
-aa = deplot(fit, x0=55, y=ygrid, add=TRUE, llty=4, col="blue", Attach=TRUE)
+aa = deplot(fit, x0 = 42, y = ygrid, add = TRUE, llty = 2, col = "red")
+aa = deplot(fit, x0 = 55, y = ygrid, add = TRUE, llty = 4, col = "blue",
+ Attach = TRUE)
aa at post$deplot # Contains density function values
}
# Example 5; GEV distribution for extremes
-(fit = vglm(maxtemp ~ 1, egev, data=oxtemp, trace=TRUE))
+(fit = vglm(maxtemp ~ 1, egev, data = oxtemp, trace = TRUE))
head(fitted(fit))
-coef(fit, mat = TRUE)
+coef(fit, matrix = TRUE)
Coef(fit)
vcov(fit)
vcov(fit, untransform = TRUE)
diff --git a/man/alaplaceUC.Rd b/man/alaplaceUC.Rd
index f646c41..6061f22 100644
--- a/man/alaplaceUC.Rd
+++ b/man/alaplaceUC.Rd
@@ -26,13 +26,16 @@ ralap(n, location = 0, scale = 1, tau = 0.5, kappa = sqrt(tau/(1-tau)))
\item{n}{
number of observations.
If \code{length(n) > 1} then the length is taken to be the number required.
+
}
\item{location}{
the location parameter \eqn{\xi}{xi}.
+
}
\item{scale}{
the scale parameter \eqn{\sigma}{sigma}.
Must consist of positive values.
+
}
\item{tau}{
the quantile parameter \eqn{\tau}{tau}.
@@ -44,9 +47,11 @@ ralap(n, location = 0, scale = 1, tau = 0.5, kappa = sqrt(tau/(1-tau)))
\item{kappa}{
the asymmetry parameter \eqn{\kappa}{kappa}.
Must consist of positive values.
+
}
\item{log}{
if \code{TRUE}, probabilities \code{p} are given as \code{log(p)}.
+
}
}
@@ -57,20 +62,25 @@ ralap(n, location = 0, scale = 1, tau = 0.5, kappa = sqrt(tau/(1-tau)))
for estimating the three parameters by maximum likelihood estimation,
for formulae and details.
+
}
\value{
\code{dalap} gives the density,
\code{palap} gives the distribution function,
\code{qalap} gives the quantile function, and
\code{ralap} generates random deviates.
+
+
}
\references{
+
Kotz, S., Kozubowski, T. J. and Podgorski, K. (2001)
\emph{The Laplace distribution and generalizations:
a revisit with applications to communications,
economics, engineering, and finance},
Boston: Birkhauser.
+
}
\author{ T. W. Yee }
%\note{
@@ -82,6 +92,8 @@ Boston: Birkhauser.
\code{\link{alaplace3}}.
% \code{\link{dloglap}}.
+
+
}
\examples{
x <- seq(-5, 5, by = 0.01)
@@ -96,8 +108,10 @@ lines(qalap(seq(0.05, 0.95, by = 0.05), loc, sigma, kappa = kappa),
loc, sigma, kappa = kappa), col = "purple", lty = 3, type = "h")
lines(x, palap(x, loc, sigma, kappa = kappa), type = "l", col = "red")
abline(h = 0, lty = 2) }
-palap(qalap(seq(0.05, 0.95, by = 0.05), loc, sigma, kappa = kappa),
- loc, sigma, kappa = kappa)
+
+pp = seq(0.05, 0.95, by = 0.05) # Test two functions
+max(abs(palap(qalap(pp, loc, sigma, kappa = kappa),
+ loc, sigma, kappa = kappa) - pp)) # Should be 0
}
\keyword{distribution}
diff --git a/man/amlexponential.Rd b/man/amlexponential.Rd
index 894f644..49ebd6b 100644
--- a/man/amlexponential.Rd
+++ b/man/amlexponential.Rd
@@ -60,20 +60,24 @@ amlexponential(w.aml = 1, parallel = FALSE, imethod = 1, digw = 4,
the \code{weights} argument (so that it can contain frequencies).
Newton-Raphson estimation is used here.
+
}
\value{
An object of class \code{"vglmff"} (see \code{\link{vglmff-class}}).
The object is used by modelling functions such as \code{\link{vglm}}
and \code{\link{vgam}}.
+
}
\references{
+
Efron, B. (1992)
Poisson overdispersion estimates based on the method of
asymmetric maximum likelihood.
\emph{Journal of the American Statistical Association},
\bold{87}, 98--107.
+
}
\author{ Thomas W. Yee }
@@ -101,15 +105,18 @@ amlexponential(w.aml = 1, parallel = FALSE, imethod = 1, digw = 4,
}
\section{Warning }{
+
Note that the \code{link} argument of \code{\link{exponential}} and
\code{\link{amlexponential}} are currently different: one is the
rate parameter and the other is the mean (expectile) parameter.
+
If \code{w.aml} has more than one value then the value returned by
\code{deviance} is the sum of all the (weighted) deviances taken over
all the \code{w.aml} values.
See Equation (1.6) of Efron (1992).
+
}
\seealso{
\code{\link{exponential}},
@@ -120,36 +127,35 @@ amlexponential(w.aml = 1, parallel = FALSE, imethod = 1, digw = 4,
\code{\link{lms.bcg}},
\code{\link{deexp}}.
+
}
\examples{
nn = 2000
-mydat = data.frame(x = seq(0, 1, length=nn))
-mydat = transform(mydat, mu = loge(-0+1.5*x+0.2*x^2, inverse=TRUE))
-mydat = transform(mydat, mu = loge(0-sin(8*x), inverse=TRUE))
-mydat = transform(mydat, y = rexp(nn, rate=1/mu))
-(fit = vgam(y ~ s(x,df=5), amlexponential(w=c(0.001,0.1,0.5,5,60)),
- mydat, trace=TRUE))
+mydat = data.frame(x = seq(0, 1, length = nn))
+mydat = transform(mydat, mu = loge(-0+1.5*x+0.2*x^2, inverse = TRUE))
+mydat = transform(mydat, mu = loge(0-sin(8*x), inverse = TRUE))
+mydat = transform(mydat, y = rexp(nn, rate = 1/mu))
+(fit = vgam(y ~ s(x,df = 5), amlexponential(w = c(0.001,0.1,0.5,5,60)),
+ mydat, trace = TRUE))
fit at extra
-\dontrun{
-# These plots are against the sqrt scale (to increase clarity)
-par(mfrow=c(1,2))
+\dontrun{ # These plots are against the sqrt scale (to increase clarity)
+par(mfrow = c(1,2))
# Quantile plot
-with(mydat, plot(x, sqrt(y), col="blue", las=1, main=
- paste(paste(round(fit at extra$percentile, dig=1), collapse=", "),
+with(mydat, plot(x, sqrt(y), col = "blue", las = 1, main =
+ paste(paste(round(fit at extra$percentile, dig = 1), collapse = ", "),
"percentile-expectile curves")))
-with(mydat, matlines(x, sqrt(fitted(fit)), lwd=2, col="blue", lty=1))
+with(mydat, matlines(x, sqrt(fitted(fit)), lwd = 2, col = "blue", lty = 1))
# Compare the fitted expectiles with the quantiles
-with(mydat, plot(x, sqrt(y), col="blue", las=1, main=
- paste(paste(round(fit at extra$percentile, dig=1), collapse=", "),
- "percentile curves are red")))
-with(mydat, matlines(x, sqrt(fitted(fit)), lwd=2, col="blue", lty=1))
+with(mydat, plot(x, sqrt(y), col = "blue", las = 1, main =
+ paste(paste(round(fit at extra$percentile, dig = 1), collapse = ", "),
+ "percentile curves are orange")))
+with(mydat, matlines(x, sqrt(fitted(fit)), lwd = 2, col = "blue", lty = 1))
for(ii in fit at extra$percentile)
- with(mydat, matlines(x, sqrt(qexp(p=ii/100, rate=1/mu)), col="red"))
-}
+ with(mydat, matlines(x, sqrt(qexp(p = ii/100, rate = 1/mu)), col = "orange")) }
}
\keyword{models}
\keyword{regression}
diff --git a/man/beta.ab.Rd b/man/beta.ab.Rd
index ac3b590..12eb466 100644
--- a/man/beta.ab.Rd
+++ b/man/beta.ab.Rd
@@ -126,7 +126,7 @@ beta.ab(lshape1 = "loge", lshape2 = "loge",
\code{\link[stats:Beta]{Beta}},
\code{\link{genbetaII}},
\code{\link{betaII}},
- \code{\link{betabin.ab}},
+ \code{\link{betabinomial.ab}},
\code{\link{betageometric}},
\code{\link{betaprime}},
\code{\link{rbetageom}},
diff --git a/man/betaII.Rd b/man/betaII.Rd
index af108cd..43d3d6f 100644
--- a/man/betaII.Rd
+++ b/man/betaII.Rd
@@ -74,6 +74,7 @@ Hoboken, NJ: Wiley-Interscience.
the initial value arguments, especially those whose default value
is not \code{NULL}.
+
}
\seealso{
@@ -86,6 +87,7 @@ Hoboken, NJ: Wiley-Interscience.
\code{\link{lomax}},
\code{\link{paralogistic}},
\code{\link{invparalogistic}}.
+
}
\examples{
diff --git a/man/betabinUC.Rd b/man/betabinomUC.Rd
similarity index 55%
rename from man/betabinUC.Rd
rename to man/betabinomUC.Rd
index ece7921..9c8de53 100644
--- a/man/betabinUC.Rd
+++ b/man/betabinomUC.Rd
@@ -1,13 +1,13 @@
-\name{Betabin}
-\alias{Betabin}
-\alias{dbetabin}
-\alias{pbetabin}
-%\alias{qbetabin}
-\alias{rbetabin}
-\alias{dbetabin.ab}
-\alias{pbetabin.ab}
-%\alias{qbetabin.ab}
-\alias{rbetabin.ab}
+\name{Betabinom}
+\alias{Betabinom}
+\alias{dbetabinom}
+\alias{pbetabinom}
+%\alias{qbetabinom}
+\alias{rbetabinom}
+\alias{dbetabinom.ab}
+\alias{pbetabinom.ab}
+%\alias{qbetabinom.ab}
+\alias{rbetabinom.ab}
\title{The Beta-Binomial Distribution}
\description{
Density, distribution function, and random
@@ -15,12 +15,12 @@
}
\usage{
-dbetabin(x, size, prob, rho, log = FALSE)
-pbetabin(q, size, prob, rho, log.p = FALSE)
-rbetabin(n, size, prob, rho)
-dbetabin.ab(x, size, shape1, shape2, log = FALSE)
-pbetabin.ab(q, size, shape1, shape2, log.p = FALSE)
-rbetabin.ab(n, size, shape1, shape2)
+dbetabinom(x, size, prob, rho = 0, log = FALSE)
+pbetabinom(q, size, prob, rho, log.p = FALSE)
+rbetabinom(n, size, prob, rho = 0)
+dbetabinom.ab(x, size, shape1, shape2, log = FALSE, .dontuse.prob = NULL)
+pbetabinom.ab(q, size, shape1, shape2, log.p = FALSE)
+rbetabinom.ab(n, size, shape1, shape2, .dontuse.prob = NULL)
}
\arguments{
\item{x, q}{vector of quantiles.}
@@ -30,12 +30,14 @@ rbetabin.ab(n, size, shape1, shape2)
Must be a positive integer of length 1.}
\item{prob}{
the probability of success \eqn{\mu}{mu}.
- Must be in the unit open interval \eqn{(0,1)}.
+ Must be in the unit closed interval \eqn{[0,1]}.
}
\item{rho}{
the correlation parameter \eqn{\rho}{rho}.
- Must be in the unit open interval \eqn{(0,1)}.
+ Usually must be in the unit open interval \eqn{(0,1)},
+ however, the value 0 is sometimes supported
+ (if so then it corresponds to the usual binomial distribution).
}
\item{shape1, shape2}{
@@ -49,12 +51,20 @@ rbetabin.ab(n, size, shape1, shape2)
If \code{TRUE} then all probabilities \code{p} are given as \code{log(p)}.
}
+
+ \item{.dontuse.prob}{
+ An argument that should be ignored and unused.
+
+ }
+
+
}
\value{
- \code{dbetabin} and \code{dbetabin.ab} give the density,
- \code{pbetabin} and \code{pbetabin.ab} give the distribution function, and
-% \code{qbetabin} and \code{qbetabin.ab} gives the quantile function, and
- \code{rbetabin} and \code{rbetabin.ab} generate random deviates.
+ \code{dbetabinom} and \code{dbetabinom.ab} give the density,
+ \code{pbetabinom} and \code{pbetabinom.ab} give the distribution function, and
+% \code{qbetabinom} and \code{qbetabinom.ab} gives the quantile function, and
+ \code{rbetabinom} and \code{rbetabinom.ab} generate random deviates.
+
}
\author{ T. W. Yee }
@@ -66,14 +76,16 @@ rbetabin.ab(n, size, shape1, shape2)
\code{mu = shape1/(shape1+shape2)}, which therefore is the
mean or the probability of success.
- See \code{\link{betabinomial}} and \code{\link{betabin.ab}},
+
+ See \code{\link{betabinomial}} and \code{\link{betabinomial.ab}},
the \pkg{VGAM} family functions for
estimating the parameters, for the formula of the probability density
function and other details.
+
}
\note{
- \code{pbetabin} and \code{pbetabin.ab} can be particularly slow.
+ \code{pbetabinom} and \code{pbetabinom.ab} can be particularly slow.
The functions here ending in \code{.ab} are called from those
functions which don't.
The simple transformations
@@ -82,36 +94,41 @@ rbetabin.ab(n, size, shape1, shape2)
where \eqn{\alpha}{alpha} and \eqn{\beta}{beta} are the two
shape parameters.
+
}
\seealso{
\code{\link{betabinomial}},
- \code{\link{betabin.ab}}.
+ \code{\link{betabinomial.ab}}.
+
}
\examples{
-\dontrun{
-N = 9; xx = 0:N; s1 = 2; s2 = 3
-dy = dbetabin.ab(xx, size = N, shape1 = s1, shape2 = s2)
-barplot(rbind(dy, dbinom(xx, size = N, prob = s1/(s1+s2))),
+set.seed(1)
+rbetabinom(10, 100, prob = 0.5)
+set.seed(1)
+rbinom(10, 100, prob = 0.5) # The same since rho = 0
+
+\dontrun{ N = 9; xx = 0:N; s1 = 2; s2 = 3
+dy = dbetabinom.ab(xx, size = N, shape1 = s1, shape2 = s2)
+barplot(rbind(dy, dbinom(xx, size = N, prob = s1 / (s1+s2))),
beside = TRUE, col = c("blue","green"), las = 1,
main = paste("Beta-binomial (size=",N,", shape1=",s1,
", shape2=",s2,") (blue) vs\n",
- " Binomial(size=", N, ", prob=", s1/(s1+s2), ") (green)", sep = ""),
+ " Binomial(size=", N, ", prob=", s1 / (s1+s2), ") (green)", sep = ""),
names.arg = as.character(xx), cex.main = 0.8)
sum(dy*xx) # Check expected values are equal
-sum(dbinom(xx, size = N, prob = s1/(s1+s2))*xx)
-cumsum(dy) - pbetabin.ab(xx, N, shape1 = s1, shape2 = s2)
+sum(dbinom(xx, size = N, prob = s1 / (s1+s2))*xx)
+cumsum(dy) - pbetabinom.ab(xx, N, shape1 = s1, shape2 = s2)
-y = rbetabin.ab(n = 10000, size = N, shape1 = s1, shape2 = s2)
+y = rbetabinom.ab(n = 10000, size = N, shape1 = s1, shape2 = s2)
ty = table(y)
-barplot(rbind(dy, ty/sum(ty)),
+barplot(rbind(dy, ty / sum(ty)),
beside = TRUE, col = c("blue","red"), las = 1,
main = paste("Beta-binomial (size=",N,", shape1=",s1,
", shape2=",s2,") (blue) vs\n",
" Random generated beta-binomial(size=", N, ", prob=", s1/(s1+s2),
") (red)", sep = ""), cex.main = 0.8,
- names.arg = as.character(xx))
-}
+ names.arg = as.character(xx)) }
}
\keyword{distribution}
diff --git a/man/betabinomial.Rd b/man/betabinomial.Rd
index ece5ee7..1a9426f 100644
--- a/man/betabinomial.Rd
+++ b/man/betabinomial.Rd
@@ -124,6 +124,7 @@ betabinomial(lmu = "logit", lrho = "logit", emu = list(), erho = list(),
\code{weights(fit, type="prior")} returns the number
of trials \eqn{N}.
+
}
\references{
Moore, D. F. and Tsiatis, A. (1991)
@@ -163,6 +164,7 @@ betabinomial(lmu = "logit", lrho = "logit", emu = list(), erho = list(),
}
\section{Warning }{
+
If the estimated rho parameter is close to zero then it pays to try
\code{lrho = "rhobit"}. One day this may become the default link function.
@@ -177,8 +179,8 @@ betabinomial(lmu = "logit", lrho = "logit", emu = list(), erho = list(),
}
\seealso{
- \code{\link{betabin.ab}},
- \code{\link{Betabin}},
+ \code{\link{betabinomial.ab}},
+ \code{\link{Betabinom}},
\code{\link{binomialff}},
\code{\link{betaff}},
\code{\link{dirmultinomial}},
@@ -188,10 +190,10 @@ betabinomial(lmu = "logit", lrho = "logit", emu = list(), erho = list(),
}
\examples{
# Example 1
-bbdat = data.frame(N = 10, mu = 0.5, rho = 0.8)
-bbdat = transform(bbdat,
- y = rbetabin(n=100, size = N, prob = mu, rho = rho))
-fit = vglm(cbind(y, N-y) ~ 1, betabinomial, bbdat, trace = TRUE)
+bdata = data.frame(N = 10, mu = 0.5, rho = 0.8)
+bdata = transform(bdata,
+ y = rbetabinom(n=100, size = N, prob = mu, rho = rho))
+fit = vglm(cbind(y, N-y) ~ 1, betabinomial, bdata, trace = TRUE)
coef(fit, matrix = TRUE)
Coef(fit)
head(cbind(fit at y, weights(fit, type = "prior")))
@@ -213,14 +215,14 @@ summary(lirat) # Only 5 litters in group 3
fit2 = vglm(cbind(R, N-R) ~ fgrp + hb, betabinomial(zero = 2),
data = lirat, trace = TRUE, subset = N > 1)
coef(fit2, matrix = TRUE)
-\dontrun{ with(lirat, plot(hb[N>1], fit2 at misc$rho,
+\dontrun{ with(lirat, plot(hb[N > 1], fit2 at misc$rho,
xlab = "Hemoglobin", ylab = "Estimated rho",
- pch = as.character(grp[N>1]), col = grp[N>1])) }
+ pch = as.character(grp[N > 1]), col = grp[N > 1])) }
\dontrun{ # cf. Figure 3 of Moore and Tsiatis (1991)
-with(lirat, plot(hb, R/N, pch = as.character(grp), col = grp, las = 1,
+with(lirat, plot(hb, R / N, pch = as.character(grp), col = grp, las = 1,
xlab = "Hemoglobin level", ylab = "Proportion Dead",
main = "Fitted values (lines)"))
-smalldf = with(lirat, lirat[N>1,])
+smalldf = with(lirat, lirat[N > 1, ])
for(gp in 1:4) {
xx = with(smalldf, hb[grp == gp])
yy = with(smalldf, fitted(fit2)[grp == gp])
diff --git a/man/betabin.ab.Rd b/man/betabinomial.ab.Rd
similarity index 89%
rename from man/betabin.ab.Rd
rename to man/betabinomial.ab.Rd
index 5e2fcf1..57de43b 100644
--- a/man/betabin.ab.Rd
+++ b/man/betabinomial.ab.Rd
@@ -1,5 +1,5 @@
-\name{betabin.ab}
-\alias{betabin.ab}
+\name{betabinomial.ab}
+\alias{betabinomial.ab}
%- Also NEED an '\alias' for EACH other topic documented here.
\title{ Beta-binomial Distribution Family Function }
\description{
@@ -9,8 +9,9 @@
}
\usage{
-betabin.ab(lshape12 = "loge", earg = list(), i1 = 1, i2 = NULL,
- imethod = 1, shrinkage.init = 0.95, nsimEIM = NULL, zero = NULL)
+betabinomial.ab(lshape12 = "loge", earg = list(), i1 = 1, i2 = NULL,
+ imethod = 1, shrinkage.init = 0.95, nsimEIM = NULL,
+ zero = NULL)
}
%- maybe also 'usage' for other objects documented here.
\arguments{
@@ -175,18 +176,19 @@ betabin.ab(lshape12 = "loge", earg = list(), i1 = 1, i2 = NULL,
}
\seealso{
\code{\link{betabinomial}},
- \code{\link{Betabin}},
+ \code{\link{Betabinom}},
\code{\link{binomialff}},
\code{\link{betaff}},
\code{\link{dirmultinomial}},
\code{\link{lirat}}.
+
}
\examples{
# Example 1
N = 10; s1 = exp(1); s2 = exp(2)
-y = rbetabin.ab(n = 100, size = N, shape1 = s1, shape2 = s2)
-fit = vglm(cbind(y, N-y) ~ 1, betabin.ab, trace = TRUE)
+y = rbetabinom.ab(n = 100, size = N, shape1 = s1, shape2 = s2)
+fit = vglm(cbind(y, N-y) ~ 1, betabinomial.ab, trace = TRUE)
coef(fit, matrix = TRUE)
Coef(fit)
head(fit at misc$rho) # The correlation parameter
@@ -194,7 +196,7 @@ head(cbind(fit at y, weights(fit, type = "prior")))
# Example 2
-fit = vglm(cbind(R, N-R) ~ 1, betabin.ab, data = lirat,
+fit = vglm(cbind(R, N-R) ~ 1, betabinomial.ab, data = lirat,
trace = TRUE, subset = N > 1)
coef(fit, matrix = TRUE)
Coef(fit)
@@ -204,27 +206,27 @@ t(fit at y)
t(weights(fit, type = "prior"))
# A "loge" link for the 2 shape parameters is a logistic regression:
all.equal(c(fitted(fit)),
- c(logit(predict(fit)[, 1] - predict(fit)[, 2], inverse = TRUE)))
+ as.vector(logit(predict(fit)[, 1] -
+ predict(fit)[, 2], inverse = TRUE)))
# Example 3, which is more complicated
lirat = transform(lirat, fgrp = factor(grp))
summary(lirat) # Only 5 litters in group 3
-fit2 = vglm(cbind(R, N-R) ~ fgrp + hb, betabin.ab(zero = 2),
+fit2 = vglm(cbind(R, N-R) ~ fgrp + hb, betabinomial.ab(zero = 2),
data = lirat, trace = TRUE, subset = N > 1)
coef(fit2, matrix = TRUE)
-Coef(fit2)
-coef(fit2, matrix = TRUE)[, 1] - coef(fit2, matrix = TRUE)[, 2] # logit(p)
-\dontrun{ with(lirat, plot(hb[N>1], fit2 at misc$rho,
+coef(fit2, matrix = TRUE)[, 1] -
+coef(fit2, matrix = TRUE)[, 2] # logit(p)
+\dontrun{ with(lirat, plot(hb[N > 1], fit2 at misc$rho,
xlab = "Hemoglobin", ylab = "Estimated rho",
- pch = as.character(grp[N>1]), col = grp[N>1]))
-}
+ pch = as.character(grp[N > 1]), col = grp[N > 1])) }
\dontrun{ # cf. Figure 3 of Moore and Tsiatis (1991)
-with(lirat, plot(hb, R/N, pch = as.character(grp), col = grp, las = 1,
+with(lirat, plot(hb, R / N, pch = as.character(grp), col = grp, las = 1,
xlab = "Hemoglobin level", ylab = "Proportion Dead",
main = "Fitted values (lines)"))
-smalldf = with(lirat, lirat[N>1,])
+smalldf = with(lirat, lirat[N > 1, ])
for(gp in 1:4) {
xx = with(smalldf, hb[grp == gp])
yy = with(smalldf, fitted(fit2)[grp == gp])
diff --git a/man/betaff.Rd b/man/betaff.Rd
index a5ffa49..8b04748 100644
--- a/man/betaff.Rd
+++ b/man/betaff.Rd
@@ -105,7 +105,7 @@ betaff(A = 0, B = 1,
\code{\link[stats:Beta]{Beta}},
\code{\link{genbetaII}},
\code{\link{betaII}},
- \code{\link{betabin.ab}},
+ \code{\link{betabinomial.ab}},
\code{\link{betageometric}},
\code{\link{betaprime}},
\code{\link{rbetageom}},
diff --git a/man/betageomUC.Rd b/man/betageomUC.Rd
index 879c601..7095511 100644
--- a/man/betageomUC.Rd
+++ b/man/betageomUC.Rd
@@ -11,8 +11,8 @@
}
\usage{
-dbetageom(x, shape1, shape2, log=FALSE)
-pbetageom(q, shape1, shape2, log.p=FALSE)
+dbetageom(x, shape1, shape2, log = FALSE)
+pbetageom(q, shape1, shape2, log.p = FALSE)
rbetageom(n, shape1, shape2)
}
\arguments{
@@ -55,18 +55,20 @@ rbetageom(n, shape1, shape2)
}
\note{
\code{pbetageom} can be particularly slow.
+
}
\seealso{
\code{\link{geometric}},
\code{\link{betaff}},
\code{\link[stats:Beta]{Beta}}.
+
}
\examples{
\dontrun{
shape1 = 1; shape2 = 2; y = 0:30
-proby = dbetageom(y, shape1, shape2, log=FALSE)
-plot(y, proby, type="h", col="blue", ylab="P[Y=y]", main=paste(
- "Y ~ Beta-geometric(shape1=",shape1,", shape2=",shape2,")", sep=""))
+proby = dbetageom(y, shape1, shape2, log = FALSE)
+plot(y, proby, type = "h", col = "blue", ylab = "P[Y=y]", main = paste(
+ "Y ~ Beta-geometric(shape1=", shape1,", shape2=", shape2,")", sep=""))
sum(proby)
}
}
diff --git a/man/betageometric.Rd b/man/betageometric.Rd
index 9e3d37f..8ecd244 100644
--- a/man/betageometric.Rd
+++ b/man/betageometric.Rd
@@ -111,18 +111,19 @@ betageometric(lprob = "logit", lshape = "loge",
\code{\link{betaff}},
\code{\link{rbetageom}}.
+
}
\examples{
bg.data = data.frame(y = 0:11, wts = c(227,123,72,42,21,31,11,14,6,4,7,28))
-fit = vglm(y ~ 1, fam=betageometric, bg.data, weight=wts, trace=TRUE)
-fitg = vglm(y ~ 1, fam= geometric, bg.data, weight=wts, trace=TRUE)
-coef(fit, matrix=TRUE)
+fit = vglm(y ~ 1, betageometric, bg.data, weight = wts, trace = TRUE)
+fitg = vglm(y ~ 1, geometric, bg.data, weight = wts, trace = TRUE)
+coef(fit, matrix = TRUE)
Coef(fit)
-diag(vcov(fit, untrans=TRUE))^0.5
+sqrt(diag(vcov(fit, untransform = TRUE)))
fit at misc$shape1
fit at misc$shape2
# Very strong evidence of a beta-geometric:
-pchisq(2*(logLik(fit)-logLik(fitg)), df=1, lower.tail=FALSE)
+pchisq(2*(logLik(fit) - logLik(fitg)), df = 1, lower.tail = FALSE)
}
\keyword{models}
\keyword{regression}
diff --git a/man/binom2.rho.Rd b/man/binom2.rho.Rd
index 1a47112..cf2e4ae 100644
--- a/man/binom2.rho.Rd
+++ b/man/binom2.rho.Rd
@@ -79,7 +79,7 @@ binom2.Rho(rho = 0, imu1 = NULL, imu2 = NULL,
Explicitly, the default model is
\deqn{probit[P(Y_j=1)] = \eta_j,\ \ \ j=1,2}{%
- probit[P(Y_j=1)] = eta_j,\ \ \ j=1,2}
+ probit[P(Y_j=1)] = eta_j, j=1,2}
for the marginals, and
\deqn{rhobit[rho] = \eta_3.}{%
rhobit[rho] = eta_3.}
diff --git a/man/binomialff.Rd b/man/binomialff.Rd
index 0768160..b34eda7 100644
--- a/man/binomialff.Rd
+++ b/man/binomialff.Rd
@@ -21,6 +21,7 @@ binomialff(link = "logit", earg = list(), dispersion = 1, mv = FALSE,
See \code{\link{Links}} for more choices, and also
\code{\link{CommonVGAMffArguments}} for more information.
+
}
\item{dispersion}{
Dispersion parameter. By default, maximum likelihood is used to
@@ -28,6 +29,7 @@ binomialff(link = "logit", earg = list(), dispersion = 1, mv = FALSE,
\code{dispersion = 0} to have it estimated, or else specify a known
positive value (or values if \code{mv} is \code{TRUE}).
+
}
\item{mv}{
Multivariate response? If \code{TRUE}, then the response is interpreted
@@ -35,17 +37,20 @@ binomialff(link = "logit", earg = list(), dispersion = 1, mv = FALSE,
of columns of the response matrix. In this case, the response matrix
should have zero/one values only.
+
If \code{FALSE} and the response is a (2-column) matrix, then the number
of successes is given in the first column, and the second column is
the number of failures.
+
}
\item{onedpar}{
One dispersion parameter? If \code{mv}, then a separate dispersion
parameter will be computed for each response (column), by default.
- Setting \code{onedpar=TRUE} will pool them so that there is only one
+ Setting \code{onedpar = TRUE} will pool them so that there is only one
dispersion parameter to be estimated.
+
}
\item{parallel}{
A logical or formula. Used only if \code{mv} is \code{TRUE}. This
@@ -53,6 +58,7 @@ binomialff(link = "logit", earg = list(), dispersion = 1, mv = FALSE,
coefficients for a variable is constrained to be equal over the \eqn{M}
linear/additive predictors.
+
}
\item{zero}{
An integer-valued vector specifying which linear/additive predictors
@@ -60,6 +66,7 @@ binomialff(link = "logit", earg = list(), dispersion = 1, mv = FALSE,
\{1,2,\ldots,\eqn{M}\}, where \eqn{M} is the number of columns of the
matrix response.
+
}
}
\details{
@@ -97,19 +104,23 @@ binomialff(link = "logit", earg = list(), dispersion = 1, mv = FALSE,
\code{\link{cqo}},
and \code{\link{cao}}.
+
}
\references{
McCullagh, P. and Nelder, J. A. (1989)
\emph{Generalized Linear Models}, 2nd ed. London: Chapman & Hall.
+
Altman, M. and Gill, J. and McDonald, M. P. (2004)
\emph{Numerical Issues in Statistical Computing for the Social
Scientist}, Hoboken, NJ: Wiley-Interscience.
+
Ridout, M. S. (1990)
Non-convergence of Fisher's method of scoring---a simple example.
\emph{GLIM Newsletter}, 20(6).
+
}
\author{ Thomas W. Yee }
@@ -172,6 +183,7 @@ binomialff(link = "logit", earg = list(), dispersion = 1, mv = FALSE,
\code{\link[stats:Binomial]{binomial}},
\pkg{safeBinaryRegression}.
+
}
\section{Warning }{
With a multivariate response, assigning a known dispersion parameter
@@ -183,7 +195,7 @@ binomialff(link = "logit", earg = list(), dispersion = 1, mv = FALSE,
\emph{completely separable} or \emph{quasi-completely separable}.
See Chapter 10 of Altman et al. (2004) for more details,
and \pkg{safeBinaryRegression}.
- Yet to do: add a \code{sepcheck=TRUE}, say, argument to detect this
+ Yet to do: add a \code{sepcheck = TRUE}, say, argument to detect this
problem and give an appropriate warning.
@@ -193,19 +205,25 @@ binomialff(link = "logit", earg = list(), dispersion = 1, mv = FALSE,
quasibinomialff()
quasibinomialff(link = "probit")
-fit = vgam(agaaus ~ poly(altitude, 2), binomialff(link = cloglog), hunua)
+shunua = hunua[sort.list(with(hunua, altitude)), ] # Sort by altitude
+fit = vglm(agaaus ~ poly(altitude, 2), binomialff(link = cloglog), shunua)
\dontrun{
-with(hunua, plot(altitude, agaaus, col="blue", ylab="P(agaaus=1)",
- main = "Presence/absence of Agathis australis", las = 1))
-ooo = with(hunua, order(altitude))
-with(hunua, lines(altitude[ooo], fitted(fit)[ooo], col="red", lwd = 2)) }
+plot(agaaus ~ jitter(altitude), shunua, col = "blue", ylab = "P(Agaaus = 1)",
+ main = "Presence/absence of Agathis australis", las = 1)
+with(shunua, lines(altitude, fitted(fit), col = "orange", lwd = 2)) }
+
+
+# Fit two species simultaneously
+fit2 = vgam(cbind(agaaus, kniexc) ~ s(altitude), binomialff(mv = TRUE), shunua)
+with(shunua, matplot(altitude, fitted(fit2), type = "l",
+ main = "Two species response curves", las = 1))
# Shows that Fisher scoring can sometime fail. See Ridout (1990).
ridout = data.frame(v = c(1000, 100, 10), r = c(4, 3, 3), n = c(5, 5, 5))
(ridout = transform(ridout, logv = log(v)))
# The iterations oscillates between two local solutions:
-glm.fail = glm(r/n ~ offset(logv) + 1, weight=n,
+glm.fail = glm(r/n ~ offset(logv) + 1, weight = n,
binomial(link = cloglog), ridout, trace = TRUE)
coef(glm.fail)
# vglm()'s half-stepping ensures the MLE of -5.4007 is obtained:
diff --git a/man/borel.tanner.Rd b/man/borel.tanner.Rd
index 0de9076..2a0fc39 100644
--- a/man/borel.tanner.Rd
+++ b/man/borel.tanner.Rd
@@ -8,7 +8,7 @@
}
\usage{
-borel.tanner(Qsize=1, link="logit", earg=list(), imethod=1)
+borel.tanner(Qsize = 1, link = "logit", earg = list(), imethod = 1)
}
%- maybe also 'usage' for other objects documented here.
\arguments{
@@ -67,12 +67,14 @@ borel.tanner(Qsize=1, link="logit", earg=list(), imethod=1)
The object is used by modelling functions such as \code{\link{vglm}}
and \code{\link{vgam}}.
+
}
\references{
Tanner, J. C. (1953)
A problem of interference between two queues.
\emph{Biometrika}, \bold{40}, 58--69.
+
Borel, E. (1942)
Sur l'emploi du theoreme de Bernoulli pour faciliter le
calcul d'une infinite de coefficients.
@@ -80,16 +82,19 @@ Application au probleme de l'attente a un guichet.
\emph{Comptes Rendus, Academie des Sciences, Paris, Series A},
\bold{214}, 452--456.
+
Page 328 of
Johnson N. L., Kemp, A. W. and Kotz S. (2005)
\emph{Univariate Discrete Distributions},
3rd edition,
Hoboken, New Jersey: Wiley.
+
Consul, P. C. and Famoye, F. (2006)
\emph{Lagrangian Probability Distributions},
Boston: Birkhauser.
+
}
\author{ T. W. Yee }
%\note{
@@ -101,11 +106,12 @@ Boston: Birkhauser.
\code{\link{poissonff}},
\code{\link{felix}}.
+
}
\examples{
-bortdata = data.frame(y = rbort(n <- 200))
-fit = vglm(y ~ 1, borel.tanner, bortdata, trace=TRUE, crit="c")
-coef(fit, matrix=TRUE)
+bdata = data.frame(y = rbort(n <- 200))
+fit = vglm(y ~ 1, borel.tanner, bdata, trace = TRUE, crit = "c")
+coef(fit, matrix = TRUE)
Coef(fit)
summary(fit)
}
diff --git a/man/cqo.Rd b/man/cqo.Rd
index 428b031..85d11f3 100644
--- a/man/cqo.Rd
+++ b/man/cqo.Rd
@@ -409,7 +409,7 @@ Constrained additive ordination.
\seealso{
\code{\link{qrrvglm.control}},
\code{\link{Coef.qrrvglm}},
- \code{\link{predict.qrrvglm}},
+ \code{\link{predictqrrvglm}},
\code{\link{rcqo}},
\code{\link{cao}},
\code{\link{uqo}},
@@ -420,7 +420,7 @@ Constrained additive ordination.
\code{\link{negbinomial}},
\code{\link{gamma2}},
\code{\link{lvplot.qrrvglm}},
- \code{\link{persp.qrrvglm}},
+ \code{\link{perspqrrvglm}},
\code{\link{trplot.qrrvglm}},
% \code{\link{vcovqrrvglm}},
\code{\link{vglm}},
diff --git a/man/cumulative.Rd b/man/cumulative.Rd
index e4a3229..f96434d 100644
--- a/man/cumulative.Rd
+++ b/man/cumulative.Rd
@@ -277,7 +277,8 @@ by the \pkg{VGAM} package can be found at
pneumo = transform(pneumo, let = log(exposure.time))
(fit = vglm(cbind(normal, mild, severe) ~ let,
cumulative(parallel = TRUE, reverse = TRUE), pneumo))
-fit at y # Sample proportions
+depvar(fit) # Sample proportions (good technique)
+fit at y # Sample proportions (bad technique)
weights(fit, type = "prior") # Number of observations
coef(fit, matrix = TRUE)
constraints(fit) # Constraint matrices
diff --git a/man/dagum.Rd b/man/dagum.Rd
index 6aee66f..dad463c 100644
--- a/man/dagum.Rd
+++ b/man/dagum.Rd
@@ -8,7 +8,7 @@
}
\usage{
dagum(link.a = "loge", link.scale = "loge", link.p = "loge",
- earg.a=list(), earg.scale=list(), earg.p=list(),
+ earg.a = list(), earg.scale = list(), earg.p = list(),
init.a = NULL, init.scale = NULL, init.p = 1, zero = NULL)
}
%- maybe also 'usage' for other objects documented here.
@@ -68,13 +68,16 @@ provided \eqn{-ap < 1 < a}.
An object of class \code{"vglmff"} (see \code{\link{vglmff-class}}).
The object is used by modelling functions such as \code{\link{vglm}},
and \code{\link{vgam}}.
+
}
\references{
+
Kleiber, C. and Kotz, S. (2003)
\emph{Statistical Size Distributions in Economics and
Actuarial Sciences},
Hoboken, NJ: Wiley-Interscience.
+
}
\author{ T. W. Yee }
@@ -83,12 +86,14 @@ If the self-starting initial values fail, try experimenting
with the initial value arguments, especially those whose
default value is not \code{NULL}.
+
From Kleiber and Kotz (2003), the MLE is rather sensitive to isolated
observations located sufficiently far from the majority of the data.
Reliable estimation of the scale parameter require \eqn{n>7000},
while estimates for \eqn{a} and \eqn{p} can be considered unbiased for
\eqn{n>2000} or 3000.
+
}
\seealso{
@@ -101,13 +106,14 @@ while estimates for \eqn{a} and \eqn{p} can be considered unbiased for
\code{\link{lomax}},
\code{\link{paralogistic}},
\code{\link{invparalogistic}}.
+
}
\examples{
-ddata = data.frame(y = rdagum(n=3000, 4, 6, 2))
-fit = vglm(y ~ 1, dagum, ddata, trace=TRUE)
-fit = vglm(y ~ 1, dagum(init.a=2.1), ddata, trace=TRUE, crit="c")
-coef(fit, mat=TRUE)
+ddata = data.frame(y = rdagum(n = 3000, 4, 6, 2))
+fit = vglm(y ~ 1, dagum, ddata, trace = TRUE)
+fit = vglm(y ~ 1, dagum(init.a = 2.1), ddata, trace = TRUE, crit = "c")
+coef(fit, matrix = TRUE)
Coef(fit)
summary(fit)
}
diff --git a/man/depvar.Rd b/man/depvar.Rd
new file mode 100644
index 0000000..2a7b2f3
--- /dev/null
+++ b/man/depvar.Rd
@@ -0,0 +1,67 @@
+\name{depvar}
+\alias{depvar}
+%- Also NEED an '\alias' for EACH other topic documented here.
+\title{ Response variable extracted }
+\description{
+ A generic function that extracts the response/dependent
+ variable from objects.
+
+}
+\usage{
+depvar(object, ...)
+}
+%- maybe also 'usage' for other objects documented here.
+\arguments{
+\item{object}{
+ An object that has some response/dependent variable.
+
+
+}
+\item{\dots}{
+ Other arguments fed into the specific methods function of
+ the model.
+
+
+}
+}
+\details{
+ This function is preferred to calling \code{fit at y}, say.
+
+
+}
+\value{
+ The response/dependent variable,
+ usually as a matrix or vector.
+
+
+}
+%\references{
+%
+%}
+\author{ Thomas W. Yee }
+
+%\note{
+%}
+
+%\section{Warning }{
+% This
+
+
+%}
+
+\seealso{
+ \code{\link[stats]{model.matrix}},
+ \code{\link{vglm}}.
+
+
+}
+\examples{
+pneumo = transform(pneumo, let = log(exposure.time))
+(fit = vglm(cbind(normal, mild, severe) ~ let, propodds, pneumo))
+fit at y # Sample proportions (not recommended)
+depvar(fit) # Better than using fit at y; dependent variable (response)
+weights(fit, type = "prior") # Number of observations
+}
+\keyword{models}
+\keyword{regression}
+
diff --git a/man/dirmul.old.Rd b/man/dirmul.old.Rd
index dabd972..e876613 100644
--- a/man/dirmul.old.Rd
+++ b/man/dirmul.old.Rd
@@ -125,7 +125,7 @@ contains further information and examples.
\seealso{
\code{\link{dirmultinomial}},
\code{\link{dirichlet}},
- \code{\link{betabin.ab}},
+ \code{\link{betabinomial.ab}},
\code{\link{multinomial}}.
diff --git a/man/dirmultinomial.Rd b/man/dirmultinomial.Rd
index 5e70255..960d0dd 100644
--- a/man/dirmultinomial.Rd
+++ b/man/dirmultinomial.Rd
@@ -172,7 +172,7 @@ Overdispersion in allelic counts and \eqn{\theta}-correction in forensic genetic
\seealso{
\code{\link{dirmul.old}},
\code{\link{betabinomial}},
- \code{\link{betabin.ab}},
+ \code{\link{betabinomial.ab}},
\code{\link{dirichlet}},
\code{\link{multinomial}}.
diff --git a/man/explink.Rd b/man/explink.Rd
new file mode 100644
index 0000000..e48bdcf
--- /dev/null
+++ b/man/explink.Rd
@@ -0,0 +1,115 @@
+\name{explink}
+\alias{explink}
+%- Also NEED an '\alias' for EACH other topic documented here.
+\title{ Exponential Link Function }
+\description{
+ Computes the exponential transformation, including its inverse and the
+ first two derivatives.
+
+}
+\usage{
+explink(theta, earg = list(), inverse = FALSE, deriv = 0, short = TRUE, tag = FALSE)
+}
+%- maybe also 'usage' for other objects documented here.
+\arguments{
+ \item{theta}{
+ Numeric or character.
+ See below for further details.
+
+ }
+ \item{earg}{
+ Optional list.
+ See \code{\link{Links}} for general information about \code{earg}.
+
+ }
+ \item{inverse}{
+ Logical. If \code{TRUE} the inverse function is computed.
+ The inverse function is the \code{\link{loge}} function.
+
+ }
+ \item{deriv}{
+ Order of the derivative. Integer with value 0, 1 or 2.
+
+ }
+ \item{short}{
+ Used for labelling the \code{blurb} slot of a
+ \code{\link{vglmff-class}} object.
+
+ }
+ \item{tag}{
+ Used for labelling the linear/additive predictor in the
+ \code{initialize} slot of a \code{\link{vglmff-class}} object.
+ Contains a little more information if \code{TRUE}.
+
+ }
+}
+\details{
+
+ The exponential link function is potentially suitable for parameters that
+ are positive.
+ Numerical values of \code{theta} close to negative or positive infinity
+ may result in
+ \code{0}, \code{Inf}, \code{-Inf}, \code{NA} or \code{NaN}.
+
+
+ The arguments \code{short} and \code{tag} are used only if
+ \code{theta} is character.
+
+
+
+
+}
+\value{
+ For \code{explink} with \code{deriv = 0}, the exponential of \code{theta}, i.e.,
+ \code{exp(theta)} when \code{inverse = FALSE}.
+ And if \code{inverse = TRUE} then
+ \code{log(theta)};
+ if \code{theta} is not positive then it will return \code{NaN}.
+
+
+ For \code{deriv = 1}, then the function returns
+ \emph{d} \code{theta} / \emph{d} \code{eta} as a function of \code{theta}
+ if \code{inverse = FALSE},
+ else if \code{inverse = TRUE} then it returns the reciprocal.
+
+
+ Here, all logarithms are natural logarithms, i.e., to base \emph{e}.
+
+
+}
+%\references{
+% McCullagh, P. and Nelder, J. A. (1989)
+% \emph{Generalized Linear Models}, 2nd ed. London: Chapman & Hall.
+%
+%}
+\author{ Thomas W. Yee }
+
+\note{
+ This function has particular use for computing quasi-variances when
+ used with \code{\link{rcam}} and \code{\link{normal1}}.
+
+
+ Numerical instability may occur when \code{theta} is
+ close to negative or positive infinity.
+ One way of overcoming this (one day) is to use \code{earg}.
+
+
+}
+
+\seealso{
+ \code{\link{Links}},
+ \code{\link{loge}},
+ \code{\link{rcam}},
+ \code{\link{Qvar}},
+ \code{\link{normal1}}.
+
+}
+\examples{
+theta = rnorm(30)
+explink(theta)
+max(abs(explink(explink(theta), inverse = TRUE) - theta)) # Should be 0
+}
+\keyword{math}
+\keyword{models}
+\keyword{regression}
+
diff --git a/man/finney44.Rd b/man/finney44.Rd
new file mode 100644
index 0000000..4b28897
--- /dev/null
+++ b/man/finney44.Rd
@@ -0,0 +1,53 @@
+\name{finney44}
+\alias{finney44}
+\docType{data}
+\title{ Toxicity trial for insects
+%% ~~ data name/kind ... ~~
+}
+\description{
+ A data frame of a toxicity trial.
+
+%% ~~ A concise (1-5 lines) description of the dataset. ~~
+}
+\usage{data(finney44)}
+\format{
+ A data frame with 6 observations on the following 3 variables.
+ \describe{
+ \item{\code{pconc}}{a numeric vector, percent concentration
+of pyrethrins. }
+ \item{\code{hatched}}{number of eggs that hatched. }
+ \item{\code{unhatched}}{number of eggs that did not hatch. }
+ }
+}
+\details{
+
+Finney (1944) describes a toxicity trial of five different
+concentrations of pyrethrins (percent) plus a control that were
+administered to eggs of \emph{Ephestia kuhniella}.
+The natural mortality rate is large, and a common adjustment
+is to use Abbott's formula.
+
+}
+%\source{
+%% ~~ reference to a publication or URL from which the data were obtained ~~
+%}
+\references{
+
+ Finney, D. J., 1944.
+ The application of the probit method to toxicity test
+ data adjusted for mortality in the controls.
+ \emph{Annals of Applied Biology}, \bold{31}, 68--74.
+
+
+ Abbott, W. S. (1925).
+ A method of computing the effectiveness of an insecticide.
+ \emph{Journal of Economic Entomology}, 18, 265--7.
+
+
+%% ~~ possibly secondary sources and usages ~~
+}
+\examples{
+data(finney44)
+transform(finney44, mortality = unhatched / (hatched + unhatched))
+}
+\keyword{datasets}
diff --git a/man/fitted.vlm.Rd b/man/fittedvlm.Rd
similarity index 95%
rename from man/fitted.vlm.Rd
rename to man/fittedvlm.Rd
index 6580da6..97ccf7b 100644
--- a/man/fitted.vlm.Rd
+++ b/man/fittedvlm.Rd
@@ -1,5 +1,5 @@
-\name{fitted.vlm}
-\alias{fitted.vlm}
+\name{fittedvlm}
+\alias{fittedvlm}
\alias{fitted.values.vlm}
%- Also NEED an '\alias' for EACH other topic documented here.
\title{Fitted Values of a VLM object}
@@ -10,7 +10,7 @@
}
\usage{
-fitted.vlm(object, matrix.arg = TRUE, ...)
+fittedvlm(object, matrix.arg = TRUE, ...)
}
%- maybe also 'usage' for other objects documented here.
\arguments{
@@ -19,6 +19,7 @@ fitted.vlm(object, matrix.arg = TRUE, ...)
\item{matrix.arg}{ Logical. Return the answer as a matrix?
If \code{FALSE} then it will be a vector. }
\item{\dots}{ Currently unused. }
+
}
\details{
The ``fitted values'' usually corresponds to the mean response,
@@ -26,16 +27,21 @@ fitted.vlm(object, matrix.arg = TRUE, ...)
this sometimes refers to quantities such as quantiles.
The mean may even not exist, e.g., for a Cauchy distribution.
+
}
\value{
The fitted values as returned by the
\code{inverse} slot of the \pkg{VGAM} family function,
evaluated at the final IRLS iteration.
+
+
}
\references{
Chambers, J. M. and T. J. Hastie (eds) (1992)
\emph{Statistical Models in S}.
Wadsworth & Brooks/Cole.
+
+
}
\author{ Thomas W. Yee }
\note{
@@ -45,17 +51,22 @@ Chambers, J. M. and T. J. Hastie (eds) (1992)
This function is equivalent to the methods function for the
generic function \code{fitted.values}.
+
If \code{fit} is a VLM or VGLM then \code{fitted(fit)} and
\code{predict(fit, type="response")} should be equivalent.
The latter has the advantage in that it handles a \code{newdata}
argument so that the fitted values can be computed for a
different data set.
+
+
}
\seealso{
\code{\link[stats]{fitted}},
- \code{\link{predict.vglm}},
+ \code{\link{predictvglm}},
\code{\link{vglmff-class}}.
+
+
}
\examples{
# Categorical regression example 1
diff --git a/man/freund61.Rd b/man/freund61.Rd
index 9fcf883..c52266c 100644
--- a/man/freund61.Rd
+++ b/man/freund61.Rd
@@ -9,14 +9,15 @@
}
\usage{
-freund61(la = "loge", lap = "loge", lb = "loge", lbp = "loge",
+freund61(la = "loge", lap = "loge", lb = "loge", lbp = "loge",
+ ea = list(), eap = list(), eb = list(), ebp = list(),
ia = NULL, iap = NULL, ib = NULL, ibp = NULL,
independent = FALSE, zero = NULL)
}
%- maybe also 'usage' for other objects documented here.
\arguments{
- \item{la,lap,lb,lbp}{
- Link function applied to the (positive)
+ \item{la,lap,lb,lbp,ea,eap,eb,ebp}{
+ Link functions and extra arguments applied to the (positive)
parameters \eqn{\alpha}{alpha}, \eqn{\alpha'}{alpha'},
\eqn{\beta}{beta} and \eqn{\beta'}{beta'}, respectively
(the ``\code{p}'' stands for ``prime'').
@@ -172,10 +173,9 @@ A bivariate extension of the exponential distribution.
}
\examples{
-y1 = rexp(n <- 200, rate = 4)
-y2 = rexp(n, rate = 8)
-ymat = cbind(y1,y2)
-fit = vglm(ymat ~ 1, fam = freund61, trace = TRUE)
+fdata = data.frame(y1 = rexp(nn <- 200, rate = 4))
+fdata = transform(fdata, y2 = rexp(nn, rate = 8))
+fit = vglm(cbind(y1, y2) ~ 1, fam = freund61, fdata, trace = TRUE)
coef(fit, matrix = TRUE)
Coef(fit)
vcov(fit)
@@ -183,10 +183,12 @@ head(fitted(fit))
summary(fit)
# y1 and y2 are independent, so fit an independence model
-fit2 = vglm(ymat ~ 1, fam = freund61(indep = TRUE), trace = TRUE)
+fit2 = vglm(cbind(y1, y2) ~ 1, fam = freund61(indep = TRUE),
+ fdata, trace = TRUE)
coef(fit2, matrix = TRUE)
constraints(fit2)
-pchisq(2*(logLik(fit)-logLik(fit2)), df = 2, lower.tail = FALSE) # p-value
+pchisq(2 * (logLik(fit)-logLik(fit2)), # p-value
+ df = df.residual(fit2) - df.residual(fit), lower.tail = FALSE)
}
\keyword{models}
\keyword{regression}
diff --git a/man/geometric.Rd b/man/geometric.Rd
index d92e03e..d5bbd1f 100644
--- a/man/geometric.Rd
+++ b/man/geometric.Rd
@@ -70,6 +70,7 @@ geometric(link = "logit", earg=list(), expected = TRUE, imethod = 1)
\code{\link[stats]{Geometric}},
\code{\link{betageometric}},
\code{\link{expgeometric}},
+ \code{\link{zigeometric}},
\code{\link{rbetageom}}.
}
@@ -78,11 +79,11 @@ gdata = data.frame(x2 = runif(nn <- 1000) - 0.5)
gdata = transform(gdata, x3 = runif(nn) - 0.5,
x4 = runif(nn) - 0.5)
gdata = transform(gdata, eta = 1.0 - 1.0 * x2 + 2.0 * x3)
-gdata = transform(gdata, prob = logit(eta, inverse=TRUE))
+gdata = transform(gdata, prob = logit(eta, inverse = TRUE))
gdata = transform(gdata, y = rgeom(nn, prob))
with(gdata, table(y))
-fit = vglm(y ~ x2 + x3 + x4, geometric, gdata, trace=TRUE)
-coef(fit, mat=TRUE)
+fit = vglm(y ~ x2 + x3 + x4, geometric, gdata, trace = TRUE)
+coef(fit, matrix = TRUE)
summary(fit)
}
\keyword{models}
diff --git a/man/grc.Rd b/man/grc.Rd
index 802d7fe..a782d3e 100644
--- a/man/grc.Rd
+++ b/man/grc.Rd
@@ -12,8 +12,8 @@
grc(y, Rank = 1, Index.corner = 2:(1 + Rank),
szero = 1, summary.arg = FALSE, h.step = 1e-04, ...)
rcam(y, family = poissonff, Rank = 0, Musual = NULL,
- Index.corner = if (!Rank) NULL else 1 + Musual * (1:Rank),
- rprefix = "Row.", cprefix = "Col.",
+ weights = NULL, Index.corner = if (!Rank) NULL else
+ 1 + Musual * (1:Rank), rprefix = "Row.", cprefix = "Col.",
szero = if (!Rank) NULL else {
if (Musual == 1) 1 else setdiff(1:(Musual * ncol(y)),
c(1 + (1:ncol(y)) * Musual, Index.corner))
@@ -59,6 +59,14 @@ rcam(y, family = poissonff, Rank = 0, Musual = NULL,
each row and column is represented by an indicator variable.
}
+ \item{weights}{
+ Prior weights. Fed into
+ \code{\link{rrvglm}}
+ or
+ \code{\link{vglm}}.
+
+
+ }
\item{Index.corner}{
A vector of \code{Rank} integers.
These are used to store the \code{Rank} by \code{Rank}
@@ -248,6 +256,7 @@ assistance from Alfian F. Hadi.
\code{summary.grc},
\code{\link{moffset}},
\code{\link{Rcam}},
+ \code{\link{Qvar}},
\code{\link{plotrcam0}},
\code{\link{alcoff}},
\code{\link{crashi}},
diff --git a/man/huber.Rd b/man/huber.Rd
index 59ff513..7c29848 100644
--- a/man/huber.Rd
+++ b/man/huber.Rd
@@ -1,13 +1,17 @@
\name{huber}
\alias{huber}
+\alias{huber1}
%- Also NEED an '\alias' for EACH other topic documented here.
\title{ Huber's least favourable distribution family function }
\description{
M-estimation of the two parameters of
Huber's least favourable distribution.
+ The one parameter case is also implemented.
}
\usage{
+huber1(llocation = "identity", elocation = list(),
+ k = 0.862, imethod = 1)
huber(llocation = "identity", lscale = "loge", elocation = list(),
escale = list(), k = 0.862, imethod = 1, zero = 2)
}
@@ -17,11 +21,13 @@ huber(llocation = "identity", lscale = "loge", elocation = list(),
Link functions applied to the location and scale parameters.
See \code{\link{Links}} for more choices.
+
}
\item{elocation, escale}{
List. Extra argument for the links.
See \code{earg} in \code{\link{Links}} for general information.
+
}
\item{k}{
Tuning constant.
@@ -33,6 +39,7 @@ huber(llocation = "identity", lscale = "loge", elocation = list(),
The default value of \code{zero} means the scale parameter is
modelled as an intercept-only.
+
}
}
@@ -41,31 +48,46 @@ huber(llocation = "identity", lscale = "loge", elocation = list(),
resistant/robust regression. The center of the distribution is normal
and its tails are double exponential.
+
By default, the mean is the first linear/additive predictor (returned
as the fitted values; this is the location parameter), and
the log of the scale parameter is the second linear/additive predictor.
The Fisher information matrix is diagonal; Fisher scoring is implemented.
+
+ The \pkg{VGAM} family function \code{huber1()} estimates only the
+ location parameter. It assumes a scale parameter of unit value.
+
+
}
\value{
An object of class \code{"vglmff"} (see \code{\link{vglmff-class}}).
The object is used by modelling functions such as \code{\link{vglm}},
and \code{\link{vgam}}.
+
}
\references{
Huber, P. J. and Ronchetti, E. (2009)
\emph{Robust Statistics}, 2nd ed. New York: Wiley.
+
}
\author{
T. W. Yee. Help was given by Arash Ardalan.
+
}
\note{
- The response should be univariate.
+ Warning: actually, \code{huber()} may be erroneous since the
+ first derivative is not continuous when there are two parameters
+ to estimate. \code{huber1()} is fine in this respect.
+
+
+ The response should be univariate.
+
}
\seealso{
@@ -75,6 +97,7 @@ huber(llocation = "identity", lscale = "loge", elocation = list(),
\code{\link{laplace}},
\code{\link{CommonVGAMffArguments}}.
+
}
\examples{
set.seed(1231); NN = 30; coef1 = 1; coef2 = 10
@@ -84,7 +107,8 @@ hdata = transform(hdata, y = rhuber(NN, mu = coef1 + coef2 * x2))
hdata$x2[1] = 0.0 # Add an outlier
hdata$y[1] = 10
-fit.huber <- vglm(y ~ x2, huber(imethod = 3), hdata, trace = TRUE)
+fit.huber <- vglm(y ~ x2, huber (imethod = 3), hdata, trace = TRUE)
+fit.huber1 <- vglm(y ~ x2, huber1(imethod = 3), hdata, trace = TRUE)
coef(fit.huber, matrix = TRUE)
summary(fit.huber)
@@ -98,12 +122,11 @@ fit.lm <- lm(y ~ x2, hdata) # Compare to a LM:
lines(fitted(fit.lm) ~ x2, hdata, col = "lavender", lwd = 3)
# Compare to truth:
-lines(coef1 + coef2 * x2 ~ x2, hdata, col = "red", lwd = 2, lty = "dashed")
+lines(coef1 + coef2 * x2 ~ x2, hdata, col = "orange", lwd = 2, lty = "dashed")
legend("bottomright", legend = c("truth", "huber", "lm"),
- col = c("red", "darkgreen", "lavender"),
- lty = c("dashed", "solid", "solid"), lwd = c(2, 2, 3))
-}
+ col = c("orange", "darkgreen", "lavender"),
+ lty = c("dashed", "solid", "solid"), lwd = c(2, 2, 3)) }
}
\keyword{models}
\keyword{regression}
diff --git a/man/loge.Rd b/man/loge.Rd
index f6971f6..a89cc1c 100644
--- a/man/loge.Rd
+++ b/man/loge.Rd
@@ -20,6 +20,7 @@ nloge(theta, earg = list(), inverse = FALSE, deriv = 0,
Numeric or character.
See below for further details.
+
}
\item{earg}{
Optional list. Extra argument for passing in additional information.
@@ -29,6 +30,7 @@ nloge(theta, earg = list(), inverse = FALSE, deriv = 0,
The component name \code{bvalue} stands for ``boundary value''.
See \code{\link{Links}} for general information about \code{earg}.
+
}
\item{inverse}{ Logical. If \code{TRUE} the inverse function is computed. }
\item{deriv}{ Order of the derivative. Integer with value 0, 1 or 2. }
@@ -42,6 +44,7 @@ nloge(theta, earg = list(), inverse = FALSE, deriv = 0,
\code{initialize} slot of a \code{\link{vglmff-class}} object.
Contains a little more information if \code{TRUE}.
+
}
}
\details{
@@ -53,10 +56,12 @@ nloge(theta, earg = list(), inverse = FALSE, deriv = 0,
The arguments \code{short} and \code{tag} are used only if
\code{theta} is character.
+
The function \code{loge} computes
\eqn{\log(\theta)}{log(theta)} whereas \code{nloge} computes
\eqn{-\log(\theta)=\log(1/\theta)}{-log(theta)=log(1/theta)}.
+
}
\value{
The following concerns \code{loge}.
@@ -68,12 +73,16 @@ nloge(theta, earg = list(), inverse = FALSE, deriv = 0,
if \code{inverse = FALSE},
else if \code{inverse = TRUE} then it returns the reciprocal.
+
Here, all logarithms are natural logarithms, i.e., to base \eqn{e}.
+
}
\references{
McCullagh, P. and Nelder, J. A. (1989)
\emph{Generalized Linear Models}, 2nd ed. London: Chapman & Hall.
+
+
}
\author{ Thomas W. Yee }
@@ -81,13 +90,16 @@ nloge(theta, earg = list(), inverse = FALSE, deriv = 0,
This function is called \code{loge} to avoid conflict with the
\code{\link[base:Log]{log}} function.
+
Numerical instability may occur when \code{theta} is close to 0 unless
\code{earg} is used.
+
}
\seealso{
\code{\link{Links}},
+ \code{\link{explink}},
\code{\link{logit}},
\code{\link{logc}},
\code{\link{loglog}},
@@ -95,14 +107,13 @@ nloge(theta, earg = list(), inverse = FALSE, deriv = 0,
\code{\link{logoff}},
\code{\link{lambertW}}.
+
}
\examples{
-\dontrun{
-loge(seq(-0.2, 0.5, by = 0.1))
+\dontrun{ loge(seq(-0.2, 0.5, by = 0.1))
loge(seq(-0.2, 0.5, by = 0.1), earg = list(bvalue = .Machine$double.xmin))
nloge(seq(-0.2, 0.5, by = 0.1))
-nloge(seq(-0.2, 0.5, by = 0.1), earg = list(bvalue = .Machine$double.xmin))
-}
+nloge(seq(-0.2, 0.5, by = 0.1), earg = list(bvalue = .Machine$double.xmin)) }
}
\keyword{math}
\keyword{models}
diff --git a/man/logit.Rd b/man/logit.Rd
index b58ecca..8360779 100644
--- a/man/logit.Rd
+++ b/man/logit.Rd
@@ -11,7 +11,7 @@
\usage{
logit(theta, earg = list(), inverse = FALSE, deriv = 0,
short = TRUE, tag = FALSE)
-elogit(theta, earg = list(min=0, max=1), inverse = FALSE, deriv = 0,
+elogit(theta, earg = list(min = 0, max = 1), inverse = FALSE, deriv = 0,
short = TRUE, tag = FALSE)
}
%- maybe also 'usage' for other objects documented here.
@@ -136,75 +136,75 @@ elogit(theta, earg = list(min=0, max=1), inverse = FALSE, deriv = 0,
}
\examples{
-p = seq(0.01, 0.99, by=0.01)
+p = seq(0.01, 0.99, by = 0.01)
logit(p)
-max(abs(logit(logit(p), inverse=TRUE) - p)) # Should be 0
+max(abs(logit(logit(p), inverse = TRUE) - p)) # Should be 0
-p = c(seq(-0.02, 0.02, by=0.01), seq(0.97, 1.02, by=0.01))
+p = c(seq(-0.02, 0.02, by = 0.01), seq(0.97, 1.02, by = 0.01))
logit(p) # Has NAs
-logit(p, earg=list(bvalue= .Machine$double.eps)) # Has no NAs
+logit(p, earg = list(bvalue = .Machine$double.eps)) # Has no NAs
-p = seq(0.9, 2.2, by=0.1)
-elogit(p, earg=list(min=1, max=2,
+p = seq(0.9, 2.2, by = 0.1)
+elogit(p, earg = list(min = 1, max = 2,
bminvalue = 1 + .Machine$double.eps,
bmaxvalue = 2 - .Machine$double.eps)) # Has no NAs
\dontrun{
-par(mfrow=c(2,2))
-y = seq(-4, 4, length=100)
-p = seq(0.01, 0.99, by=0.01)
+par(mfrow = c(2,2))
+y = seq(-4, 4, length = 100)
+p = seq(0.01, 0.99, by = 0.01)
for(d in 0:1) {
- matplot(p, cbind(logit(p, deriv=d), probit(p, deriv=d)),
- type="n", col="purple", ylab="transformation",
- lwd=2, las=1,
- main = if (d == 0) "Some probability link functions"
+ matplot(p, cbind(logit(p, deriv = d), probit(p, deriv = d)),
+ type = "n", col = "purple", ylab = "transformation",
+ lwd = 2, las = 1,
+ main = if (d == 0) "Some probability link functions"
else "First derivative")
- lines(p, logit(p, deriv=d), col="limegreen", lwd=2)
- lines(p, probit(p, deriv=d), col="purple", lwd=2)
- lines(p, cloglog(p, deriv=d), col="chocolate", lwd=2)
- lines(p, cauchit(p, deriv=d), col="tan", lwd=2)
- if (d == 0) {
- abline(v=0.5, h=0, lty="dashed")
+ lines(p, logit(p, deriv = d), lwd = 2, col = "limegreen")
+ lines(p, probit(p, deriv = d), lwd = 2, col = "purple")
+ lines(p, cloglog(p, deriv = d), lwd = 2, col = "chocolate")
+ lines(p, cauchit(p, deriv = d), lwd = 2, col = "tan")
+ if (d == 0) {
+ abline(v = 0.5, h = 0, lty = "dashed")
legend(0, 4.5, c("logit", "probit", "cloglog", "cauchit"),
- col=c("limegreen","purple","chocolate", "tan"), lwd=2)
+ col = c("limegreen", "purple", "chocolate", "tan"), lwd = 2)
} else
- abline(v=0.5, lty="dashed")
+ abline(v = 0.5, lty = "dashed")
}
for(d in 0) {
- matplot(y, cbind(logit(y, deriv=d, inverse=TRUE),
- probit(y, deriv=d, inverse=TRUE)),
- type="n", col="purple", xlab="transformation", ylab="p",
- lwd=2, las=1,
- main = if (d == 0) "Some inverse probability link functions"
+ matplot(y, cbind(logit(y, deriv = d, inverse = TRUE),
+ probit(y, deriv = d, inverse = TRUE)),
+ type = "n", col = "purple", xlab = "transformation", ylab = "p",
+ lwd = 2, las = 1,
+ main = if (d == 0) "Some inverse probability link functions"
else "First derivative")
- lines(y, logit(y, deriv=d, inverse=TRUE), col="limegreen", lwd=2)
- lines(y, probit(y, deriv=d, inverse=TRUE), col="purple", lwd=2)
- lines(y, cloglog(y, deriv=d, inverse=TRUE), col="chocolate", lwd=2)
- lines(y, cauchit(y, deriv=d, inverse=TRUE), col="tan", lwd=2)
- if (d == 0) {
- abline(h=0.5, v=0, lty="dashed")
+ lines(y, logit(y, deriv = d, inverse = TRUE), lwd = 2, col = "limegreen")
+ lines(y, probit(y, deriv = d, inverse = TRUE), lwd = 2, col = "purple")
+ lines(y, cloglog(y, deriv = d, inverse = TRUE), lwd = 2, col = "chocolate")
+ lines(y, cauchit(y, deriv = d, inverse = TRUE), lwd = 2, col = "tan")
+ if (d == 0) {
+ abline(h = 0.5, v = 0, lty = "dashed")
legend(-4, 1, c("logit", "probit", "cloglog", "cauchit"),
- col=c("limegreen","purple","chocolate", "tan"), lwd=2)
+ col = c("limegreen", "purple", "chocolate", "tan"), lwd = 2)
}
}
-p = seq(0.21, 0.59, by=0.01)
-plot(p, elogit(p, earg=list(min=0.2, max=0.6)), lwd=2,
- type="l", col="black", ylab="transformation", xlim=c(0,1),
- las=1, main="elogit(p, earg=list(min=0.2, max=0.6)")
+p = seq(0.21, 0.59, by = 0.01)
+plot(p, elogit(p, earg = list(min = 0.2, max = 0.6)), lwd = 2,
+ type = "l", col = "black", ylab = "transformation", xlim = c(0,1),
+ las = 1, main = "elogit(p, earg = list(min = 0.2, max = 0.6)")
}
}
\keyword{math}
\keyword{models}
\keyword{regression}
-%plot(y, logit(y, inverse=TRUE), type="l", col="limegreen",
-% xlab="transformation", ylab="p",
-% lwd=2, las=1, main="Some inverse probability link functions")
-%lines(y, probit(y, inverse=TRUE), col="purple", lwd=2)
-%lines(y, cloglog(y, inverse=TRUE), col="chocolate", lwd=2)
-%abline(h=0.5, v=0, lty="dashed")
+%plot(y, logit(y, inverse = TRUE), type = "l", col = "limegreen",
+% xlab = "transformation", ylab = "p",
+% lwd = 2, las = 1, main = "Some inverse probability link functions")
+%lines(y, probit(y, inverse = TRUE), col = "purple", lwd = 2)
+%lines(y, cloglog(y, inverse = TRUE), col = "chocolate", lwd = 2)
+%abline(h = 0.5, v = 0, lty = "dashed")
diff --git a/man/lvplot.qrrvglm.Rd b/man/lvplot.qrrvglm.Rd
index 8594edc..97c091b 100644
--- a/man/lvplot.qrrvglm.Rd
+++ b/man/lvplot.qrrvglm.Rd
@@ -251,7 +251,7 @@ canonical Gaussian ordination.
in the future by \code{llty}, \code{lcol} and \code{llwd}, respectively.
For rank-1 models, a similar function to this one is
- \code{\link{persp.qrrvglm}}. It plots the fitted values on a more
+ \code{\link{perspqrrvglm}}. It plots the fitted values on a more
fine grid rather than at the actual site scores here. The result is a
collection of smooth bell-shaped curves. However, it has the weakness
that the plot is more divorced from the data; the user thinks it is
@@ -278,7 +278,7 @@ canonical Gaussian ordination.
\seealso{
\code{\link{lvplot}},
-\code{\link{persp.qrrvglm}},
+\code{\link{perspqrrvglm}},
\code{\link{Coef.qrrvglm}},
\code{\link[graphics]{par}},
\code{\link{cqo}}.
diff --git a/man/margeff.Rd b/man/margeff.Rd
index 1a29fb0..5db3fb5 100644
--- a/man/margeff.Rd
+++ b/man/margeff.Rd
@@ -10,7 +10,7 @@
}
\usage{
-margeff(object, subset=NULL)
+margeff(object, subset = NULL)
}
%- maybe also 'usage' for other objects documented here.
\arguments{
@@ -97,22 +97,22 @@ ii = 3; hh = 1/100
pneumo = transform(pneumo, let = log(exposure.time))
fit = vglm(cbind(normal, mild, severe) ~ let, multinomial, pneumo)
fit = vglm(cbind(normal, mild, severe) ~ let,
- cumulative(reverse=TRUE, parallel=TRUE),
+ cumulative(reverse = TRUE, parallel = TRUE),
data = pneumo)
fitted(fit)[ii,]
mynewdata = with(pneumo, data.frame(let = let[ii]+hh))
-(newp <- predict(fit, newdata=mynewdata, type="response"))
+(newp <- predict(fit, newdata = mynewdata, type = "response"))
# Compare the difference. Should be the same as hh --> 0.
-round(dig=3, (newp-fitted(fit)[ii,])/hh) # Finite-difference approximation
-round(dig=3, margeff(fit, subset=ii)["let",])
+round(dig = 3, (newp-fitted(fit)[ii,])/hh) # Finite-difference approximation
+round(dig = 3, margeff(fit, subset = ii)["let",])
# Other examples
-round(dig=3, margeff(fit))
-round(dig=3, margeff(fit, subset=2)["let",])
-round(dig=3, margeff(fit, subset=c(FALSE,TRUE))["let",,]) # recycling
-round(dig=3, margeff(fit, subset=c(2,4,6,8))["let",,])
+round(dig = 3, margeff(fit))
+round(dig = 3, margeff(fit, subset = 2)["let",])
+round(dig = 3, margeff(fit, subset = c(FALSE,TRUE))["let",,]) # recycling
+round(dig = 3, margeff(fit, subset = c(2,4,6,8))["let",,])
}
diff --git a/man/maxwell.Rd b/man/maxwell.Rd
index d776aa1..51e000f 100644
--- a/man/maxwell.Rd
+++ b/man/maxwell.Rd
@@ -7,7 +7,7 @@
maximum likelihood estimation.
}
\usage{
-maxwell(link = "loge", earg=list())
+maxwell(link = "loge", earg = list())
}
%- maybe also 'usage' for other objects documented here.
\arguments{
@@ -27,14 +27,15 @@ maxwell(link = "loge", earg=list())
The Maxwell distribution, which is used in the area of
thermodynamics,
has a probability density function that can be written
- \deqn{f(y) = \sqrt{2/\pi} a^{3/2} y^2 \exp(-0.5 a y^2)}{%
- f(y) = sqrt(2/pi) * a^(3/2) * y^2 * exp(-0.5*a*y^2)}
+ \deqn{f(y;a) = \sqrt{2/\pi} a^{3/2} y^2 \exp(-0.5 a y^2)}{%
+ f(y;a) = sqrt(2/pi) * a^(3/2) * y^2 * exp(-0.5*a*y^2)}
for \eqn{y>0} and \eqn{a>0}.
The mean of \eqn{Y} is
\eqn{\sqrt{8 / (a \pi)}}{sqrt(8 / (a * pi))}
(returned as the fitted values), and its variance is
\eqn{(3\pi - 8)/(\pi a)}{(3*pi - 8)/(pi*a)}.
+
}
\value{
An object of class \code{"vglmff"} (see \code{\link{vglmff-class}}).
@@ -42,12 +43,15 @@ maxwell(link = "loge", earg=list())
\code{\link{rrvglm}}
and \code{\link{vgam}}.
+
}
\references{
+
von Seggern, D. H. (1993)
\emph{CRC Standard Curves and Surfaces},
Boca Raton, FL.: CRC Press.
+
}
\author{ T. W. Yee }
\note{
@@ -62,9 +66,9 @@ maxwell(link = "loge", earg=list())
}
\examples{
-mdata = data.frame(y = rmaxwell(1000, a=exp(2)))
-fit = vglm(y ~ 1, maxwell, mdata, trace=TRUE, crit="c")
-coef(fit, matrix=TRUE)
+mdata = data.frame(y = rmaxwell(1000, a = exp(2)))
+fit = vglm(y ~ 1, maxwell, mdata, trace = TRUE, crit = "c")
+coef(fit, matrix = TRUE)
Coef(fit)
}
\keyword{models}
diff --git a/man/mbinomial.Rd b/man/mbinomial.Rd
index 69dd0a7..6c3a568 100644
--- a/man/mbinomial.Rd
+++ b/man/mbinomial.Rd
@@ -8,7 +8,7 @@
}
\usage{
-mbinomial(mvar=NULL, link="logit", earg=list(),
+mbinomial(mvar = NULL, link = "logit", earg = list(),
parallel = TRUE, smallno = .Machine$double.eps^(3/4))
}
%- maybe also 'usage' for other objects documented here.
@@ -47,13 +47,13 @@ mbinomial(mvar=NULL, link="logit", earg=list(),
\details{
By default, this \pkg{VGAM} family function fits a logistic regression
model to a binary response from a matched case-control study. Here,
- each case \eqn{(Y=1}) is matched with one or more controls \eqn{(Y=0})
+ each case \eqn{(Y = 1}) is matched with one or more controls \eqn{(Y = 0})
with respect to some matching variables (confounders). For example,
the first matched set is all women aged from 20 to 25, the second
matched set is women aged between 26 to 30, etc. The logistic
regression has a different intercept for each matched set but the other
regression coefficients are assumed to be the same across matched sets
- (\code{parallel=TRUE}).
+ (\code{parallel = TRUE}).
Let \eqn{C} be the number of matched sets.
This \pkg{VGAM} family function uses a trick by allowing \eqn{M},
@@ -114,8 +114,8 @@ mbinomial(mvar=NULL, link="logit", earg=list(),
per matched set, the memory requirements are \eqn{O(C^3)} and the
the computational time is \eqn{O(C^4)} flops.
- The example below has been run successfully with \code{n=700} (this
- corresponds to \eqn{C=350}) but only on a big machine and it took over
+ The example below has been run successfully with \code{n = 700} (this
+ corresponds to \eqn{C = 350}) but only on a big machine and it took over
10 minutes. The large model matrix was 670Mb.
}
@@ -131,8 +131,8 @@ mbinomial(mvar=NULL, link="logit", earg=list(),
# the confounder or matching variable.
n = 700 # Requires a big machine with lots of memory. Expensive wrt time
n = 100 # This requires a reasonably big machine.
-mydat = data.frame(x2 = rnorm(n), x3 = rep(rnorm(n/2), each=2))
-xmat = with(mydat, cbind(x2,x3))
+mydat = data.frame(x2 = rnorm(n), x3 = rep(rnorm(n/2), each = 2))
+xmat = with(mydat, cbind(x2, x3))
mydat = transform(mydat, eta = -0.1 + 0.2 * x2 + 0.3 * x3)
etamat = with(mydat, matrix(eta, n/2, 2))
condmu = exp(etamat[,1]) / (exp(etamat[,1]) + exp(etamat[,2]))
@@ -140,16 +140,16 @@ y1 = ifelse(runif(n/2) < condmu, 1, 0)
y = cbind(y1, 1-y1)
mydat = transform(mydat, y = c(y1, 1-y1),
ID = factor(c(row(etamat))))
-fit = vglm(y ~ 1 + ID + x2, trace=TRUE,
- fam = mbinomial(mvar = ~ ID - 1), data=mydat)
-dimnames(coef(fit, mat=TRUE))
-coef(fit, mat=TRUE)
+fit = vglm(y ~ 1 + ID + x2, trace = TRUE,
+ fam = mbinomial(mvar = ~ ID - 1), data = mydat)
+dimnames(coef(fit, matrix = TRUE))
+coef(fit, matrix = TRUE)
summary(fit)
head(fitted(fit))
-objsizemb = function(object) round(object.size(object) / 2^20, dig=2)
+objsizemb = function(object) round(object.size(object) / 2^20, dig = 2)
objsizemb(fit) # in Mb
-VLMX = model.matrix(fit, type="vlm") # The big model matrix
+VLMX = model.matrix(fit, type = "vlm") # The big model matrix
dim(VLMX)
objsizemb(VLMX) # in Mb
rm(VLMX)
diff --git a/man/mccullagh89.Rd b/man/mccullagh89.Rd
index c5f9723..558e7e2 100644
--- a/man/mccullagh89.Rd
+++ b/man/mccullagh89.Rd
@@ -8,15 +8,16 @@
}
\usage{
-mccullagh89(ltheta="rhobit", lnu="logoff", itheta=NULL, inu=NULL,
- etheta=list(), enu=if(lnu == "logoff") list(offset=0.5)
- else list(), zero=NULL)
+mccullagh89(ltheta = "rhobit", lnu = "logoff", itheta = NULL, inu = NULL,
+ etheta = list(), enu = if(lnu == "logoff") list(offset = 0.5)
+ else list(), zero = NULL)
}
%- maybe also 'usage' for other objects documented here.
\arguments{
- \item{ltheta, lnu}{
- Link functions for the \eqn{\theta}{theta} and \eqn{\nu}{nu} parameters.
- See \code{\link{Links}} for more choices.
+ \item{ltheta, lnu, etheta, enu}{
+ Link functions and their extra arguments
+ for the \eqn{\theta}{theta} and \eqn{\nu}{nu} parameters.
+ See \code{\link{Links}} for general information.
}
\item{itheta, inu}{
@@ -25,13 +26,6 @@ mccullagh89(ltheta="rhobit", lnu="logoff", itheta=NULL, inu=NULL,
The default is to internally compute them.
}
- \item{etheta, enu}{
- List. Extra argument associated with \code{ltheta} and \code{lnu}
- containing any extra information.
- See \code{\link{Links}} for general information about \pkg{VGAM} link
- functions.
-
- }
\item{zero}{
An integer-valued vector specifying which
linear/additive predictors are modelled as intercepts only.
@@ -41,7 +35,7 @@ mccullagh89(ltheta="rhobit", lnu="logoff", itheta=NULL, inu=NULL,
}
}
\details{
- The McCullagh (1989) distribution has density function
+The McCullagh (1989) distribution has density function
\deqn{f(y;\theta,\nu) =
\frac{ \{ 1-y^2 \}^{\nu-\frac12}}
{ (1-2\theta y + \theta^2)^{\nu} \mbox{Beta}(\nu+\frac12, \frac12)}}{%
@@ -56,6 +50,7 @@ with offset equal to 0.5, i.e.,
The mean is of \eqn{Y} is \eqn{\nu \theta / (1+\nu)}{nu*theta/(1+nu)},
and these are returned as the fitted values.
+
This distribution is related to the Leipnik distribution (see Johnson
et al. (1995)), is related to ultraspherical functions, and under
certain conditions, arises as exit distributions for Brownian motion.
@@ -65,20 +60,25 @@ McCullagh (1989) also states that, to some extent, \eqn{\theta}{theta}
and \eqn{\nu}{nu} have the properties of a location parameter and a
precision parameter, respectively.
+
}
\value{
An object of class \code{"vglmff"} (see \code{\link{vglmff-class}}).
The object is used by modelling functions such as \code{\link{vglm}},
\code{\link{rrvglm}}
and \code{\link{vgam}}.
+
+
}
\references{
+
McCullagh, P. (1989)
Some statistical properties of a family of continuous univariate distributions.
\emph{Journal of the American Statistical Association},
\bold{84}, 125--129.
+
Johnson, N. L. and Kotz, S. and Balakrishnan, N. (1995)
\emph{Continuous Univariate Distributions},
2nd edition,
@@ -86,6 +86,7 @@ Volume 2,
New York: Wiley.
(pages 612--617).
+
}
\author{ T. W. Yee }
\note{
@@ -96,24 +97,26 @@ densities for different values of \eqn{\theta}{theta} and \eqn{\nu}{nu},
and this could be consulted for obtaining reasonable initial values if
all else fails.
+
}
\seealso{
- \code{\link{leipnik}},
- \code{\link{rhobit}},
- \code{\link{logoff}}.
+ \code{\link{leipnik}},
+ \code{\link{rhobit}},
+ \code{\link{logoff}}.
+
+
}
%\section{Warning }{
%}
\examples{
-n = 1000
-y = rnorm(n, mean=0.0, sd=0.2) # Limit as theta is 0, nu is infinity
-fit = vglm(y ~ 1, mccullagh89, trace=TRUE)
+mdata = data.frame(y = rnorm(n = 1000, sd = 0.2)) # Limit as theta = 0, nu is Inf
+fit = vglm(y ~ 1, mccullagh89, mdata, trace = TRUE)
head(fitted(fit))
-mean(y)
+with(mdata, mean(y))
summary(fit)
-coef(fit, matrix=TRUE)
+coef(fit, matrix = TRUE)
Coef(fit)
}
\keyword{models}
diff --git a/man/mix2exp.Rd b/man/mix2exp.Rd
index 0cf0d51..fa8e03e 100644
--- a/man/mix2exp.Rd
+++ b/man/mix2exp.Rd
@@ -9,36 +9,31 @@
}
\usage{
-mix2exp(lphi="logit", llambda="loge", ephi=list(), el1=list(), el2=list(),
- iphi=0.5, il1=NULL, il2=NULL, qmu=c(0.8, 0.2), nsimEIM=100, zero=1)
+mix2exp(lphi = "logit", llambda = "loge", ephi = list(),
+ el1 = list(), el2 = list(), iphi = 0.5, il1 = NULL, il2 = NULL,
+ qmu = c(0.8, 0.2), nsimEIM = 100, zero = 1)
}
%- maybe also 'usage' for other objects documented here.
\arguments{
- \item{lphi}{
- Link function for the parameter \eqn{\phi}{phi}.
+ \item{lphi, llambda}{
+ Link functions for the parameters \eqn{\phi}{phi}
+ and \eqn{\lambda}{lambda}. The latter is the rate parameter
+ and note that the mean of an ordinary exponential distribution is
+ \eqn{1 / \lambda}.
See \code{\link{Links}} for more choices.
}
- \item{llambda}{
- Link function applied to each \eqn{\lambda}{lambda} (rate) parameter.
- See \code{\link{Links}} for more choices.
- Note that the mean of an ordinary exponential distribution is
- \eqn{1 / \lambda}.
- }
\item{ephi, el1, el2}{
List. Extra argument for each of the links.
See \code{earg} in \code{\link{Links}} for general information.
}
- \item{iphi}{
- Initial value for \eqn{\phi}{phi}, whose value must lie
- between 0 and 1.
-
- }
- \item{il1, il2}{
- Optional initial value for \eqn{\lambda_1}{lambda1} and
- \eqn{\lambda_2}{lambda2}. These values must be positive.
+ \item{iphi, il1, il2}{
+ Initial value for \eqn{\phi}{phi}, and
+ optional initial value for \eqn{\lambda_1}{lambda1} and
+ \eqn{\lambda_2}{lambda2}.
+ The last two have values that must be positive.
The default is to compute initial values internally using
the argument \code{qmu}.
@@ -51,18 +46,9 @@ mix2exp(lphi="logit", llambda="loge", ephi=list(), el1=list(), el2=list(),
\code{\link[stats]{quantile}}.
}
- \item{nsimEIM}{
+ \item{nsimEIM, zero}{
See \code{\link{CommonVGAMffArguments}}.
- }
- \item{zero}{
- An integer specifying which linear/additive predictor is modelled as
- intercepts only. If given, the value must be either 1 and/or 2 and/or
- 3, and the default is the first one only, meaning \eqn{\phi}{phi}
- is a single parameter even when there are explanatory variables.
- Set \code{zero=NULL} to model all linear/additive predictors as
- functions of the explanatory variables.
- See \code{\link{CommonVGAMffArguments}} for more information.
}
}
@@ -80,12 +66,14 @@ mix2exp(lphi="logit", llambda="loge", ephi=list(), el1=list(), el2=list(),
\eqn{(logit(\phi), \log(\lambda_1), \log(\lambda_2))^T}{(logit(phi),
log(lambda1), log(lambda2))^T}.
+
}
\value{
An object of class \code{"vglmff"} (see \code{\link{vglmff-class}}).
The object is used by modelling functions such as \code{\link{vglm}}
and \code{\link{vgam}}.
+
}
% \references{ ~put references to the literature/web site here ~ }
\section{Warning }{
@@ -97,6 +85,7 @@ mix2exp(lphi="logit", llambda="loge", ephi=list(), el1=list(), el2=list(),
\code{il2}, \code{qmu} is highly recommended. Graphical methods such
as \code{\link[graphics]{hist}} can be used as an aid.
+
}
\author{ T. W. Yee }
@@ -107,7 +96,7 @@ mix2exp(lphi="logit", llambda="loge", ephi=list(), el1=list(), el2=list(),
and check that the best fit looks reasonable. Plotting the results is
recommended. This function works better as \eqn{\lambda_1}{lambda1}
and \eqn{\lambda_2}{lambda2} become more different.
- The default control argument \code{trace=TRUE} is to encourage
+ The default control argument \code{trace = TRUE} is to encourage
monitoring convergence.
}
@@ -116,25 +105,27 @@ mix2exp(lphi="logit", llambda="loge", ephi=list(), el1=list(), el2=list(),
\code{\link[stats:Exponential]{rexp}},
\code{\link{exponential}},
\code{\link{mix2poisson}}.
+
+
}
\examples{
lambda1 = exp(1); lambda2 = exp(3)
-(phi = logit(-1, inverse=TRUE))
+(phi = logit(-1, inverse = TRUE))
mdata = data.frame(y1 = rexp(nn <- 1000, lambda1))
mdata = transform(mdata, y2 = rexp(nn, lambda2))
mdata = transform(mdata, y = ifelse(runif(nn) < phi, y1, y2))
-fit = vglm(y ~ 1, mix2exp, mdata, trace=TRUE)
-coef(fit, matrix=TRUE)
+fit = vglm(y ~ 1, mix2exp, mdata, trace = TRUE)
+coef(fit, matrix = TRUE)
# Compare the results with the truth
-round(rbind('Estimated'=Coef(fit),
- 'Truth'=c(phi, lambda1, lambda2)), dig=2)
+round(rbind('Estimated' = Coef(fit),
+ 'Truth' = c(phi, lambda1, lambda2)), dig = 2)
\dontrun{# Plot the results
-with(mdata, hist(y, prob=TRUE, main="Red=estimate, blue=truth"))
-abline(v=1/Coef(fit)[c(2,3)], lty=2, col="red", lwd=2)
-abline(v=1/c(lambda1, lambda2), lty=2, col="blue", lwd=2) }
+with(mdata, hist(y, prob = TRUE, main = "Orange=estimate, blue=truth"))
+abline(v = 1/Coef(fit)[c(2,3)], lty = 2, col = "orange", lwd = 2)
+abline(v = 1/c(lambda1, lambda2), lty = 2, col = "blue", lwd = 2) }
}
\keyword{models}
\keyword{regression}
diff --git a/man/mix2normal1.Rd b/man/mix2normal1.Rd
index f11220f..0dee335 100644
--- a/man/mix2normal1.Rd
+++ b/man/mix2normal1.Rd
@@ -8,32 +8,25 @@
}
\usage{
-mix2normal1(lphi="logit", lmu="identity", lsd="loge",
- ephi=list(), emu1=list(), emu2=list(), esd1=list(), esd2=list(),
- iphi=0.5, imu1=NULL, imu2=NULL, isd1=NULL, isd2=NULL,
- qmu=c(0.2, 0.8), equalsd=TRUE, nsimEIM=100, zero=1)
+mix2normal1(lphi = "logit", lmu = "identity", lsd = "loge",
+ ephi = list(), emu1 = list(), emu2 = list(),
+ esd1 = list(), esd2 = list(),
+ iphi = 0.5, imu1 = NULL, imu2 = NULL, isd1 = NULL, isd2 = NULL,
+ qmu = c(0.2, 0.8), equalsd = TRUE, nsimEIM = 100, zero = 1)
}
%- maybe also 'usage' for other objects documented here.
\arguments{
- \item{lphi}{
- Link function for the parameter \eqn{\phi}{phi}.
- See \code{\link{Links}} for more choices.
-
- }
- \item{lmu}{
- Link function applied to each \eqn{\mu}{mu} parameter.
- See \code{\link{Links}} for more choices.
-
- }
- \item{lsd}{
- Link function applied to each \eqn{\sigma}{sd} parameter.
+ \item{lphi,lmu,lsd}{
+ Link functions for the parameters \eqn{\phi}{phi},
+ \eqn{\mu}{mu}, and
+ \eqn{\sigma}{sd}.
See \code{\link{Links}} for more choices.
}
\item{ephi, emu1, emu2, esd1, esd2}{
List. Extra argument for each of the links.
See \code{earg} in \code{\link{Links}} for general information.
- If \code{equalsd=TRUE} then \code{esd1} must equal \code{esd2}.
+ If \code{equalsd = TRUE} then \code{esd1} must equal \code{esd2}.
}
\item{iphi}{
@@ -79,7 +72,7 @@ mix2normal1(lphi="logit", lmu="identity", lsd="loge",
set \eqn{\{1,2,\ldots,5\}}{1,2,...,5}.
The default is the first one only, meaning \eqn{\phi}{phi}
is a single parameter even when there are explanatory variables.
- Set \code{zero=NULL} to model all linear/additive predictors as
+ Set \code{zero = NULL} to model all linear/additive predictors as
functions of the explanatory variables.
See \code{\link{CommonVGAMffArguments}} for more information.
@@ -100,7 +93,8 @@ mix2normal1(lphi="logit", lmu="identity", lsd="loge",
By default, the five linear/additive predictors are
\eqn{(logit(\phi), \mu_1, \log(\sigma_1), \mu_2, \log(\sigma_2))^T}{(logit(phi),
mu1, log(sd1), mu2, log(sd2))^T}.
- If \code{equalsd=TRUE} then \eqn{\sigma_1 = \sigma_2}{sd1=sd2} is enforced.
+ If \code{equalsd = TRUE} then \eqn{\sigma_1 = \sigma_2}{sd1=sd2} is enforced.
+
}
\value{
@@ -111,14 +105,17 @@ mix2normal1(lphi="logit", lmu="identity", lsd="loge",
}
\references{
+
McLachlan, G. J. and Peel, D. (2000)
\emph{Finite Mixture Models}.
New York: Wiley.
+
Everitt, B. S. and Hand, D. J. (1981)
\emph{Finite Mixture Distributions}.
London: Chapman & Hall.
+
}
\section{Warning }{
Numerical problems can occur and
@@ -132,6 +129,7 @@ London: Chapman & Hall.
\code{isd2},
etc.
+
% This function uses a quasi-Newton update for the working weight matrices
% (BFGS variant). It builds up approximations to the weight matrices,
% and currently the code is not fully tested.
@@ -139,8 +137,10 @@ London: Chapman & Hall.
% \code{vcov} and \code{summary}) may be quite incorrect, especially when
% the arguments \code{weights} is used to input prior weights.
+
This \pkg{VGAM} family function should be used with care.
+
}
\author{ T. W. Yee }
@@ -152,13 +152,15 @@ London: Chapman & Hall.
This function works better as \eqn{\mu_1}{mu1} and \eqn{\mu_2}{mu2}
become more different.
+
Convergence can be slow, especially when the two component
distributions are not well separated.
- The default control argument \code{trace=TRUE} is to encourage
+ The default control argument \code{trace = TRUE} is to encourage
monitoring convergence.
- Having \code{equalsd=TRUE} often makes the overall optimization problem
+ Having \code{equalsd = TRUE} often makes the overall optimization problem
easier.
+
}
\seealso{
@@ -169,30 +171,29 @@ London: Chapman & Hall.
}
\examples{
-mu1 = 99; mu2 = 150
+mu1 = 99; mu2 = 150; nn = 1000
sd1 = sd2 = exp(3)
-(phi = logit(-1, inverse=TRUE))
-nn = 1000
+(phi = logit(-1, inverse = TRUE))
mdata = data.frame(y = ifelse(runif(nn) < phi, rnorm(nn, mu1, sd1),
rnorm(nn, mu2, sd2)))
-fit = vglm(y ~ 1, mix2normal1(equalsd=TRUE), mdata)
+fit = vglm(y ~ 1, mix2normal1(equalsd = TRUE), mdata)
# Compare the results
cfit = coef(fit)
-round(rbind('Estimated'=c(logit(cfit[1], inv=TRUE),
- cfit[2], exp(cfit[3]), cfit[4]), 'Truth'=c(phi, mu1, sd1, mu2)), dig=2)
+round(rbind('Estimated' = c(logit(cfit[1], inverse = TRUE),
+ cfit[2], exp(cfit[3]), cfit[4]), 'Truth' = c(phi, mu1, sd1, mu2)), dig = 2)
\dontrun{# Plot the results
-xx = with(mdata, seq(min(y), max(y), len=200))
-plot(xx, (1-phi)*dnorm(xx, mu2, sd2), type="l", xlab="y",
- main="Red=estimate, blue=truth", col="blue", ylab="Density")
-phi.est = logit(coef(fit)[1], inverse=TRUE)
+xx = with(mdata, seq(min(y), max(y), len = 200))
+plot(xx, (1-phi)*dnorm(xx, mu2, sd2), type = "l", xlab = "y",
+ main = "Orange=estimate, blue=truth", col = "blue", ylab = "Density")
+phi.est = logit(coef(fit)[1], inverse = TRUE)
sd.est = exp(coef(fit)[3])
-lines(xx, phi*dnorm(xx, mu1, sd1), col="blue")
-lines(xx, phi.est * dnorm(xx, Coef(fit)[2], sd.est), col="red")
-lines(xx, (1-phi.est) * dnorm(xx, Coef(fit)[4], sd.est), col="red")
-abline(v=Coef(fit)[c(2,4)], lty=2, col="red")
-abline(v=c(mu1, mu2), lty=2, col="blue") }
+lines(xx, phi*dnorm(xx, mu1, sd1), col = "blue")
+lines(xx, phi.est * dnorm(xx, Coef(fit)[2], sd.est), col = "orange")
+lines(xx, (1-phi.est) * dnorm(xx, Coef(fit)[4], sd.est), col = "orange")
+abline(v = Coef(fit)[c(2,4)], lty = 2, col = "orange")
+abline(v = c(mu1, mu2), lty = 2, col = "blue") }
}
\keyword{models}
\keyword{regression}
diff --git a/man/mix2poisson.Rd b/man/mix2poisson.Rd
index 8bacea2..473c390 100644
--- a/man/mix2poisson.Rd
+++ b/man/mix2poisson.Rd
@@ -9,19 +9,15 @@
}
\usage{
mix2poisson(lphi = "logit", llambda = "loge",
- ephi=list(), el1=list(), el2=list(),
+ ephi = list(), el1 = list(), el2 = list(),
iphi = 0.5, il1 = NULL, il2 = NULL,
- qmu = c(0.2, 0.8), nsimEIM=100, zero = 1)
+ qmu = c(0.2, 0.8), nsimEIM = 100, zero = 1)
}
%- maybe also 'usage' for other objects documented here.
\arguments{
- \item{lphi}{
- Link function for the parameter \eqn{\phi}{phi}.
- See \code{\link{Links}} for more choices.
-
- }
- \item{llambda}{
- Link function applied to each \eqn{\lambda}{lambda} parameter.
+ \item{lphi, llambda}{
+ Link functions for the parameter \eqn{\phi}{phi} and
+ \eqn{\lambda}{lambda}.
See \code{\link{Links}} for more choices.
}
@@ -50,20 +46,10 @@ mix2poisson(lphi = "logit", llambda = "loge",
\code{\link[stats]{quantile}}.
}
- \item{nsimEIM}{
+ \item{nsimEIM, zero}{
See \code{\link{CommonVGAMffArguments}}.
}
- \item{zero}{
- An integer specifying which linear/additive predictor is modelled as
- intercepts only. If given, the value must be either 1 and/or 2 and/or
- 3, and the default is the first one only, meaning \eqn{\phi}{phi}
- is a single parameter even when there are explanatory variables.
- Set \code{zero=NULL} to model all linear/additive predictors as
- functions of the explanatory variables.
- See \code{\link{CommonVGAMffArguments}} for more information.
-
- }
}
\details{
The probability function can be loosely written as
@@ -79,12 +65,14 @@ mix2poisson(lphi = "logit", llambda = "loge",
\eqn{(logit(\phi), \log(\lambda_1), \log(\lambda_2))^T}{(logit(phi),
log(lambda1), log(lambda2))^T}.
+
}
\value{
An object of class \code{"vglmff"} (see \code{\link{vglmff-class}}).
The object is used by modelling functions such as \code{\link{vglm}}
and \code{\link{vgam}}.
+
}
% \references{ ~put references to the literature/web site here ~ }
\section{Warning }{
@@ -96,10 +84,12 @@ mix2poisson(lphi = "logit", llambda = "loge",
\code{il2}, \code{qmu} is highly recommended. Graphical methods such
as \code{\link[graphics]{hist}} can be used as an aid.
+
With grouped data (i.e., using the \code{weights} argument)
one has to use a large value of \code{nsimEIM};
see the example below.
+
}
\author{ T. W. Yee }
@@ -107,21 +97,25 @@ mix2poisson(lphi = "logit", llambda = "loge",
The response must be integer-valued since \code{\link[stats]{dpois}}
is invoked.
+
Fitting this model successfully to data can be difficult due to local
solutions and ill-conditioned data. It pays to fit the model several
times with different initial values, and check that the best fit
looks reasonable. Plotting the results is recommended. This function
works better as \eqn{\lambda_1}{lambda1} and \eqn{\lambda_2}{lambda2}
become more different.
- The default control argument \code{trace=TRUE} is to encourage
+ The default control argument \code{trace = TRUE} is to encourage
monitoring convergence.
+
}
\seealso{
\code{\link[stats:Poisson]{rpois}},
\code{\link{poissonff}},
\code{\link{mix2normal1}}.
+
+
}
\examples{
@@ -129,20 +123,20 @@ mix2poisson(lphi = "logit", llambda = "loge",
nn = 1000
mu1 = exp(2.5) # also known as lambda1
mu2 = exp(3)
-(phi = logit(-0.5, inverse=TRUE))
+(phi = logit(-0.5, inverse = TRUE))
mdata = data.frame(y = ifelse(runif(nn) < phi, rpois(nn, mu1), rpois(nn, mu2)))
fit = vglm(y ~ 1, mix2poisson, mdata)
-coef(fit, matrix=TRUE)
+coef(fit, matrix = TRUE)
# Compare the results with the truth
-round(rbind('Estimated'=Coef(fit), 'Truth'=c(phi, mu1, mu2)), dig=2)
+round(rbind('Estimated' = Coef(fit), 'Truth' = c(phi, mu1, mu2)), dig = 2)
\dontrun{# Plot the results
ty = with(mdata, table(y))
-plot(names(ty), ty, type="h", main="Red=estimate, blue=truth",
- ylab="Frequency", xlab="y")
-abline(v=Coef(fit)[-1], lty=2, col="red", lwd=2)
-abline(v=c(mu1, mu2), lty=2, col="blue", lwd=2) }
+plot(names(ty), ty, type = "h", main = "Orange=estimate, blue=truth",
+ ylab = "Frequency", xlab = "y")
+abline(v = Coef(fit)[-1], lty = 2, col = "orange", lwd = 2)
+abline(v = c(mu1, mu2), lty = 2, col = "blue", lwd = 2) }
# Example 2: London Times data (Lange, 1997, p.31)
ltdata1 = data.frame(deaths = 0:9,
@@ -150,12 +144,12 @@ ltdata1 = data.frame(deaths = 0:9,
ltdata2 = data.frame(y = with(ltdata1, rep(deaths, freq)))
# Usually this does not work well unless nsimEIM is large
-fit = vglm(deaths ~ 1, weight=freq, data=ltdata1,
- mix2poisson(iphi=0.3, il1=1, il2=2.5, nsimEIM=5000))
+fit = vglm(deaths ~ 1, weight = freq, data = ltdata1,
+ mix2poisson(iphi = 0.3, il1 = 1, il2 = 2.5, nsimEIM = 5000))
# This works better in general
-fit = vglm(y ~ 1, mix2poisson(iphi=0.3, il1=1, il2=2.5), ltdata2)
-coef(fit, matrix=TRUE)
+fit = vglm(y ~ 1, mix2poisson(iphi = 0.3, il1 = 1, il2 = 2.5), ltdata2)
+coef(fit, matrix = TRUE)
Coef(fit)
}
\keyword{models}
diff --git a/man/model.framevlm.Rd b/man/model.framevlm.Rd
index 31ae73d..1b00dfb 100644
--- a/man/model.framevlm.Rd
+++ b/man/model.framevlm.Rd
@@ -36,40 +36,48 @@ model.framevlm(object, setupsmart = TRUE, wrapupsmart = TRUE, \dots)
This code implements \emph{smart prediction}
(see \code{\link{smartpred}}).
+
+
}
\value{
A \code{\link{data.frame}} containing the variables used in
the \code{object} plus those specified in \code{\dots}.
+
}
\seealso{
\code{\link[stats]{model.frame}},
\code{\link{model.matrixvlm}},
- \code{\link{predict.vglm}},
+ \code{\link{predictvglm}},
\code{\link{smartpred}}.
+
+
}
\references{
+
Chambers, J. M. (1992)
\emph{Data for models.}
Chapter 3 of \emph{Statistical Models in S}
eds J. M. Chambers and T. J. Hastie, Wadsworth & Brooks/Cole.
+
+
}
\examples{
# Illustrates smart prediction
-pneumo = transform(pneumo, let=log(exposure.time))
+pneumo = transform(pneumo, let = log(exposure.time))
fit = vglm(cbind(normal,mild, severe) ~ poly(c(scale(let)), 2),
- fam=multinomial,
- data=pneumo, trace=TRUE, x=FALSE)
+ fam = multinomial,
+ data = pneumo, trace = TRUE, x = FALSE)
class(fit)
check1 = head(model.frame(fit))
check1
-check2 = model.frame(fit, data=head(pneumo))
+check2 = model.frame(fit, data = head(pneumo))
check2
all.equal(unlist(check1), unlist(check2)) # Should be TRUE
q0 = head(predict(fit))
-q1 = head(predict(fit, newdata=pneumo))
-q2 = predict(fit, newdata=head(pneumo))
+q1 = head(predict(fit, newdata = pneumo))
+q2 = predict(fit, newdata = head(pneumo))
all.equal(q0, q1) # Should be TRUE
all.equal(q1, q2) # Should be TRUE
}
diff --git a/man/model.matrixvlm.Rd b/man/model.matrixvlm.Rd
index 137a99f..01acf01 100644
--- a/man/model.matrixvlm.Rd
+++ b/man/model.matrixvlm.Rd
@@ -2,7 +2,7 @@
\alias{model.matrixvlm}
\title{Construct the Design Matrix of a VLM Object}
\usage{
-model.matrixvlm(object, type=c("vlm","lm","lm2","bothlmlm2"), \dots)
+model.matrixvlm(object, type = c("vlm","lm","lm2","bothlmlm2"), \dots)
}
\arguments{
\item{object}{an object of a class that inherits from the
@@ -31,6 +31,8 @@ model.matrixvlm(object, type=c("vlm","lm","lm2","bothlmlm2"), \dots)
returned: a large one (class \code{"vlm"} or one that inherits
from this such as \code{"vglm"}) or a small one
(such as returned if it were of class \code{"lm"}).
+
+
}
\details{
This function creates a design matrix from \code{object}.
@@ -38,53 +40,62 @@ model.matrixvlm(object, type=c("vlm","lm","lm2","bothlmlm2"), \dots)
The latter is constructed from the former and the constraint
matrices.
+
This code implements \emph{smart prediction}
(see \code{\link{smartpred}}).
+
+
}
\value{
The design matrix for a regression model with the specified formula
and data.
- If \code{type="bothlmlm2"} then a list is returned with components
+ If \code{type = "bothlmlm2"} then a list is returned with components
\code{"X"} and \code{"Xm2"}.
+
}
\references{
+
Yee, T. W. and Hastie, T. J. (2003)
Reduced-rank vector generalized linear models.
\emph{Statistical Modelling},
\bold{3}, 15--41.
+
Chambers, J. M. (1992)
\emph{Data for models.}
Chapter 3 of \emph{Statistical Models in S}
eds J. M. Chambers and T. J. Hastie, Wadsworth & Brooks/Cole.
+
}
\seealso{
\code{\link[stats]{model.matrix}},
\code{\link{model.framevlm}},
- \code{\link{predict.vglm}},
+ \code{\link{predictvglm}},
\code{\link{smartpred}}.
+
+
}
\examples{
# Illustrates smart prediction
-pneumo = transform(pneumo, let=log(exposure.time))
-fit = vglm(cbind(normal,mild, severe) ~ poly(c(scale(let)), 2),
- fam=multinomial,
- data=pneumo, trace=TRUE, x=FALSE)
+pneumo = transform(pneumo, let = log(exposure.time))
+fit = vglm(cbind(normal, mild, severe) ~ poly(c(scale(let)), 2),
+ fam = multinomial,
+ data = pneumo, trace = TRUE, x = FALSE)
class(fit)
fit at x
model.matrix(fit)
-Check1 = head(model.matrix(fit, type="lm"))
+Check1 = head(model.matrix(fit, type = "lm"))
Check1
-Check2 = model.matrix(fit, data=head(pneumo), type="lm")
+Check2 = model.matrix(fit, data = head(pneumo), type = "lm")
Check2
all.equal(c(Check1), c(Check2))
q0 = head(predict(fit))
-q1 = head(predict(fit, newdata=pneumo))
-q2 = predict(fit, newdata=head(pneumo))
+q1 = head(predict(fit, newdata = pneumo))
+q2 = predict(fit, newdata = head(pneumo))
all.equal(q0, q1) # Should be TRUE
all.equal(q1, q2) # Should be TRUE
}
diff --git a/man/morgenstern.Rd b/man/morgenstern.Rd
index 933ab3d..5ead3a9 100644
--- a/man/morgenstern.Rd
+++ b/man/morgenstern.Rd
@@ -8,20 +8,18 @@
}
\usage{
-morgenstern(lapar="rhobit", earg=list(), iapar=NULL, tola0=0.01,
- imethod=1)
+morgenstern(lapar = "rhobit", earg = list(), iapar = NULL, tola0 = 0.01,
+ imethod = 1)
}
%- maybe also 'usage' for other objects documented here.
\arguments{
- \item{lapar}{
- Link function applied to the association parameter
+ \item{lapar, earg}{
+ Link function
+ and extra argument for the
+ association parameter
\eqn{\alpha}{alpha}, which lies between \eqn{-1} and \eqn{1}.
- See \code{\link{Links}} for more choices.
-
- }
- \item{earg}{
- List. Extra argument for the link.
- See \code{earg} in \code{\link{Links}} for general information.
+ See \code{\link{Links}} for more choices
+ and other information.
}
\item{iapar}{
@@ -64,23 +62,29 @@ morgenstern(lapar="rhobit", earg=list(), iapar=NULL, tola0=0.01,
process since the distribution no longer depends on the
parameter.
+
A variant of Newton-Raphson is used, which only seems to work for an
intercept model.
- It is a very good idea to set \code{trace=TRUE}.
+ It is a very good idea to set \code{trace = TRUE}.
+
}
\value{
An object of class \code{"vglmff"} (see \code{\link{vglmff-class}}).
The object is used by modelling functions such as \code{\link{vglm}}
and \code{\link{vgam}}.
+
+
}
\references{
+
Castillo, E., Hadi, A. S., Balakrishnan, N. Sarabia, J. S. (2005)
\emph{Extreme Value and Related Models with Applications in Engineering and Science},
Hoboken, N.J.: Wiley-Interscience.
+
}
\author{ T. W. Yee }
\note{
@@ -89,21 +93,24 @@ Hoboken, N.J.: Wiley-Interscience.
This is because each marginal distribution corresponds to a
exponential distribution with unit mean.
+
This \pkg{VGAM} family function should be used with caution.
+
}
\seealso{
\code{\link{fgm}},
\code{\link{gumbelIbiv}}.
+
+
}
\examples{
-n = 1000
-ymat = cbind(rexp(n), rexp(n))
+n = 1000; ymat = cbind(rexp(n), rexp(n))
\dontrun{plot(ymat)}
-fit = vglm(ymat ~ 1, fam=morgenstern, trace=TRUE)
-fit = vglm(ymat ~ 1, fam=morgenstern, trace=TRUE, crit="coef")
-coef(fit, matrix=TRUE)
+fit = vglm(ymat ~ 1, fam = morgenstern, trace = TRUE)
+fit = vglm(ymat ~ 1, fam = morgenstern, trace = TRUE, crit = "coef")
+coef(fit, matrix = TRUE)
Coef(fit)
head(fitted(fit))
}
diff --git a/man/multinomial.Rd b/man/multinomial.Rd
index 971ad37..ceecff2 100644
--- a/man/multinomial.Rd
+++ b/man/multinomial.Rd
@@ -219,10 +219,10 @@ coef(fit, matrix = TRUE) }
ycounts = t(rmultinom(10, size = 20, prob = c(0.1, 0.2, 0.8))) # Counts
fit = vglm(ycounts ~ 1, multinomial)
head(fitted(fit)) # Proportions
-fit at prior.weights # Not recommended for extraction of prior weights
+fit at prior.weights # NOT recommended for extraction of prior weights
weights(fit, type = "prior", matrix = FALSE) # The better method
-fit at y # Sample proportions
-constraints(fit) # Constraint matrices
+depvar(fit) # Sample proportions; same as fit at y
+constraints(fit) # Constraint matrices
# Example 2b: Different reference level used as the baseline
fit2 = vglm(ycounts ~ 1, multinomial(refLevel = 2))
diff --git a/man/nakagami.Rd b/man/nakagami.Rd
index 0f2e2ef..61beee0 100644
--- a/man/nakagami.Rd
+++ b/man/nakagami.Rd
@@ -9,20 +9,18 @@
}
\usage{
nakagami(lshape = "loge", lscale = "loge",
- eshape=list(), escale=list(), ishape = NULL, iscale = 1)
+ eshape = list(), escale = list(),
+ ishape = NULL, iscale = 1)
}
%- maybe also 'usage' for other objects documented here.
\arguments{
- \item{lshape, lscale}{
- Parameter link function applied to the
+ \item{lshape, lscale, eshape, escale}{
+ Parameter link functions and extra arguments
+ applied to the
\emph{shape} and \emph{scale} parameters.
Log links ensure they are positive.
- See \code{\link{Links}} for more choices.
-
- }
- \item{eshape, escale}{
- List. Extra argument for each of the links.
- See \code{earg} in \code{\link{Links}} for general information.
+ See \code{\link{Links}} for more choices
+ and information.
}
\item{ishape, iscale}{
@@ -53,14 +51,17 @@ nakagami(lshape = "loge", lscale = "loge",
\eqn{\eta_2=\log(scale)}{eta2=log(scale)}.
Fisher scoring is implemented.
+
}
\value{
An object of class \code{"vglmff"} (see \code{\link{vglmff-class}}).
The object is used by modelling functions such as \code{\link{vglm}},
and \code{\link{vgam}}.
+
}
\references{
+
Nakagami, M. (1960)
The \emph{m}-distribution: a general formula of
intensity distribution of rapid fading,
@@ -68,6 +69,7 @@ nakagami(lshape = "loge", lscale = "loge",
\emph{Statistical Methods in Radio Wave Propagation}.
W. C. Hoffman, Ed., New York: Pergamon.
+
}
\author{ T. W. Yee }
\note{
@@ -77,31 +79,34 @@ nakagami(lshape = "loge", lscale = "loge",
distribution and \eqn{m=1} is a Rayleigh distribution.
The second moment is \eqn{E(Y^2)=m}.
+
If \eqn{Y} has a Nakagami distribution with parameters \emph{shape}
and \emph{scale} then \eqn{Y^2} has a gamma distribution with shape
parameter \emph{shape} and scale parameter \emph{scale/shape}.
+
}
\seealso{
\code{\link{rnaka}},
\code{\link{gamma2}},
\code{\link{rayleigh}}.
+
+
}
\examples{
-n = 1000; shape = exp(0); Scale = exp(1)
-y = sqrt(rgamma(n, shape=shape, scale=Scale/shape))
-fit = vglm(y ~ 1, nakagami, trace=TRUE, crit="c")
-y = rnaka(n, shape=shape, scale=Scale)
-fit = vglm(y ~ 1, nakagami(iscale=3), trace=TRUE)
+nn = 1000; shape = exp(0); Scale = exp(1)
+ndata = data.frame(y1 = sqrt(rgamma(nn, shape = shape, scale = Scale/shape)))
+fit = vglm(y1 ~ 1, nakagami, ndata, trace = TRUE, crit = "c")
+ndata = transform(ndata, y2 = rnaka(nn, shape = shape, scale = Scale))
+fit = vglm(y2 ~ 1, nakagami(iscale = 3), ndata, trace = TRUE)
head(fitted(fit))
-mean(y)
-coef(fit, matrix=TRUE)
+with(ndata, mean(y2))
+coef(fit, matrix = TRUE)
(Cfit = Coef(fit))
-\dontrun{
-hist(sy <- sort(y), prob=TRUE, main="", xlab="y", ylim=c(0,0.6))
-lines(sy, dnaka(sy, shape=Cfit[1], scale=Cfit[2]), col="red")
-}
+\dontrun{ with(ndata,
+hist(sy <- sort(y2), prob = TRUE, main = "", xlab = "y", ylim = c(0, 0.6)))
+lines(dnaka(sy, shape = Cfit[1], scale = Cfit[2]) ~ sy, ndata, col = "orange") }
}
\keyword{models}
\keyword{regression}
diff --git a/man/nakagamiUC.Rd b/man/nakagamiUC.Rd
index 46c7add..88666b8 100644
--- a/man/nakagamiUC.Rd
+++ b/man/nakagamiUC.Rd
@@ -12,10 +12,10 @@
}
\usage{
-dnaka(x, shape, scale=1, log = FALSE)
-pnaka(q, shape, scale=1)
-qnaka(p, shape, scale=1, ...)
-rnaka(n, shape, scale=1, Smallno=1.0e-6)
+dnaka(x, shape, scale = 1, log = FALSE)
+pnaka(q, shape, scale = 1)
+qnaka(p, shape, scale = 1, ...)
+rnaka(n, shape, scale = 1, Smallno = 1.0e-6)
}
\arguments{
\item{x, q}{vector of quantiles.}
@@ -41,7 +41,7 @@ rnaka(n, shape, scale=1, Smallno=1.0e-6)
}
\item{log}{
Logical.
- If \code{log=TRUE} then the logarithm of the density is returned.
+ If \code{log = TRUE} then the logarithm of the density is returned.
}
}
@@ -50,11 +50,13 @@ rnaka(n, shape, scale=1, Smallno=1.0e-6)
\code{pnaka} gives the cumulative distribution function,
\code{qnaka} gives the quantile function, and
\code{rnaka} generates random deviates.
+
}
\author{ T. W. Yee }
\details{
See \code{\link{nakagami}} for more details.
+
}
%\note{
%
@@ -62,29 +64,28 @@ rnaka(n, shape, scale=1, Smallno=1.0e-6)
\seealso{
\code{\link{nakagami}}.
+
}
\examples{
-\dontrun{
-x = seq(0, 3.2, len=200)
-plot(x, dgamma(x, shape=1), type="n", col="black", ylab="",
- ylim=c(0,1.5), main="dnaka(x, shape)")
-lines(x, dnaka(x, shape=1), col="red")
-lines(x, dnaka(x, shape=2), col="blue")
-lines(x, dnaka(x, shape=3), col="green")
-legend(2, 1.0, col=c("red","blue","green"), lty=rep(1, len=3),
- legend=paste("shape =", c(1, 2, 3)))
+\dontrun{ x = seq(0, 3.2, len = 200)
+plot(x, dgamma(x, shape = 1), type = "n", col = "black", ylab = "",
+ ylim = c(0,1.5), main = "dnaka(x, shape)")
+lines(x, dnaka(x, shape = 1), col = "orange")
+lines(x, dnaka(x, shape = 2), col = "blue")
+lines(x, dnaka(x, shape = 3), col = "green")
+legend(2, 1.0, col = c("orange","blue","green"), lty = rep(1, len = 3),
+ legend = paste("shape =", c(1, 2, 3)))
-plot(x, pnorm(x), type="n", col="black", ylab="",
- ylim=0:1, main="pnaka(x, shape)")
-lines(x, pnaka(x, shape=1), col="red")
-lines(x, pnaka(x, shape=2), col="blue")
-lines(x, pnaka(x, shape=3), col="green")
-legend(2, 0.6, col=c("red","blue","green"), lty=rep(1, len=3),
- legend=paste("shape =", c(1, 2, 3)))
-}
+plot(x, pnorm(x), type = "n", col = "black", ylab = "",
+ ylim = 0:1, main = "pnaka(x, shape)")
+lines(x, pnaka(x, shape = 1), col = "orange")
+lines(x, pnaka(x, shape = 2), col = "blue")
+lines(x, pnaka(x, shape = 3), col = "green")
+legend(2, 0.6, col = c("orange","blue","green"), lty = rep(1, len = 3),
+ legend = paste("shape =", c(1, 2, 3))) }
-probs = seq(0.1, 0.9, by=0.1)
-pnaka(qnaka(p=probs, shape=2), shape=2) - probs # Should be all 0
+probs = seq(0.1, 0.9, by = 0.1)
+pnaka(qnaka(p = probs, shape = 2), shape = 2) - probs # Should be all 0
}
\keyword{distribution}
diff --git a/man/nbolf.Rd b/man/nbolf.Rd
index 8e9822f..54f79b7 100644
--- a/man/nbolf.Rd
+++ b/man/nbolf.Rd
@@ -8,8 +8,8 @@
}
\usage{
-nbolf(theta, earg = stop("'earg' must be given"), inverse = FALSE,
- deriv = 0, short = TRUE, tag = FALSE)
+nbolf(theta, earg = stop("argument 'earg' must be given"),
+ inverse = FALSE, deriv = 0, short = TRUE, tag = FALSE)
}
%- maybe also 'usage' for other objects documented here.
\arguments{
@@ -27,7 +27,7 @@ nbolf(theta, earg = stop("'earg' must be given"), inverse = FALSE,
The cutpoints should be non-negative integers.
If \code{nbolf()} is used as the link function in
\code{\link{cumulative}} then one should choose
- \code{reverse=TRUE, parallel=TRUE, intercept.apply=TRUE}.
+ \code{reverse = TRUE, parallel = TRUE, intercept.apply = TRUE}.
}
\item{inverse}{
@@ -57,22 +57,27 @@ nbolf(theta, earg = stop("'earg' must be given"), inverse = FALSE,
an ordinal response coming from an underlying negative binomial
distribution.
+
The arguments \code{short} and \code{tag} are used only if
\code{theta} is character.
+
See \code{\link{Links}} for general information about \pkg{VGAM}
link functions.
+
}
\value{
- See Yee (2007) for details.
+ See Yee (2011) for details.
+
}
\references{
- Yee, T. W. (2007)
+ Yee, T. W. (2011)
\emph{Ordinal ordination with normalizing link functions for count data},
(in preparation).
+
}
\author{ Thomas W. Yee }
@@ -84,16 +89,19 @@ nbolf(theta, earg = stop("'earg' must be given"), inverse = FALSE,
\code{theta} is too close to 1 or 0,
numerical instabilities may still arise.
+
In terms of the threshold approach with cumulative probabilities for
an ordinal response this link function corresponds to the negative
binomial distribution (see \code{\link{negbinomial}}) that has been
recorded as an ordinal response using known cutpoints.
+
}
\section{Warning }{
Prediction may not work on \code{\link{vglm}} or
\code{\link{vgam}} etc. objects if this link function is used.
+
}
\seealso{
@@ -104,25 +112,24 @@ nbolf(theta, earg = stop("'earg' must be given"), inverse = FALSE,
\code{nbolf2},
\code{\link{cumulative}}.
+
}
\examples{
-earg = list(cutpoint=2, k=1)
-nbolf("p", earg=earg, short=FALSE)
-nbolf("p", earg=earg, tag=TRUE)
-
-p = seq(0.02, 0.98, by=0.01)
-y = nbolf(p, earg=earg)
-y. = nbolf(p, earg=earg, deriv=1)
-max(abs(nbolf(y, earg=earg, inv=TRUE) - p)) # Should be 0
-
-\dontrun{
-par(mfrow=c(2,1), las=1)
-plot(p, y, type="l", col="blue", main="nbolf()")
-abline(h=0, v=0.5, col="red", lty="dashed")
-
-plot(p, y., type="l", col="blue",
- main="(Reciprocal of) first NBOLF derivative")
-}
+earg = list(cutpoint = 2, k = 1)
+nbolf("p", earg = earg, short = FALSE)
+nbolf("p", earg = earg, tag = TRUE)
+
+p = seq(0.02, 0.98, by = 0.01)
+y = nbolf(p, earg = earg)
+y. = nbolf(p, earg = earg, deriv = 1)
+max(abs(nbolf(y, earg = earg, inv = TRUE) - p)) # Should be 0
+
+\dontrun{ par(mfrow = c(2, 1), las = 1)
+plot(p, y, type = "l", col = "blue", main = "nbolf()")
+abline(h = 0, v = 0.5, col = "red", lty = "dashed")
+
+plot(p, y., type = "l", col = "blue",
+ main = "(Reciprocal of) first NBOLF derivative") }
# Another example
nn = 1000
@@ -130,22 +137,20 @@ x2 = sort(runif(nn))
x3 = runif(nn)
mymu = exp( 3 + 1 * x2 - 2 * x3)
k = 4
-y1 = rnbinom(nn, mu=mymu, size=k)
+y1 = rnbinom(nn, mu = mymu, size = k)
cutpoints = c(-Inf, 10, 20, Inf)
-cuty = Cut(y1, breaks=cutpoints)
-\dontrun{
-plot(x2, x3, col=cuty, pch=as.character(cuty))
-}
+cuty = Cut(y1, breaks = cutpoints)
+\dontrun{ plot(x2, x3, col = cuty, pch = as.character(cuty)) }
table(cuty) / sum(table(cuty))
-fit = vglm(cuty ~ x2 + x3, fam = cumulative(link="nbolf",
- reverse=TRUE, parallel=TRUE, intercept.apply=TRUE,
- mv=TRUE, earg=list(cutpoint=cutpoints[2:3], k=k)),
- trace=TRUE)
+fit = vglm(cuty ~ x2 + x3, fam = cumulative(link = "nbolf",
+ reverse = TRUE, parallel = TRUE, intercept.apply = TRUE,
+ mv = TRUE, earg = list(cutpoint = cutpoints[2:3], k = k)),
+ trace = TRUE)
head(fit at y)
head(fitted(fit))
head(predict(fit))
coef(fit)
-coef(fit, matrix=TRUE)
+coef(fit, matrix = TRUE)
constraints(fit)
fit at misc$earg
}
diff --git a/man/normal1.Rd b/man/normal1.Rd
index 0d7ca5a..7fd761c 100644
--- a/man/normal1.Rd
+++ b/man/normal1.Rd
@@ -50,9 +50,11 @@ normal1(lmean = "identity", lsd = "loge",
}
\references{
-Evans, M., Hastings, N. and Peacock, B. (2000)
-\emph{Statistical Distributions},
-New York: Wiley-Interscience, Third edition.
+
+ Evans, M., Hastings, N. and Peacock, B. (2000)
+ \emph{Statistical Distributions},
+ New York: Wiley-Interscience, Third edition.
+
}
@@ -62,11 +64,13 @@ New York: Wiley-Interscience, Third edition.
standard devations to be the same.
And a \code{parallel} argument.
+
}
\seealso{
\code{\link{gaussianff}},
\code{\link{posnormal1}},
\code{\link{mix2normal1}},
+ \code{\link{Qvar}},
\code{\link{tobit}},
\code{\link{cennormal1}},
\code{\link{fnormal1}},
@@ -77,6 +81,7 @@ New York: Wiley-Interscience, Third edition.
\code{\link{binormal}},
\code{\link[stats:Normal]{dnorm}}.
+
}
\examples{
ndata <- data.frame(x2 = rnorm(nn <- 200))
diff --git a/man/notdocumentedyet.Rd b/man/notdocumentedyet.Rd
index 589a95f..ed93c06 100644
--- a/man/notdocumentedyet.Rd
+++ b/man/notdocumentedyet.Rd
@@ -38,6 +38,9 @@
%\alias{Rcam} % Has been written
%\alias{plotrcam0} % Has been written
%\alias{moffset} % Has been written
+% \alias{Qvar}
+\alias{plotqvar}
+\alias{depvar.vlm}
%
%
%
@@ -88,6 +91,7 @@
\alias{Tol.qrrvglm}
\alias{Tol.uqo}
\alias{a2m}
+\alias{abbott}
% \alias{acat.deriv}
% \alias{add.arg}
% \alias{add.constraints}
@@ -177,6 +181,7 @@
% \alias{eij}
\alias{erfc}
\alias{eta2theta}
+%\alias{explink}
% \alias{extract.arg}
\alias{family.vglm}
%\alias{felix}
@@ -269,6 +274,14 @@
% \alias{new.assign}
\alias{nlminbcontrol}
\alias{nbolf2}
+\alias{nobs.vlm}
+\alias{nvar}
+\alias{nvar.vlm}
+\alias{nvar.vgam}
+\alias{nvar.rrvglm}
+\alias{nvar.qrrvglm}
+\alias{nvar.cao}
+\alias{nvar.rcam}
\alias{ns}
% \alias{num.deriv.rrr}
\alias{persp}
@@ -286,7 +299,7 @@
\alias{predict.glm}
\alias{predict.lm}
\alias{predict.mlm}
-% \alias{predict.qrrvglm}
+% \alias{predictqrrvglm}
\alias{predict.rrvglm}
\alias{predict.uqo}
\alias{predict.vgam}
@@ -327,6 +340,7 @@
% \alias{process.constraints}
% \alias{proj.vgam}
% \alias{proj.vglm}
+\alias{put.caption}
% \alias{pweights}
% \alias{qrrvglm.xprod}
\alias{qtplot}
@@ -485,7 +499,7 @@
}
%\usage{
-%normal1(lmean="identity", lsd="loge", zero=NULL)
+%normal1(lmean = "identity", lsd = "loge", zero = NULL)
%}
%- maybe also 'usage' for other objects documented here.
%\arguments{
diff --git a/man/nzc.Rd b/man/nzc.Rd
index 3da9366..20f6724 100644
--- a/man/nzc.Rd
+++ b/man/nzc.Rd
@@ -5,6 +5,7 @@
\description{
The Chinese population in New Zealand from 1867 to 2001,
along with the whole of the New Zealand population.
+
}
\usage{data(nzc)}
\format{
@@ -19,25 +20,28 @@
\details{
The NZ total for the years 1867 and 1871 exclude the Maori population.
The second value of 4583 looks erroneous, as seen by the plot below.
+
+
}
%\source{
%}
\references{
+
Page 6 of \emph{Aliens At My Table: Asians as New Zealanders see them}
by M. Ip and N. Murphy,
(2005), Penguin.
+
+
}
\examples{
-\dontrun{
-with(nzc, plot(year, female/(male+female), type="b", ylab="Proportion",
- main="Proportion of NZ Chinese that are female",
- col="blue", las=1))
-abline(h=0.5, lty="dashed")
+\dontrun{ plot(female/(male+female) ~ year, nzc, type = "b",
+ ylab = "Proportion", col = "blue", las = 1,
+ main = "Proportion of NZ Chinese that are female")
+abline(h = 0.5, lty = "dashed")
-with(nzc, plot(year, 100*(male+female)/nz, type="b", ylab="Percent",
- ylim=c(0, max(100*(male+female)/nz)), col="blue", las=1,
- main="Percent of NZers that are Chinese"))
-abline(h=0, lty="dashed")
-}
+plot(100*(male+female)/nz ~ year, nzc, type = "b", ylab = "Percent",
+ ylim = c(0, max(100*(male+female)/nz)), col = "blue", las = 1,
+ main = "Percent of NZers that are Chinese")
+abline(h = 0, lty = "dashed") }
}
\keyword{datasets}
diff --git a/man/nzmarital.Rd b/man/nzmarital.Rd
index 3e00ab7..7f998cc 100644
--- a/man/nzmarital.Rd
+++ b/man/nzmarital.Rd
@@ -32,13 +32,18 @@ study consisting of retirees. The data can be considered a reasonable
representation of the white male New Zealand population in the early
1990s.
+
}
\source{
Clinical Trials Research Unit, University of Auckland, New Zealand.
+
+
}
\references{
See \code{\link{bminz}} and \code{\link{chestnz}}.
+
+
}
\examples{
summary(nzmarital)
diff --git a/man/olympic.Rd b/man/olympic.Rd
index 354c045..c85c0ae 100644
--- a/man/olympic.Rd
+++ b/man/olympic.Rd
@@ -6,6 +6,7 @@
Final count of medal winners by country for the 2008 Summer Olympic
games in Beijing.
+
}
\usage{data(olympic)}
\format{
@@ -22,11 +23,12 @@
\details{
The event was held during August 8--24, 2008, in Beijing.
+
% This is a simple two-way contingency table of counts.
}
\source{
- \url{http://www.associatedcontent.com/article/979484/2008_summer_olympic_medal_count_total.html}.
+\url{http://www.associatedcontent.com/article/979484/2008_summer_olympic_medal_count_total.html}.
}
\references{
@@ -37,19 +39,18 @@
\seealso{
\code{\link{grc}}.
+
}
\examples{
summary(olympic)
## maybe str(olympic) ; plot(olympic) ...
-\dontrun{
-with(head(olympic, n=8),
- barplot(rbind(gold,silver,bronze),
- col=c("gold","grey","brown"), # No "silver" or "bronze"!
- names.arg=country, cex.names=0.5,
- beside=TRUE, main="2008 Summer Olympic Final Medal Count",
- ylab="Medal count", las=1,
- sub="Top 8 countries; 'gold'=gold, 'grey'=silver, 'brown'=bronze"))
-}
+\dontrun{ with(head(olympic, n = 8),
+barplot(rbind(gold,silver,bronze),
+ col = c("gold","grey","brown"), # No "silver" or "bronze"!
+ names.arg = country, cex.names = 0.5,
+ beside = TRUE, main = "2008 Summer Olympic Final Medal Count",
+ ylab = "Medal count", las = 1,
+ sub = "Top 8 countries; 'gold'=gold, 'grey'=silver, 'brown'=bronze")) }
}
\keyword{datasets}
diff --git a/man/ordpoisson.Rd b/man/ordpoisson.Rd
index f0b9ae9..4e70a9b 100644
--- a/man/ordpoisson.Rd
+++ b/man/ordpoisson.Rd
@@ -8,9 +8,9 @@
}
\usage{
-ordpoisson(cutpoints, countdata=FALSE, NOS=NULL,
- Levels=NULL, init.mu=NULL, parallel=FALSE,
- zero=NULL, link="loge", earg = list())
+ordpoisson(cutpoints, countdata = FALSE, NOS = NULL,
+ Levels = NULL, init.mu = NULL, parallel = FALSE,
+ zero = NULL, link = "loge", earg = list())
}
%- maybe also 'usage' for other objects documented here.
\arguments{
@@ -30,21 +30,21 @@ ordpoisson(cutpoints, countdata=FALSE, NOS=NULL,
the response is expected to be in the same format as \code{fit at y}
where \code{fit} is a fitted model with \code{ordpoisson} as the
\pkg{VGAM} family function. That is, the response is matrix of counts
- with \code{L} columns (if \code{NOS=1}).
+ with \code{L} columns (if \code{NOS = 1}).
}
\item{NOS}{
Integer. The number of species, or more generally, the number of
response random variates.
- This argument must be specified when \code{countdata=TRUE}.
- Usually \code{NOS=1}.
+ This argument must be specified when \code{countdata = TRUE}.
+ Usually \code{NOS = 1}.
}
\item{Levels}{
Integer vector, recycled to length \code{NOS} if necessary.
The number of levels for each response random variate.
This argument should agree with \code{cutpoints}.
- This argument must be specified when \code{countdata=TRUE}.
+ This argument must be specified when \code{countdata = TRUE}.
}
\item{init.mu}{
@@ -75,6 +75,7 @@ ordpoisson(cutpoints, countdata=FALSE, NOS=NULL,
The response for this family function corresponds to \eqn{Y^*} but
we are really interested in the Poisson regression of \eqn{Y}.
+
If \code{NOS=1} then
the argument \code{cutpoints} is a vector \eqn{(K_1,K_2,\ldots,K_L)}
where the last value (\code{Inf}) is optional. If \code{NOS>1} then
@@ -84,18 +85,23 @@ ordpoisson(cutpoints, countdata=FALSE, NOS=NULL,
\code{ordpoisson(cut = c(0, 5, 10, Inf, 20, 30, Inf, 0, 10, 40, Inf))}
is valid.
+
}
\value{
An object of class \code{"vglmff"} (see \code{\link{vglmff-class}}).
The object is used by modelling functions such as \code{\link{vglm}}
and \code{\link{vgam}}.
+
}
\references{
- Yee, T. W. (2007)
+
+
+ Yee, T. W. (2011)
\emph{Ordinal ordination with normalizing link functions for count data},
(in preparation).
+
}
\author{ Thomas W. Yee }
@@ -104,12 +110,14 @@ ordpoisson(cutpoints, countdata=FALSE, NOS=NULL,
the arguments \code{Levels} and \code{NOS} need to be specified too.
See below for an example.
+
}
\section{Warning }{
The input requires care as little to no checking is done.
If \code{fit} is the fitted object, have a look at \code{fit at extra} and
\code{fit at y} to check.
+
}
\seealso{
@@ -117,38 +125,38 @@ ordpoisson(cutpoints, countdata=FALSE, NOS=NULL,
\code{\link{polf}},
\code{\link[base:factor]{ordered}}.
+
}
\examples{
-# Example 1
-set.seed(123)
+set.seed(123) # Example 1
x2 = runif(n <- 1000); x3 = runif(n)
mymu = exp(3 - 1 * x2 + 2 * x3)
-y1 = rpois(n, lambda=mymu)
+y1 = rpois(n, lambda = mymu)
cutpts = c(-Inf, 20, 30, Inf)
fcutpts = cutpts[is.finite(cutpts)] # finite cutpoints
-ystar = cut(y1, breaks=cutpts, labels=FALSE)
+ystar = cut(y1, breaks = cutpts, labels = FALSE)
\dontrun{
-plot(x2, x3, col=ystar, pch=as.character(ystar))
+plot(x2, x3, col = ystar, pch = as.character(ystar))
}
table(ystar) / sum(table(ystar))
-fit = vglm(ystar ~ x2 + x3, fam = ordpoisson(cutpoi=fcutpts))
-head(fit at y) # This can be input if countdata=TRUE
+fit = vglm(ystar ~ x2 + x3, fam = ordpoisson(cutpoi = fcutpts))
+head(fit at y) # This can be input if countdata = TRUE
head(fitted(fit))
head(predict(fit))
-coef(fit, matrix=TRUE)
+coef(fit, matrix = TRUE)
fit at extra
# Example 2: multivariate and there are no obsns between some cutpoints
cutpts2 = c(-Inf, 0, 9, 10, 20, 70, 200, 201, Inf)
fcutpts2 = cutpts2[is.finite(cutpts2)] # finite cutpoints
-y2 = rpois(n, lambda=mymu) # Same model as y1
-ystar2 = cut(y2, breaks=cutpts2, labels=FALSE)
+y2 = rpois(n, lambda = mymu) # Same model as y1
+ystar2 = cut(y2, breaks = cutpts2, labels = FALSE)
table(ystar2) / sum(table(ystar2))
fit = vglm(cbind(ystar,ystar2) ~ x2 + x3, fam =
- ordpoisson(cutpoi=c(fcutpts,Inf,fcutpts2,Inf),
- Levels=c(length(fcutpts)+1,length(fcutpts2)+1),
- parallel=TRUE), trace=TRUE)
-coef(fit, matrix=TRUE)
+ ordpoisson(cutpoi = c(fcutpts,Inf,fcutpts2,Inf),
+ Levels = c(length(fcutpts)+1,length(fcutpts2)+1),
+ parallel = TRUE), trace = TRUE)
+coef(fit, matrix = TRUE)
fit at extra
constraints(fit)
summary(fit at y) # Some columns have all zeros
diff --git a/man/oxtemp.Rd b/man/oxtemp.Rd
index c581990..c59c342 100644
--- a/man/oxtemp.Rd
+++ b/man/oxtemp.Rd
@@ -15,15 +15,19 @@
}
\details{
The data were collected from 1901 to 1980.
+
+
}
% zz:
\source{
Unknown.
+
+
}
% \references{
% }
\examples{
-fit = vglm(maxtemp ~ 1, egev, trace=TRUE, data=oxtemp)
+fit = vglm(maxtemp ~ 1, egev, data = oxtemp, trace = TRUE)
}
\keyword{datasets}
diff --git a/man/paralogistic.Rd b/man/paralogistic.Rd
index b5d8a33..55b0642 100644
--- a/man/paralogistic.Rd
+++ b/man/paralogistic.Rd
@@ -7,8 +7,8 @@
paralogistic distribution.
}
\usage{
-paralogistic(link.a = "loge", link.scale = "loge", earg.a=list(),
- earg.scale=list(), init.a = 1, init.scale = NULL, zero = NULL)
+paralogistic(link.a = "loge", link.scale = "loge", earg.a = list(),
+ earg.scale = list(), init.a = 1, init.scale = NULL, zero = NULL)
}
%- maybe also 'usage' for other objects documented here.
\arguments{
@@ -62,13 +62,15 @@ provided \eqn{a > 1}.
The object is used by modelling functions such as \code{\link{vglm}},
and \code{\link{vgam}}.
+
}
\references{
+
Kleiber, C. and Kotz, S. (2003)
-\emph{Statistical Size Distributions in Economics and
- Actuarial Sciences},
+\emph{Statistical Size Distributions in Economics and Actuarial Sciences},
Hoboken, NJ: Wiley-Interscience.
+
}
\author{ T. W. Yee }
@@ -77,6 +79,7 @@ If the self-starting initial values fail, try experimenting
with the initial value arguments, especially those whose
default value is not \code{NULL}.
+
}
\seealso{
@@ -92,11 +95,11 @@ default value is not \code{NULL}.
}
\examples{
-pdat = data.frame(y = rparalogistic(n=3000, 4, 6))
-fit = vglm(y ~ 1, paralogistic, pdat, trace=TRUE)
-fit = vglm(y ~ 1, paralogistic(init.a=2.3, init.sc=5),
- pdat, trace=TRUE, crit="c")
-coef(fit, mat=TRUE)
+pdat = data.frame(y = rparalogistic(n = 3000, 4, 6))
+fit = vglm(y ~ 1, paralogistic, pdat, trace = TRUE)
+fit = vglm(y ~ 1, paralogistic(init.a = 2.3, init.sc = 5),
+ pdat, trace = TRUE, crit = "c")
+coef(fit, matrix = TRUE)
Coef(fit)
summary(fit)
}
diff --git a/man/paretoIV.Rd b/man/paretoIV.Rd
index d060f73..56cdcb3 100644
--- a/man/paretoIV.Rd
+++ b/man/paretoIV.Rd
@@ -11,15 +11,15 @@
}
\usage{
-paretoIV(location=0, lscale="loge", linequality="loge", lshape="loge",
- escale=list(), einequality=list(), eshape=list(),
- iscale=1, iinequality=1, ishape=NULL, imethod=1)
-paretoIII(location=0, lscale="loge", linequality="loge",
- escale=list(), einequality=list(),
- iscale=NULL, iinequality=NULL)
-paretoII(location=0, lscale="loge", lshape="loge",
- escale=list(), eshape=list(),
- iscale=NULL, ishape=NULL)
+paretoIV(location = 0, lscale = "loge", linequality = "loge", lshape = "loge",
+ escale = list(), einequality = list(), eshape = list(),
+ iscale = 1, iinequality = 1, ishape = NULL, imethod = 1)
+paretoIII(location = 0, lscale = "loge", linequality = "loge",
+ escale = list(), einequality = list(),
+ iscale = NULL, iinequality = NULL)
+paretoII(location = 0, lscale = "loge", lshape = "loge",
+ escale = list(), eshape = list(),
+ iscale = NULL, ishape = NULL)
}
%- maybe also 'usage' for other objects documented here.
\arguments{
@@ -124,6 +124,7 @@ paretoII(location=0, lscale="loge", lshape="loge",
}
\references{
+
Brazauskas, V. (2003)
Information matrix for Pareto(IV), Burr, and related distributions.
\emph{Comm.\ Statist.\ Theory and Methods}
@@ -161,10 +162,10 @@ Fairland, Maryland: International Cooperative Publishing House.
}
\examples{
-pdat = data.frame(y=rparetoIV(2000, scal=exp(1), ineq=exp(-0.3), shap=exp(1)))
-\dontrun{par(mfrow=c(2,1)); with(pdat, hist(y)); with(pdat, hist(log(y))) }
-fit = vglm(y ~ 1, paretoIV, pdat, trace=TRUE)
-coef(fit, matrix=TRUE)
+pdat = data.frame(y = rparetoIV(2000, scal = exp(1), ineq = exp(-0.3), shap = exp(1)))
+\dontrun{par(mfrow = c(2,1)); with(pdat, hist(y)); with(pdat, hist(log(y))) }
+fit = vglm(y ~ 1, paretoIV, pdat, trace = TRUE)
+coef(fit, matrix = TRUE)
Coef(fit)
summary(fit)
}
diff --git a/man/persp.qrrvglm.Rd b/man/persp.qrrvglm.Rd
index b087408..ffc8493 100644
--- a/man/persp.qrrvglm.Rd
+++ b/man/persp.qrrvglm.Rd
@@ -1,5 +1,5 @@
-\name{persp.qrrvglm}
-\alias{persp.qrrvglm}
+\name{perspqrrvglm}
+\alias{perspqrrvglm}
%- Also NEED an '\alias' for EACH other topic documented here.
\title{ Perspective plot for QRR-VGLMs }
\description{
@@ -8,16 +8,16 @@ applicable for rank-1 or rank-2 models with argument \code{Norrr = ~ 1}.
}
\usage{
-persp.qrrvglm(x, varlvI = FALSE, reference = NULL, plot.it = TRUE,
- xlim=NULL, ylim=NULL, zlim=NULL,
- gridlength = if (Rank==1) 301 else c(51,51),
+perspqrrvglm(x, varlvI = FALSE, reference = NULL, plot.it = TRUE,
+ xlim = NULL, ylim = NULL, zlim = NULL,
+ gridlength = if (Rank == 1) 301 else c(51,51),
whichSpecies = NULL,
- xlab = if (Rank==1) "Latent Variable" else "Latent Variable 1",
- ylab = if (Rank==1) "Expected Value" else "Latent Variable 2",
+ xlab = if (Rank == 1) "Latent Variable" else "Latent Variable 1",
+ ylab = if (Rank == 1) "Expected Value" else "Latent Variable 2",
zlab = "Expected value", labelSpecies = FALSE,
- stretch = 1.05, main="", ticktype = "detailed",
- col = if (Rank==1) par()$col else "white",
- llty=par()$lty, llwd=par()$lwd,
+ stretch = 1.05, main = "", ticktype = "detailed",
+ col = if (Rank == 1) par()$col else "white",
+ llty = par()$lty, llwd = par()$lwd,
add1 = FALSE, ...)
}
%- maybe also 'usage' for other objects documented here.
@@ -49,7 +49,7 @@ persp.qrrvglm(x, varlvI = FALSE, reference = NULL, plot.it = TRUE,
}
\item{gridlength}{
Numeric. The fitted values are evaluated on a grid, and this
- argument regulates the fineness of the grid. If \code{Rank=2}
+ argument regulates the fineness of the grid. If \code{Rank = 2}
then the argument is recycled to length 2, and the two numbers
are the number of grid points on the x- and y-axes respectively.
@@ -68,7 +68,7 @@ persp.qrrvglm(x, varlvI = FALSE, reference = NULL, plot.it = TRUE,
}
\item{zlab}{Character caption for the z-axis.
- Used only if \code{Rank=2}.
+ Used only if \code{Rank = 2}.
By default, a suitable caption is found.
See the \code{xlab} argument in \code{\link[graphics]{plot}}
or \code{\link[graphics]{title}}.
@@ -76,13 +76,13 @@ persp.qrrvglm(x, varlvI = FALSE, reference = NULL, plot.it = TRUE,
}
\item{labelSpecies}{Logical.
Whether the species should be labelled with their names.
- Used for \code{Rank=1} only.
+ Used for \code{Rank = 1} only.
The position of the label is just above the species' maximum.
}
\item{stretch}{
Numeric. A value slightly more than 1, this argument
- adjusts the height of the y-axis. Used for \code{Rank=1} only.
+ adjusts the height of the y-axis. Used for \code{Rank = 1} only.
}
\item{main}{
@@ -91,7 +91,7 @@ persp.qrrvglm(x, varlvI = FALSE, reference = NULL, plot.it = TRUE,
or \code{\link[graphics]{title}}.
}
- \item{ticktype}{ Tick type. Used only if \code{Rank=2}.
+ \item{ticktype}{ Tick type. Used only if \code{Rank = 2}.
See \code{\link[graphics]{persp}} for more information.
}
@@ -208,13 +208,13 @@ sort(r1 at misc$deviance.Bestof) # A history of the fits
sort(r2 at misc$deviance.Bestof) # A history of the fits
if (deviance(r2) > 857) stop("suboptimal fit obtained")
-persp(r1, xlim=c(-6,5), col=1:4, label=TRUE)
+persp(r1, xlim = c(-6,5), col = 1:4, label = TRUE)
# Involves all species
-persp(r2, xlim=c(-6,5), ylim=c(-4,5), theta=10, phi=20, zlim=c(0,220))
+persp(r2, xlim = c(-6,5), ylim = c(-4,5), theta = 10, phi = 20, zlim = c(0,220))
# Omit the two dominant species to see what's behind them
-persp(r2, xlim=c(-6,5), ylim=c(-4,5), theta=10, phi=20, zlim=c(0,220),
- which=(1:10)[-c(8,10)]) # Use zlim to retain the original z-scale
+persp(r2, xlim = c(-6,5), ylim = c(-4,5), theta = 10, phi = 20, zlim = c(0,220),
+ which = (1:10)[-c(8,10)]) # Use zlim to retain the original z-scale
}
}
\keyword{models}
diff --git a/man/plackUC.Rd b/man/plackUC.Rd
index 25dec0a..a146720 100644
--- a/man/plackUC.Rd
+++ b/man/plackUC.Rd
@@ -10,7 +10,7 @@
}
\usage{
-dplack(x1, x2, oratio, log=FALSE)
+dplack(x1, x2, oratio, log = FALSE)
pplack(q1, q2, oratio)
rplack(n, oratio)
}
@@ -29,14 +29,18 @@ rplack(n, oratio)
\code{dplack} gives the density,
\code{pplack} gives the distribution function, and
\code{rplack} generates random deviates (a two-column matrix).
+
+
}
\references{
+
Mardia, K. V. (1967)
Some contributions to contingency-type distributions.
\emph{Biometrika},
\bold{54}, 235--249.
+
}
\author{ T. W. Yee }
\details{
@@ -45,6 +49,7 @@ Some contributions to contingency-type distributions.
parameter by maximum likelihood estimation, for the formula of the
cumulative distribution function and other details.
+
}
%\note{
%}
@@ -52,19 +57,19 @@ Some contributions to contingency-type distributions.
\code{\link{plackett}},
\code{\link{frank}}.
+
}
\examples{
-\dontrun{
-N = 101; oratio = exp(1)
-x = seq(0.0, 1.0, len=N)
+\dontrun{ N = 101; oratio = exp(1)
+x = seq(0.0, 1.0, len = N)
ox = expand.grid(x, x)
-z = dplack(ox[,1], ox[,2], oratio=oratio)
-contour(x, x, matrix(z, N, N), col="blue")
-z = pplack(ox[,1], ox[,2], oratio=oratio)
-contour(x, x, matrix(z, N, N), col="blue")
+z = dplack(ox[,1], ox[,2], oratio = oratio)
+contour(x, x, matrix(z, N, N), col = "blue")
+z = pplack(ox[,1], ox[,2], oratio = oratio)
+contour(x, x, matrix(z, N, N), col = "blue")
-plot(rr <- rplack(n=3000, oratio=oratio))
-par(mfrow=c(1,2))
+plot(rr <- rplack(n = 3000, oratio = oratio))
+par(mfrow = c(1,2))
hist(rr[,1]) # Should be uniform
hist(rr[,2]) # Should be uniform
}
diff --git a/man/plackett.Rd b/man/plackett.Rd
index b9ff39f..b1b4f6a 100644
--- a/man/plackett.Rd
+++ b/man/plackett.Rd
@@ -8,19 +8,16 @@
}
\usage{
-plackett(link="loge", earg=list(), ioratio=NULL, imethod=1, nsimEIM=200)
+plackett(link = "loge", earg = list(), ioratio = NULL,
+ imethod = 1, nsimEIM = 200)
}
%- maybe also 'usage' for other objects documented here.
\arguments{
- \item{link}{
- Link function applied to the (positive) odds ratio
+ \item{link, earg}{
+ Link function and extra argument applied to the (positive) odds ratio
\eqn{\psi}{psi}.
- See \code{\link{Links}} for more choices.
-
- }
- \item{earg}{
- List. Extra argument for the link.
- See \code{earg} in \code{\link{Links}} for general information.
+ See \code{\link{Links}} for more choices
+ and information.
}
\item{ioratio}{
@@ -28,14 +25,7 @@ plackett(link="loge", earg=list(), ioratio=NULL, imethod=1, nsimEIM=200)
If a convergence failure occurs try assigning a value or a different value.
}
- \item{imethod}{
- An integer with value \code{1} or \code{2} which
- specifies the initialization method for the parameter.
- If failure to converge occurs try another value
- and/or else specify a value for \code{ioratio}.
-
- }
- \item{nsimEIM}{
+ \item{imethod, nsimEIM}{
See \code{\link{CommonVGAMffArguments}}.
}
@@ -62,29 +52,36 @@ plackett(link="loge", earg=list(), ioratio=NULL, imethod=1, nsimEIM=200)
The marginal distributions here are the standard uniform although
it is commonly generalized to other distributions.
+
If \eqn{\psi = 1}{psi=1} then
\eqn{h_{\psi}(y_1,y_2) = y_1 y_2}{h(y1,y2) = y1*y2},
i.e., independence.
As the odds ratio tends to infinity one has \eqn{y_1=y_2}{y1=y2}.
As the odds ratio tends to 0 one has \eqn{y_2=1-y_1}{y2=1-y1}.
+
Fisher scoring is implemented using \code{\link{rplack}}.
Convergence is often quite slow.
+
}
\value{
An object of class \code{"vglmff"} (see \code{\link{vglmff-class}}).
The object is used by modelling functions such as \code{\link{vglm}}
and \code{\link{vgam}}.
+
+
}
\references{
+
Plackett, R. L. (1965)
A class of bivariate distributions.
\emph{Journal of the American Statistical Association},
\bold{60}, 516--522.
+
}
\author{ T. W. Yee }
\note{
@@ -93,18 +90,20 @@ A class of bivariate distributions.
because the marginal distributions correspond to a standard
uniform distribution.
+
}
\seealso{
\code{\link{rplack}},
\code{\link{frank}}.
+
}
\examples{
-ymat = rplack(n=2000, oratio=exp(2))
-\dontrun{plot(ymat, col="blue")}
-fit = vglm(ymat ~ 1, fam=plackett, trace=TRUE)
-coef(fit, matrix=TRUE)
+ymat = rplack(n = 2000, oratio = exp(2))
+\dontrun{plot(ymat, col = "blue")}
+fit = vglm(ymat ~ 1, fam = plackett, trace = TRUE)
+coef(fit, matrix = TRUE)
Coef(fit)
vcov(fit)
head(fitted(fit))
diff --git a/man/plotdeplot.lmscreg.Rd b/man/plotdeplot.lmscreg.Rd
index 8d5c36c..52dfbac 100644
--- a/man/plotdeplot.lmscreg.Rd
+++ b/man/plotdeplot.lmscreg.Rd
@@ -107,9 +107,9 @@ contains further information and examples.
fit = vgam(BMI ~ s(age, df = c(4,2)), fam = lms.bcn(zero = 1), data = bminz)
\dontrun{ y = seq(15, 43, by = 0.25)
deplot(fit, x0 = 20, y = y, xlab = "BMI", col = "green", llwd = 2,
- main = "BMI distribution at ages 20 (green), 40 (blue), 60 (red)")
+ main = "BMI distribution at ages 20 (green), 40 (blue), 60 (orange)")
deplot(fit, x0 = 40, y = y, add = TRUE, col = "blue", llwd = 2)
-deplot(fit, x0 = 60, y = y, add = TRUE, col = "red", llwd = 2) -> aa
+deplot(fit, x0 = 60, y = y, add = TRUE, col = "orange", llwd = 2) -> aa
names(aa at post$deplot)
aa at post$deplot$newdata
diff --git a/man/plotqrrvglm.Rd b/man/plotqrrvglm.Rd
index 3c1c870..3b4d80e 100644
--- a/man/plotqrrvglm.Rd
+++ b/man/plotqrrvglm.Rd
@@ -70,9 +70,9 @@ p1 = cqo(cbind(Alopacce, Alopcune, Alopfabr, Arctlute, Arctperi,
Auloalbi, Pardlugu, Pardmont, Pardnigr, Pardpull,
Trocterr, Zoraspin) ~
WaterCon + BareSand + FallTwig + CoveMoss + CoveHerb + ReflLux,
- fam = quasipoissonff, data = hspider, Crow1positive=FALSE)
-par(mfrow=c(3,4))
-plot(p1, rtype="d", col="blue", pch=4, las=1)
+ fam = quasipoissonff, data = hspider, Crow1positive = FALSE)
+par(mfrow = c(3, 4))
+plot(p1, rtype = "d", col = "blue", pch = 4, las = 1)
}
}
\keyword{dplot}
diff --git a/man/plotqtplot.lmscreg.Rd b/man/plotqtplot.lmscreg.Rd
index 6b0b3a3..2ad0c76 100644
--- a/man/plotqtplot.lmscreg.Rd
+++ b/man/plotqtplot.lmscreg.Rd
@@ -98,9 +98,9 @@ contains further information and examples.
}
\examples{\dontrun{
-fit = vgam(BMI ~ s(age, df=c(4,2)), fam=lms.bcn(zero=1), data=bminz)
+fit = vgam(BMI ~ s(age, df = c(4,2)), fam = lms.bcn(zero = 1), data = bminz)
qtplot(fit)
-qtplot(fit, perc=c(25,50,75,95), lcol="blue", tcol="blue", llwd=2)
+qtplot(fit, perc = c(25,50,75,95), lcol = "blue", tcol = "blue", llwd = 2)
}
}
diff --git a/man/plotvgam.Rd b/man/plotvgam.Rd
index 22166c1..64f89c4 100644
--- a/man/plotvgam.Rd
+++ b/man/plotvgam.Rd
@@ -109,6 +109,8 @@ plotvgam(x, newdata = NULL, y = NULL, residuals = NULL,
Many of \code{plotvgam()}'s options can be found in
\code{\link{plotvgam.control}}, e.g., line types, line widths,
colors.
+
+
}
\value{
The original object, but with the \code{preplot} slot of the object
@@ -116,15 +118,18 @@ plotvgam(x, newdata = NULL, y = NULL, residuals = NULL,
}
\references{
+
Yee, T. W. and Wild, C. J. (1996)
Vector generalized additive models.
\emph{Journal of the Royal Statistical Society, Series B, Methodological},
\bold{58}, 481--493.
+
Documentation accompanying the \pkg{VGAM} package at
\url{http://www.stat.auckland.ac.nz/~yee}
contains further information and examples.
+
}
\author{ Thomas W. Yee }
@@ -133,12 +138,15 @@ contains further information and examples.
is \code{"vgam"}, it is necessary to use \code{plotvgam(fit)}
explicitly otherwise.
+
\code{plotvgam()} is quite buggy at the moment.
+
% \code{plotvgam()} works in a similar
% manner to S-PLUS's \code{plot.gam()}, however, there is no
% options for interactive construction of the plots yet.
+
}
\seealso{
@@ -146,16 +154,16 @@ contains further information and examples.
\code{\link{plotvgam.control}},
\code{predict.vgam},
\code{\link{vglm}}.
+
+
}
\examples{
coalminers = transform(coalminers, Age = (age - 42) / 5)
-fit = vgam(cbind(nBnW,nBW,BnW,BW) ~ s(Age), binom2.or(zero=NULL), coalminers)
-\dontrun{
-par(mfrow=c(1,3))
-plot(fit, se=TRUE, ylim=c(-3,2), las=1)
-plot(fit, se=TRUE, which.cf=1:2, lcol="blue", scol="red", ylim=c(-3,2))
-plot(fit, se=TRUE, which.cf=1:2, lcol="blue", scol="red", overlay=TRUE)
-}
+fit = vgam(cbind(nBnW,nBW,BnW,BW) ~ s(Age), binom2.or(zero = NULL), coalminers)
+\dontrun{ par(mfrow = c(1,3))
+plot(fit, se = TRUE, ylim = c(-3,2), las = 1)
+plot(fit, se = TRUE, which.cf = 1:2, lcol = "blue", scol = "orange", ylim = c(-3,2))
+plot(fit, se = TRUE, which.cf = 1:2, lcol = "blue", scol = "orange", overlay = TRUE) }
}
\keyword{models}
\keyword{regression}
diff --git a/man/plotvgam.control.Rd b/man/plotvgam.control.Rd
index 9e0b8c0..09646cc 100644
--- a/man/plotvgam.control.Rd
+++ b/man/plotvgam.control.Rd
@@ -14,7 +14,7 @@ plotvgam.control(which.cf = NULL,
lcol = par()$col, rcol = par()$col,
scol = par()$col, llwd = par()$lwd, slwd = par()$lwd,
add.arg = FALSE, one.at.a.time = FALSE,
- .include.dots = TRUE, noxmean= FALSE, ...)
+ .include.dots = TRUE, noxmean = FALSE, ...)
}
%- maybe also 'usage' for other objects documented here.
\arguments{
@@ -65,20 +65,22 @@ plotvgam.control(which.cf = NULL,
\details{
The most obvious features of \code{\link{plotvgam}} can be
controlled by the above arguments.
+
+
}
\value{
A list with values matching the arguments.
+
+
}
\references{
+
Yee, T. W. and Wild, C. J. (1996)
Vector generalized additive models.
\emph{Journal of the Royal Statistical Society, Series B, Methodological},
\bold{58}, 481--493.
-Documentation accompanying the \pkg{VGAM} package at
-\url{http://www.stat.auckland.ac.nz/~yee}
-contains further information and examples.
}
\author{ Thomas W. Yee }
@@ -92,9 +94,11 @@ contains further information and examples.
\seealso{
\code{\link{plotvgam}}.
+
+
}
\examples{
-plotvgam.control(lcol=c("red", "blue"), scol="darkgreen", se=TRUE)
+plotvgam.control(lcol = c("red", "blue"), scol = "darkgreen", se = TRUE)
}
\keyword{models}
\keyword{regression}
diff --git a/man/pneumo.Rd b/man/pneumo.Rd
index 64f56f7..029ed13 100644
--- a/man/pneumo.Rd
+++ b/man/pneumo.Rd
@@ -20,19 +20,27 @@ Exposure time is explanatory, and there are 3 ordinal response variables.
\details{
These were collected from coalface workers. In the original
data set, the two most severe categories were combined.
+
+
}
\source{
+
Ashford, J.R., 1959. An approach to the analysis of data for
semi-quantal responses in biological assay.
\emph{Biometrics}, \bold{15}, 573--581.
+
+
}
\references{
+
McCullagh, P. and Nelder, J. A. (1989)
\emph{Generalized Linear Models}, 2nd ed. London: Chapman & Hall.
+
+
}
\examples{
# Fit the proportional odds model, p.179, in McCullagh and Nelder (1989)
-pneumo = transform(pneumo, let=log(exposure.time))
-vglm(cbind(normal,mild,severe) ~ let, propodds, pneumo)
+pneumo = transform(pneumo, let = log(exposure.time))
+vglm(cbind(normal, mild, severe) ~ let, propodds, pneumo)
}
\keyword{datasets}
diff --git a/man/poissonff.Rd b/man/poissonff.Rd
index 29c2602..9376183 100644
--- a/man/poissonff.Rd
+++ b/man/poissonff.Rd
@@ -11,18 +11,14 @@
}
\usage{
poissonff(link = "loge", earg=list(), dispersion = 1, onedpar = FALSE,
- imu=NULL, imethod=1, parallel = FALSE, zero = NULL)
+ imu = NULL, imethod = 1, parallel = FALSE, zero = NULL)
}
%- maybe also 'usage' for other objects documented here.
\arguments{
- \item{link}{
- Link function applied to the mean or means.
- See \code{\link{Links}} for more choices.
-
- }
- \item{earg}{
- Extra argument optionally used by the link function.
- See \code{\link{Links}} for more information.
+ \item{link, earg}{
+ Link function and extra argument applied to the mean or means.
+ See \code{\link{Links}} for more choices
+ and information.
}
\item{dispersion}{
@@ -61,18 +57,22 @@ poissonff(link = "loge", earg=list(), dispersion = 1, onedpar = FALSE,
\details{
\eqn{M} defined above is the number of linear/additive predictors.
+
If the dispersion parameter is unknown, then the resulting estimate
is not fully a maximum likelihood estimate.
+
A dispersion parameter that is less/greater than unity corresponds to
under-/over-dispersion relative to the Poisson model. Over-dispersion
is more common in practice.
+
When fitting a Quadratic RR-VGLM (see \code{\link{cqo}}), the
response is a matrix of \eqn{M}, say, columns (e.g., one column
per species). Then there will be \eqn{M} dispersion parameters
- (one per column of the response matrix) if \code{dispersion=0} and
- \code{onedpar=FALSE}.
+ (one per column of the response matrix) if \code{dispersion = 0} and
+ \code{onedpar = FALSE}.
+
}
\value{
@@ -84,35 +84,45 @@ poissonff(link = "loge", earg=list(), dispersion = 1, onedpar = FALSE,
\code{\link{cqo}},
and \code{\link{cao}}.
+
}
\references{
+
McCullagh, P. and Nelder, J. A. (1989)
\emph{Generalized Linear Models}, 2nd ed. London: Chapman & Hall.
+
+
}
\author{ Thomas W. Yee }
\note{
+
This function will handle a matrix response automatically.
+
The call \code{poissonff(dispersion=0, ...)} is equivalent to
\code{quasipoissonff(...)}. The latter was written so that R users
of \code{quasipoisson()} would only need to add a ``\code{ff}''
to the end of the family function name.
+
Regardless of whether the dispersion parameter is to be estimated or
not, its value can be seen from the output from the \code{summary()}
of the object.
+
% With the introduction of name spaces for the \pkg{VGAM} package,
% \code{"ff"} can be dropped for this family function.
+
}
\section{Warning }{
With a multivariate response, assigning a known dispersion parameter
for \emph{each} response is not handled well yet. Currently, only
a single known dispersion parameter is handled well.
+
}
\seealso{
@@ -135,14 +145,16 @@ poissonff(link = "loge", earg=list(), dispersion = 1, onedpar = FALSE,
\code{\link{quasibinomialff}},
\code{\link[stats]{poisson}},
\code{\link{poissonp}}.
+
+
}
\examples{
poissonff()
pdat = data.frame(x = rnorm(nn <- 100))
pdat = transform(pdat, y = rpois(nn, exp(1+x)))
-(fit = vglm(y ~ x, family=poissonff, pdat))
-coef(fit, matrix=TRUE)
+(fit = vglm(y ~ x, family = poissonff, pdat))
+coef(fit, matrix = TRUE)
nn = 200
cdat = data.frame(x2 = rnorm(nn), x3 = rnorm(nn), x4 = rnorm(nn))
@@ -154,11 +166,9 @@ cdat = transform(cdat, y1 = rpois(nn, lambda1),
y2 = rpois(nn, lambda2),
y3 = rpois(nn, lambda3))
# vvv p1 = cqo(cbind(y1,y2,y3) ~ x2 + x3 + x4, poissonff, cdat,
-# vvv EqualTol=FALSE, ITol=FALSE)
+# vvv EqualTol = FALSE, ITol = FALSE)
# vvv summary(p1) # # Three dispersion parameters are all unity
-\dontrun{
-lvplot(p1, y=TRUE, lcol=2:4, pch=2:4, pcol=2:4, rug=FALSE)
-}
+\dontrun{ lvplot(p1, y = TRUE, lcol = 2:4, pch = 2:4, pcol = 2:4, rug = FALSE) }
}
\keyword{models}
\keyword{regression}
diff --git a/man/polf.Rd b/man/polf.Rd
index a622aa8..86b74bd 100644
--- a/man/polf.Rd
+++ b/man/polf.Rd
@@ -8,8 +8,8 @@
}
\usage{
-polf(theta, earg = stop("'earg' must be given"), inverse = FALSE,
- deriv = 0, short = TRUE, tag = FALSE)
+polf(theta, earg = stop("argument 'earg' must be given"),
+ inverse = FALSE, deriv = 0, short = TRUE, tag = FALSE)
}
%- maybe also 'usage' for other objects documented here.
\arguments{
diff --git a/man/polonoUC.Rd b/man/polonoUC.Rd
index 4474eb9..9bd31b0 100644
--- a/man/polonoUC.Rd
+++ b/man/polonoUC.Rd
@@ -1,7 +1,7 @@
\name{Polono}
\alias{Polono}
\alias{dpolono}
-%\alias{ppolono}
+\alias{ppolono}
%\alias{qpolono}
\alias{rpolono}
\title{The Poisson Lognormal Distribution}
@@ -11,20 +11,26 @@
}
\usage{
-dpolono(x, meanlog=0, sdlog=1, bigx=Inf, ...)
-rpolono(n, meanlog=0, sdlog=1)
+dpolono(x, meanlog = 0, sdlog = 1, bigx = 170, ...)
+ppolono(q, meanlog = 0, sdlog = 1,
+ isOne = 1 - sqrt( .Machine$double.eps ), ...)
+rpolono(n, meanlog = 0, sdlog = 1)
}
\arguments{
- \item{x}{vector of quantiles.}
+ \item{x, q}{vector of quantiles.}
% \item{p}{vector of probabilities.}
\item{n}{number of observations.
- If \code{length(n) > 1} then the length is taken to be the number required. }
+ If \code{length(n) > 1} then the length is taken to be the number required.
+
+
+ }
\item{meanlog, sdlog }{
the mean and standard deviation of the normal distribution
(on the log scale).
They match the arguments in
\code{\link[stats:Lognormal]{Lognormal}}.
+
}
\item{bigx}{
Numeric.
@@ -33,12 +39,18 @@ rpolono(n, meanlog=0, sdlog=1)
A first order Taylor series approximation
[Equation (7) of Bulmer (1974)]
is used at values of \code{x} that are greater or equal to this argument.
- For \code{bigx=10},
+ For \code{bigx = 10},
he showed that the approximation has a relative error less than
0.001 for values of \code{meanlog} and
- \code{sdlog} ``likely to be encountered in practice''. The default value
- means that this approximation is not used. Setting something like
- \code{bigx=100} may be a good idea.
+ \code{sdlog} ``likely to be encountered in practice''.
+ The argument can be assigned \code{Inf} in which case
+ the approximation is not used.
+
+
+ }
+ \item{isOne }{
+ Used to test whether the cumulative probabilities have
+ effectively reached unity.
}
\item{...}{
@@ -48,10 +60,12 @@ rpolono(n, meanlog=0, sdlog=1)
}
}
\value{
- \code{dpolono} gives the density, and
-% \code{ppolono} gives the distribution function, and
+ \code{dpolono} gives the density,
+ \code{ppolono} gives the distribution function, and
% \code{qpolono} gives the quantile function, and
\code{rpolono} generates random deviates.
+
+
}
\references{
Bulmer, M. G. (1974)
@@ -60,19 +74,28 @@ rpolono(n, meanlog=0, sdlog=1)
\bold{30},
101--110.
+
}
-\author{ T. W. Yee }
+\author{
+ T. W. Yee.
+ Some anonymous soul kindly wrote \code{ppolono()} and
+ improved the original \code{dpolono()}.
+
+
+ }
\details{
The Poisson lognormal distribution is similar to the negative
binomial in that it can be motivated by a Poisson distribution whose
mean parameter comes from a right skewed distribution (gamma for the
negative binomial and lognormal for the Poisson lognormal distribution).
+
% See zz code{link{polonozz}}, the \pkg{VGAM} family function
% for estimating the parameters,
% for the formula of the probability density function and other details.
+
}
\note{
By default,
@@ -81,42 +104,43 @@ rpolono(n, meanlog=0, sdlog=1)
slow and numerical problems may occur
(if so then the use of \code{...} may be needed).
Alternatively, for extreme values of \code{x}, \code{meanlog},
- \code{sdlog}, etc., the use of \code{bigx} avoids the call to
- \code{\link[stats]{integrate}}; however the answer may be a little
+ \code{sdlog}, etc., the use of \code{bigx = Inf} avoids the call to
+ \code{\link[stats]{integrate}}, however the answer may be a little
inaccurate.
+
For the maximum likelihood estimation of the 2 parameters a \pkg{VGAM}
family function called \code{polono}, say, has not been written yet.
+
}
\seealso{
\code{\link{lognormal}},
\code{\link{poissonff}},
\code{\link{negbinomial}}.
+
}
\examples{
-meanlog = 0.5; sdlog = 0.5; y = 0:19
-proby = dpolono(y, m=meanlog, sd=sdlog)
-sum(proby) # Should be 1
-\dontrun{
-opar = par(no.readonly = TRUE)
-par(mfrow=c(2,2))
-plot(y, proby, type="h", col="blue", ylab="P[Y=y]", log="",
- main=paste("Poisson lognormal(meanlog=",meanlog,", sdlog=",sdlog,")",
- sep=""))
-
-# More extreme values; use the approximation and plot on a log scale
-# Notice the kink at bigx.
-y = 0:190
-proby = dpolono(y, m=meanlog, sd=sdlog, bigx=100)
-sum(proby) # Should be 1
-plot(y, proby, type="h", col="blue", ylab="P[Y=y]", log="y",
- main=paste("Poisson lognormal(meanlog=",meanlog,", sdlog=",sdlog,")"))
+meanlog = 0.5; sdlog = 0.5; yy = 0:19
+sum(proby <- dpolono(yy, m = meanlog, sd = sdlog)) # Should be 1
+max(abs(cumsum(proby) - ppolono(yy, m = meanlog, sd = sdlog))) # Should be 0
+
+\dontrun{ opar = par(no.readonly = TRUE)
+par(mfrow = c(2, 2))
+plot(yy, proby, type = "h", col = "blue", ylab = "P[Y=y]", log = "",
+ main = paste("Poisson lognormal(m = ", meanlog,
+ ", sdl = ", sdlog, ")", sep = ""))
+
+y = 0:190 # More extreme values; use the approximation and plot on a log scale
+(sum(proby <- dpolono(y, m = meanlog, sd = sdlog, bigx = 100))) # Should be 1
+plot(y, proby, type = "h", col = "blue", ylab = "P[Y=y] (log)", log = "y",
+ main = paste("Poisson lognormal(m = ", meanlog,
+ ", sdl = ", sdlog, ")", sep = "")) # Note the kink at bigx
# Random number generation
-table(y <- rpolono(n=1000, m=meanlog, sd=sdlog))
-hist(y, breaks=((-1):max(y))+0.5, prob=TRUE, border="blue")
+table(y <- rpolono(n = 1000, m = meanlog, sd = sdlog))
+hist(y, breaks = ((-1):max(y))+0.5, prob = TRUE, border = "blue")
par(opar) }
}
\keyword{distribution}
diff --git a/man/predict.qrrvglm.Rd b/man/predictqrrvglm.Rd
similarity index 85%
rename from man/predict.qrrvglm.Rd
rename to man/predictqrrvglm.Rd
index 25ca063..684afcd 100644
--- a/man/predict.qrrvglm.Rd
+++ b/man/predictqrrvglm.Rd
@@ -1,5 +1,5 @@
-\name{predict.qrrvglm}
-\alias{predict.qrrvglm}
+\name{predictqrrvglm}
+\alias{predictqrrvglm}
%- Also NEED an '\alias' for EACH other topic documented here.
\title{ Predict Method for a CQO fit }
\description{
@@ -8,10 +8,10 @@
}
\usage{
-predict.qrrvglm(object, newdata=NULL,
- type=c("link", "response", "lv", "terms"),
- se.fit=FALSE, deriv=0, dispersion=NULL,
- extra=object at extra, varlvI = FALSE, reference = NULL, ...)
+predictqrrvglm(object, newdata=NULL,
+ type = c("link", "response", "lv", "terms"),
+ se.fit = FALSE, deriv = 0, dispersion = NULL,
+ extra = object at extra, varlvI = FALSE, reference = NULL, ...)
}
%- maybe also 'usage' for other objects documented here.
@@ -23,7 +23,7 @@ predict.qrrvglm(object, newdata=NULL,
}
\item{type, se.fit, dispersion, extra}{
- See \code{\link{predict.vglm}}.
+ See \code{\link{predictvglm}}.
}
\item{deriv}{ Derivative. Currently only 0 is handled. }
@@ -42,7 +42,9 @@ predict.qrrvglm(object, newdata=NULL,
}
\value{
- See \code{\link{predict.vglm}}.
+ See \code{\link{predictvglm}}.
+
+
}
\references{
Yee, T. W. (2004)
diff --git a/man/predict.vglm.Rd b/man/predictvglm.Rd
similarity index 91%
rename from man/predict.vglm.Rd
rename to man/predictvglm.Rd
index 6bc1c56..176efe6 100644
--- a/man/predict.vglm.Rd
+++ b/man/predictvglm.Rd
@@ -1,5 +1,5 @@
-\name{predict.vglm}
-\alias{predict.vglm}
+\name{predictvglm}
+\alias{predictvglm}
%- Also NEED an '\alias' for EACH other topic documented here.
\title{Predict Method for a VGLM fit}
\description{
@@ -7,10 +7,10 @@
object.
}
\usage{
-predict.vglm(object, newdata = NULL,
- type = c("link", "response", "terms"),
- se.fit = FALSE, deriv = 0, dispersion = NULL,
- untransform = FALSE, extra = object at extra, ...)
+predictvglm(object, newdata = NULL,
+ type = c("link", "response", "terms"),
+ se.fit = FALSE, deriv = 0, dispersion = NULL,
+ untransform = FALSE, extra = object at extra, ...)
}
%- maybe also 'usage' for other objects documented here.
\arguments{
@@ -59,7 +59,7 @@ predict.vglm(object, newdata = NULL,
This argument only works if \code{type = "link", se.fit = FALSE, deriv = 0}.
}
- \item{\dots}{Arguments passed into \code{predict.vlm}.
+ \item{\dots}{Arguments passed into \code{predictvlm}.
}
}
\details{
@@ -104,7 +104,7 @@ Reduced-rank vector generalized linear models.
\seealso{
\code{\link[stats]{predict}},
\code{\link{vglm}},
- \code{predict.vlm},
+ \code{predictvlm},
\code{\link{smartpred}}.
}
diff --git a/man/qrrvglm.control.Rd b/man/qrrvglm.control.Rd
index 2757cc9..890c71c 100644
--- a/man/qrrvglm.control.Rd
+++ b/man/qrrvglm.control.Rd
@@ -468,7 +468,7 @@ p1 = cqo(cbind(Alopacce, Alopcune, Alopfabr, Arctlute, Arctperi, Auloalbi,
quasipoissonff, data = hspider, EqualTolerances = TRUE)
sort(p1 at misc$deviance.Bestof) # A history of all the iterations
-(isdlv = sd(lv(p1))) # Should be approx isdlv
+(isdlv = apply(lv(p1), 2, sd)) # Should be approx isdlv
# Refit the model with better initial values
set.seed(111) # This leads to the global solution
diff --git a/man/rcqo.Rd b/man/rcqo.Rd
index 9fdeff0..ebb16fb 100644
--- a/man/rcqo.Rd
+++ b/man/rcqo.Rd
@@ -368,7 +368,7 @@ lvplot(fit, lcol=1:S, y = TRUE, pcol=1:S) # The same plot as above
ccoef(fit) # The fitted model
attr(mydata, "ccoefficients") # The 'truth'
-c(sd(attr(mydata, "lv")), sd(lv(fit))) # Both values should be approx equal
+c(apply(attr(mydata, "lv"), 2, sd), apply(lv(fit), 2, sd)) # Both values should be approx equal
# Example 2: negative binomial data fitted using a Poisson model:
diff --git a/man/tikuv.Rd b/man/tikuv.Rd
index 892da29..1077ba8 100644
--- a/man/tikuv.Rd
+++ b/man/tikuv.Rd
@@ -7,14 +7,14 @@
}
\usage{
-tikuv(d, lmean="identity", lsigma="loge", emean=list(), esigma=list(),
- isigma=NULL, zero=2)
+tikuv(d, lmean = "identity", lsigma = "loge", emean = list(), esigma = list(),
+ isigma = NULL, zero = 2)
}
%- maybe also 'usage' for other objects documented here.
\arguments{
\item{d}{
The \eqn{d} parameter. It must be a single numeric value less than 2.
- Then \eqn{h=2-d>0} is another parameter.
+ Then \eqn{h = 2-d>0} is another parameter.
}
\item{lmean, lsigma}{
@@ -40,9 +40,9 @@ tikuv(d, lmean="identity", lsigma="loge", emean=list(), esigma=list(),
linear/additive predictors are modelled as intercepts only.
The values must be from the set \{1,2\} corresponding
respectively to \eqn{\mu}{mu}, \eqn{\sigma}{sigma}.
- If \code{zero=NULL} then all linear/additive predictors are modelled as
+ If \code{zero = NULL} then all linear/additive predictors are modelled as
a linear combination of the explanatory variables.
- For many data sets having \code{zero=2} is a good idea.
+ For many data sets having \code{zero = 2} is a good idea.
}
}
@@ -65,11 +65,14 @@ tikuv(d, lmean="identity", lsigma="loge", emean=list(), esigma=list(),
The mean of \eqn{Y} is
\eqn{E(Y) = \mu}{E(Y) = mu} and this is returned as the fitted values.
+
}
\value{
An object of class \code{"vglmff"} (see \code{\link{vglmff-class}}).
The object is used by modelling functions such as \code{\link{vglm}},
and \code{\link{vgam}}.
+
+
}
\references{
@@ -82,6 +85,7 @@ tikuv(d, lmean="identity", lsigma="loge", emean=list(), esigma=list(),
A family of short-tailed symmetric distributions.
\emph{Technical report, McMaster University, Canada}.
+
}
\author{ Thomas W. Yee }
\note{
@@ -94,29 +98,32 @@ tikuv(d, lmean="identity", lsigma="loge", emean=list(), esigma=list(),
After fitting the value of \code{d} is stored in \code{@misc} with
component name \code{d}.
+
}
\section{Warning }{
Under- or over-flow may occur if the data is ill-conditioned,
e.g., when \eqn{d} is very close to 2 or approaches \code{-Inf}.
+
}
\seealso{
- \code{\link{dtikuv}},
- \code{\link{normal1}}.
+ \code{\link{dtikuv}},
+ \code{\link{normal1}}.
+
+
}
\examples{
m = 1.0; sigma = exp(0.5)
-sy = sort(y <- rtikuv(n=1000, d=1, m=m, s=sigma))
-fit = vglm(y ~ 1, fam=tikuv(d=1), trace=TRUE)
-coef(fit, mat=TRUE)
+tdata = data.frame(y = rtikuv(n = 1000, d = 1, m = m, s = sigma))
+tdata = transform(tdata, sy = sort(y))
+fit = vglm(y ~ 1, fam = tikuv(d = 1), tdata, trace = TRUE)
+coef(fit, matrix = TRUE)
(Cfit = Coef(fit))
-mean(y)
-\dontrun{
-hist(y, prob=TRUE)
-lines(sy, dtikuv(sy, d=1, m=Cfit[1], s=Cfit[2]), col="red")
-}
+with(tdata, mean(y))
+\dontrun{ with(tdata, hist(y, prob = TRUE))
+lines(dtikuv(sy, d = 1, m = Cfit[1], s = Cfit[2]) ~ sy, tdata, col = "orange") }
}
\keyword{models}
\keyword{regression}
diff --git a/man/tikuvUC.Rd b/man/tikuvUC.Rd
index be4b92c..99c13bf 100644
--- a/man/tikuvUC.Rd
+++ b/man/tikuvUC.Rd
@@ -12,10 +12,10 @@
}
\usage{
-dtikuv(x, d, mean=0, sigma=1, log=FALSE)
-ptikuv(q, d, mean=0, sigma=1)
-qtikuv(p, d, mean=0, sigma=1, ...)
-rtikuv(n, d, mean=0, sigma=1, Smallno=1.0e-6)
+dtikuv(x, d, mean = 0, sigma = 1, log = FALSE)
+ptikuv(q, d, mean = 0, sigma = 1)
+qtikuv(p, d, mean = 0, sigma = 1, ...)
+rtikuv(n, d, mean = 0, sigma = 1, Smallno = 1.0e-6)
}
\arguments{
\item{x, q}{vector of quantiles.}
@@ -42,7 +42,7 @@ rtikuv(n, d, mean=0, sigma=1, Smallno=1.0e-6)
}
\item{log}{
Logical.
- If \code{log=TRUE} then the logarithm of the density is returned.
+ If \code{log = TRUE} then the logarithm of the density is returned.
}
@@ -52,11 +52,14 @@ rtikuv(n, d, mean=0, sigma=1, Smallno=1.0e-6)
\code{ptikuv} gives the cumulative distribution function,
\code{qtikuv} gives the quantile function, and
\code{rtikuv} generates random deviates.
+
+
}
\author{ T. W. Yee }
\details{
See \code{\link{tikuv}} for more details.
+
}
%\note{
%
@@ -66,26 +69,26 @@ rtikuv(n, d, mean=0, sigma=1, Smallno=1.0e-6)
}
\examples{
-\dontrun{
-x = seq(-5, 5, len=401)
-plot(x, dnorm(x), type="l", col="black", ylab="",
- main="Black is standard normal, others are dtikuv(x, d)")
-lines(x, dtikuv(x, d=-10), col="red")
-lines(x, dtikuv(x, d=-1 ), col="blue")
-lines(x, dtikuv(x, d= 1 ), col="green")
-legend(2, 0.35, col=c("red","blue","green"), lty=rep(1, len=3),
- legend=paste("d =", c(-10, -1, 1)))
+\dontrun{ par(mfrow = c(2, 1))
+x = seq(-5, 5, len = 401)
+plot(x, dnorm(x), type = "l", col = "black", ylab = "", las = 1,
+ main = "Black is standard normal, others are dtikuv(x, d)")
+lines(x, dtikuv(x, d = -10), col = "orange")
+lines(x, dtikuv(x, d = -1 ), col = "blue")
+lines(x, dtikuv(x, d = 1 ), col = "green")
+legend("topleft", col = c("orange","blue","green"), lty = rep(1, len = 3),
+ legend = paste("d =", c(-10, -1, 1)))
-plot(x, pnorm(x), type="l", col="black", ylab="",
- main="Black is standard normal, others are ptikuv(x, d)")
-lines(x, ptikuv(x, d=-10), col="red")
-lines(x, ptikuv(x, d=-1 ), col="blue")
-lines(x, ptikuv(x, d= 1 ), col="green")
-legend(2, 0.35, col=c("red","blue","green"), lty=rep(1, len=3),
- legend=paste("d =", c(-10, -1, 1)))
+plot(x, pnorm(x), type = "l", col = "black", ylab = "", las = 1,
+ main = "Black is standard normal, others are ptikuv(x, d)")
+lines(x, ptikuv(x, d = -10), col = "orange")
+lines(x, ptikuv(x, d = -1 ), col = "blue")
+lines(x, ptikuv(x, d = 1 ), col = "green")
+legend("topleft", col = c("orange","blue","green"), lty = rep(1, len = 3),
+ legend = paste("d =", c(-10, -1, 1)))
-probs = seq(0.1, 0.9, by=0.1)
-ptikuv(qtikuv(p=probs, d= 1), d=1) - probs # Should be all 0
+probs = seq(0.1, 0.9, by = 0.1)
+ptikuv(qtikuv(p = probs, d = 1), d = 1) - probs # Should be all 0
}
}
\keyword{distribution}
diff --git a/man/toxop.Rd b/man/toxop.Rd
index 58c8899..85d0a3e 100644
--- a/man/toxop.Rd
+++ b/man/toxop.Rd
@@ -18,13 +18,16 @@
}
\details{
See the references for details.
+
}
\source{
See the references for details.
+
}
\seealso{
\code{\link{dexpbinomial}}.
+
}
\references{
@@ -34,16 +37,16 @@
\emph{Journal of the American Statistical Association},
\bold{73}, 113--121.
+
Efron, B. (1986)
Double exponential families and their use in generalized linear regression.
\emph{Journal of the American Statistical Association},
\bold{81}, 709--721.
+
}
\examples{
-\dontrun{
-with(toxop, plot(rainfall, positive/ssize, col="blue"))
-plot(toxop, col="blue")
-}
+\dontrun{ with(toxop, plot(rainfall, positive/ssize, col = "blue"))
+plot(toxop, col = "blue") }
}
\keyword{datasets}
diff --git a/man/triangle.Rd b/man/triangle.Rd
index dd40f48..2ed6ca0 100644
--- a/man/triangle.Rd
+++ b/man/triangle.Rd
@@ -8,9 +8,9 @@
}
\usage{
-triangle(lower=0, upper=1, link="elogit",
- earg=if(link=="elogit") list(min = lower, max = upper) else
- list(), itheta=NULL)
+triangle(lower = 0, upper = 1, link = "elogit",
+ earg = if(link == "elogit") list(min = lower, max = upper) else
+ list(), itheta = NULL)
}
%- maybe also 'usage' for other objects documented here.
\arguments{
@@ -41,7 +41,7 @@ triangle(lower=0, upper=1, link="elogit",
The triangle distribution
has a probability density function that consists of two lines
joined at \eqn{\theta}{theta}. The lines intersect the
- \eqn{y=0} axis at \eqn{A} and \eqn{B}.
+ \eqn{y = 0} axis at \eqn{A} and \eqn{B}.
Here, Fisher scoring is used.
On fitting, the \code{extra} slot has components called \code{lower}
@@ -69,13 +69,13 @@ triangle(lower=0, upper=1, link="elogit",
\code{\link{Triangle}}.
}
\examples{
-y = rtriangle(n <- 3000, theta=3/4)
-fit = vglm(y ~ 1, triangle(link="identity"), trace=TRUE)
-coef(fit, matrix=TRUE)
+tdata = data.frame(y = rtriangle(n <- 3000, theta = 3/4))
+fit = vglm(y ~ 1, triangle(link = "identity"), tdata, trace = TRUE)
+coef(fit, matrix = TRUE)
Coef(fit)
head(fit at extra$lower)
head(fitted(fit))
-mean(y)
+with(tdata, mean(y))
}
\keyword{models}
\keyword{regression}
diff --git a/man/triangleUC.Rd b/man/triangleUC.Rd
index 6e1716e..9694889 100644
--- a/man/triangleUC.Rd
+++ b/man/triangleUC.Rd
@@ -11,10 +11,10 @@
\code{theta}.
}
\usage{
-dtriangle(x, theta, lower=0, upper=1, log=FALSE)
-ptriangle(q, theta, lower=0, upper=1)
-qtriangle(p, theta, lower=0, upper=1)
-rtriangle(n, theta, lower=0, upper=1)
+dtriangle(x, theta, lower = 0, upper = 1, log = FALSE)
+ptriangle(q, theta, lower = 0, upper = 1)
+qtriangle(p, theta, lower = 0, upper = 1)
+rtriangle(n, theta, lower = 0, upper = 1)
}
\arguments{
\item{x, q}{vector of quantiles.}
@@ -28,7 +28,7 @@ rtriangle(n, theta, lower=0, upper=1)
}
\item{log}{
Logical.
- If \code{log=TRUE} then the logarithm of the density is returned.
+ If \code{log = TRUE} then the logarithm of the density is returned.
}
@@ -38,6 +38,7 @@ rtriangle(n, theta, lower=0, upper=1)
\code{ptriangle} gives the distribution function,
\code{qtriangle} gives the quantile function, and
\code{rtriangle} generates random deviates.
+
}
%\references{
%
@@ -48,29 +49,29 @@ rtriangle(n, theta, lower=0, upper=1)
for estimating the parameter \eqn{\theta}{theta} by
maximum likelihood estimation.
+
}
%\note{
%
%}
\seealso{
\code{\link{triangle}}.
+
+
}
\examples{
-\dontrun{
-x = seq(-0.1, 1.1, by=0.01)
-theta = 0.75
-plot(x, dtriangle(x, theta=theta), type="l", col="blue", las=1,
- main="Blue is density, red is cumulative distribution function",
- sub="Purple lines are the 10,20,...,90 percentiles",
- ylim=c(0,2), ylab="")
-abline(h=0, col="blue", lty=2)
-lines(x, ptriangle(x, theta=theta), col="red")
-probs = seq(0.1, 0.9, by=0.1)
-Q = qtriangle(probs, theta=theta)
-lines(Q, dtriangle(Q, theta=theta), col="purple", lty=3, type="h")
-ptriangle(Q, theta=theta) - probs # Should be all zero
-abline(h=probs, col="purple", lty=3)
-}
+\dontrun{ x = seq(-0.1, 1.1, by = 0.01); theta = 0.75
+plot(x, dtriangle(x, theta = theta), type = "l", col = "blue", las = 1,
+ main = "Blue is density, orange is cumulative distribution function",
+ sub = "Purple lines are the 10,20,...,90 percentiles",
+ ylim = c(0,2), ylab = "")
+abline(h = 0, col = "blue", lty = 2)
+lines(x, ptriangle(x, theta = theta), col = "orange")
+probs = seq(0.1, 0.9, by = 0.1)
+Q = qtriangle(probs, theta = theta)
+lines(Q, dtriangle(Q, theta = theta), col = "purple", lty = 3, type = "h")
+ptriangle(Q, theta = theta) - probs # Should be all zero
+abline(h = probs, col = "purple", lty = 3) }
}
\keyword{distribution}
diff --git a/man/trplot.Rd b/man/trplot.Rd
index e299b3a..1bc6122 100644
--- a/man/trplot.Rd
+++ b/man/trplot.Rd
@@ -23,22 +23,29 @@ trplot(object, ...)
models.
Many models have no such notion or definition.
+
For quadratic and additive ordination models they plot the
fitted values of two species against each other (more than
two is theoretically possible, but not implemented in this software
yet).
+
+
}
\value{
The value returned depends specifically on the methods
function invoked.
+
+
}
\references{
-Yee, T. W. (2005)
+
+Yee, T. W. (2011)
On constrained and unconstrained
quadratic ordination.
\emph{Manuscript in preparation}.
+
}
\author{ Thomas W. Yee }
@@ -48,32 +55,30 @@ quadratic ordination.
\seealso{
\code{\link{trplot.qrrvglm}},
- \code{\link{persp.qrrvglm}},
+ \code{\link{perspqrrvglm}},
\code{\link{lvplot}}.
+
+
}
\examples{
-\dontrun{
+\dontrun{ set.seed(123)
hspider[,1:6] = scale(hspider[,1:6]) # Standardized environmental vars
-set.seed(123)
-p1 = cqo(cbind(Alopacce, Alopcune, Alopfabr, Arctlute, Arctperi,
- Auloalbi, Pardlugu, Pardmont, Pardnigr, Pardpull,
- Trocterr, Zoraspin) ~
- WaterCon + BareSand + FallTwig + CoveMoss + CoveHerb + ReflLux,
- fam = quasipoissonff, data = hspider, Crow1positive=FALSE)
+p1cqo = cqo(cbind(Alopacce, Alopcune, Alopfabr, Arctlute, Arctperi,
+ Auloalbi, Pardlugu, Pardmont, Pardnigr, Pardpull,
+ Trocterr, Zoraspin) ~
+ WaterCon + BareSand + FallTwig + CoveMoss + CoveHerb + ReflLux,
+ fam = quasipoissonff, data = hspider, Crow1positive = FALSE)
-nos = ncol(p1 at y)
+nos = ncol(p1cqo at y)
clr = 1:nos # OR (1:(nos+1))[-7] to omit yellow
-trplot(p1, whichSpecies=1:3, log="xy",
- col=c("blue","red","green"), lwd=2, label=TRUE) -> ii
-legend(0.00005, 0.3, paste(ii$species[,1], ii$species[,2], sep=" and "),
- lwd=2, lty=1, col=c("blue","red","green"))
-abline(a=0, b=1, lty="dashed")
-
-
-}
+trplot(p1cqo, whichSpecies = 1:3, log = "xy",
+ col = c("blue","orange","green"), lwd = 2, label = TRUE) -> ii
+legend(0.00005, 0.3, paste(ii$species[,1], ii$species[,2], sep = " and "),
+ lwd = 2, lty = 1, col = c("blue","orange","green"))
+abline(a = 0, b = 1, lty = "dashed") }
}
\keyword{models}
\keyword{regression}
diff --git a/man/trplot.qrrvglm.Rd b/man/trplot.qrrvglm.Rd
index 5ae6e6d..6f1a952 100644
--- a/man/trplot.qrrvglm.Rd
+++ b/man/trplot.qrrvglm.Rd
@@ -8,6 +8,7 @@ Produces a trajectory plot for
(QRR-VGLMs).
It is only applicable for rank-1 models with argument
\code{Norrr = ~ 1}.
+
}
\usage{
trplot.qrrvglm(object, whichSpecies = NULL, add=FALSE, plot.it=TRUE,
@@ -18,7 +19,7 @@ trplot.qrrvglm(object, whichSpecies = NULL, add=FALSE, plot.it=TRUE,
lwd = rep(par()$lwd, len = nos * (nos - 1)/2),
tcol = rep(par()$col, len = nos * (nos - 1)/2),
xlab = NULL, ylab = NULL,
- main = "", type = "b", check.ok=TRUE, ...)
+ main = "", type = "b", check.ok = TRUE, ...)
}
%- maybe also 'usage' for other objects documented here.
\arguments{
@@ -96,13 +97,16 @@ trplot.qrrvglm(object, whichSpecies = NULL, add=FALSE, plot.it=TRUE,
the resulting plot will be very congested, and so it is recommended
that only a few species be selected for plotting.
+
In the above, \eqn{M} is the number of species selected for plotting,
so there will be \eqn{M(M-1)/2}{M*(M-1)/2} curves/trajectories in total.
+
A trajectory plot will be fitted only if \code{Norrr = ~ 1} because
otherwise the trajectory will not be a smooth function of the latent
variables.
+
}
\value{
A list with the following components.
@@ -118,11 +122,12 @@ variables.
}
\references{
-Yee, T. W. (2005)
+Yee, T. W. (2011)
On constrained and unconstrained
quadratic ordination.
\emph{Manuscript in preparation}.
+
}
\author{ Thomas W. Yee }
@@ -138,25 +143,25 @@ quadratic ordination.
}
\seealso{
-\code{\link{cqo}},
-\code{\link[graphics]{par}},
-\code{\link[graphics]{title}}.
+ \code{\link{cqo}},
+ \code{\link[graphics]{par}},
+ \code{\link[graphics]{title}}.
+
}
-\examples{\dontrun{
-set.seed(111) # This leads to the global solution
-# hspider[,1:6]=scale(hspider[,1:6]) # Standardize the environmental variables
+\examples{\dontrun{ set.seed(111) # This leads to the global solution
+# hspider[,1:6] = scale(hspider[,1:6]) # Standardize the environmental variables
p1 = cqo(cbind(Alopacce, Alopcune, Alopfabr, Arctlute, Arctperi, Auloalbi,
Pardlugu, Pardmont, Pardnigr, Pardpull, Trocterr, Zoraspin) ~
WaterCon + BareSand + FallTwig + CoveMoss + CoveHerb + ReflLux,
- fam = poissonff, data = hspider, trace=FALSE)
-
-trplot(p1, whichSpecies=1:3, log="xy", type="b", lty=1,
- main="Trajectory plot of three hunting spiders species",
- col=c("blue","red","green"), lwd=2, label=TRUE) -> ii
-legend(0.00005, 0.3, lwd=2, lty=1, col=c("blue","red","green"),
- with(ii, paste(species.names[,1], species.names[,2], sep=" and ")))
-abline(a=0, b=1, lty="dashed") # Useful reference line
+ fam = poissonff, data = hspider, trace = FALSE)
+
+trplot(p1, whichSpecies = 1:3, log = "xy", type = "b", lty = 1,
+ main = "Trajectory plot of three hunting spiders species",
+ col = c("blue","red","green"), lwd = 2, label = TRUE) -> ii
+legend(0.00005, 0.3, lwd = 2, lty = 1, col = c("blue","red","green"),
+ with(ii, paste(species.names[,1], species.names[,2], sep = " and ")))
+abline(a = 0, b = 1, lty = "dashed") # Useful reference line
}
}
\keyword{models}
diff --git a/man/ugss.Rd b/man/ugss.Rd
index 05169e1..4377a06 100644
--- a/man/ugss.Rd
+++ b/man/ugss.Rd
@@ -54,7 +54,7 @@
\item{\code{smokes}}{Smokes? a factor, (Yes or No) }
\item{\code{alcohol}}{Average amount spent on alcohol per week,
a numeric vector }
- \item{\code{purchase.alcohol}}{Purchases alcohol? a factor, (Yes or No) }
+ \item{\code{buy.alcohol}}{Buys (purchases) alcohol? a factor, (Yes or No) }
\item{\code{sendtxt}}{Average number text messages sent per day,
a numeric vector.}
\item{\code{receivetxt}}{Average number text messages received per day,
diff --git a/man/undocumented-methods.Rd b/man/undocumented-methods.Rd
index 487d988..938ff0b 100644
--- a/man/undocumented-methods.Rd
+++ b/man/undocumented-methods.Rd
@@ -41,6 +41,14 @@
\alias{constraints,vlm-method}
\alias{deplot,vglm-method}
\alias{deplot,vgam-method}
+%
+\alias{depvar,ANY-method}
+\alias{depvar,cao-method}
+\alias{depvar,qrrvglm-method}
+\alias{depvar,rcam-method}
+\alias{depvar,rrvglm-method}
+\alias{depvar,vlm-method}
+%
\alias{deviance,qrrvglm-method}
\alias{deviance,vlm-method}
\alias{deviance,vglm-method}
@@ -130,6 +138,16 @@
%\alias{model.matrix,ANY-method}
\alias{model.matrix,qrrvglm-method}
\alias{model.matrix,vlm-method}
+\alias{nobs,ANY-method}
+\alias{nobs,vlm-method}
+\alias{nvar,ANY-method}
+\alias{nvar,vlm-method}
+\alias{nvar,vgam-method}
+\alias{nvar,rrvglm-method}
+\alias{nvar,qrrvglm-method}
+\alias{nvar,cao-method}
+\alias{nvar,vlm-method}
+\alias{nvar,rcam-method}
\alias{Opt,qrrvglm-method}
\alias{Opt,Coef.qrrvglm-method}
\alias{Opt,uqo-method}
diff --git a/man/vgam-class.Rd b/man/vgam-class.Rd
index aab4582..55af6aa 100644
--- a/man/vgam-class.Rd
+++ b/man/vgam-class.Rd
@@ -241,9 +241,9 @@ Vector generalized additive models.
\examples{
# Fit a nonparametric proportional odds model
-pneumo = transform(pneumo, let=log(exposure.time))
+pneumo = transform(pneumo, let = log(exposure.time))
vgam(cbind(normal, mild, severe) ~ s(let),
- cumulative(parallel=TRUE), pneumo)
+ cumulative(parallel = TRUE), pneumo)
}
\keyword{classes}
\keyword{models}
diff --git a/man/vgam.Rd b/man/vgam.Rd
index fbcfcbe..054f8ee 100644
--- a/man/vgam.Rd
+++ b/man/vgam.Rd
@@ -159,6 +159,7 @@ vgam(formula, family, data = list(), weights = NULL, subset = NULL,
model is a vector generalized linear model (VGLM).
VGLMs are best fitted with \code{\link{vglm}}.
+
Vector (cubic smoothing spline) smoothers are represented
by \code{s()} (see \code{\link[VGAM]{s}}).
Local regression via \code{lo()} is \emph{not}
@@ -168,6 +169,7 @@ vgam(formula, family, data = list(), weights = NULL, subset = NULL,
are chosen because the computation becomes expensive when the number
of additive predictors \eqn{M} is large.
+
The underlying algorithm of VGAMs is iteratively
reweighted least squares (IRLS) and modified vector backfitting
using vector splines. B-splines are used as the basis functions
@@ -175,9 +177,11 @@ vgam(formula, family, data = list(), weights = NULL, subset = NULL,
\code{vgam.fit} is the function that actually does the work.
The smoothing code is based on F. O'Sullivan's BART code.
+
% If more than one of \code{etastart}, \code{start} and \code{mustart}
% is specified, the first in the list will be used.
+
A closely related methodology based on VGAMs called
\emph{constrained additive ordination} (CAO)
first forms a linear combination of the explanatory variables
@@ -185,10 +189,13 @@ vgam(formula, family, data = list(), weights = NULL, subset = NULL,
This is implemented in the function \code{\link{cao}} for a very
limited choice of family functions.
+
}
\value{
An object of class \code{"vgam"}
(see \code{\link{vgam-class}} for further information).
+
+
}
\references{
Yee, T. W. and Wild, C. J. (1996)
@@ -196,14 +203,17 @@ Vector generalized additive models.
\emph{Journal of the Royal Statistical Society, Series B, Methodological},
\bold{58}, 481--493.
+
Yee, T. W. (2008)
The \code{VGAM} Package.
\emph{R News}, \bold{8}, 28--39.
+
Documentation accompanying the \pkg{VGAM} package at
\url{http://www.stat.auckland.ac.nz/~yee}
contains further information and examples.
+
}
\author{ Thomas W. Yee }
@@ -219,6 +229,7 @@ The \code{VGAM} Package.
A third step is to make use of arguments such as \code{etastart},
\code{coefstart} and \code{mustart}.
+
Some \pkg{VGAM} family functions end in \code{"ff"} to avoid
interference with other functions, e.g., \code{\link{binomialff}},
\code{\link{poissonff}}, \code{\link{gaussianff}},
@@ -227,13 +238,16 @@ The \code{VGAM} Package.
(and also \code{\link[gam]{gam}} in the \pkg{gam} library and
\code{\link[mgcv]{gam}} in the \pkg{mgcv} library).
+
The smart prediction (\code{\link{smartpred}}) library is packed with
the \pkg{VGAM} library.
+
The theory behind the scaling parameter is currently being made more
rigorous, but it it should give the same value as the scale parameter
for GLMs.
+
}
@@ -241,19 +255,22 @@ The \code{VGAM} Package.
%~Make other sections like WARNING with \section{WARNING }{....} ~
\seealso{
-\code{\link{vgam.control}},
-\code{\link{vgam-class}},
-\code{\link{vglmff-class}},
-\code{\link{plotvgam}},
-\code{\link{vglm}},
-\code{\link[VGAM]{s}},
-\code{\link{vsmooth.spline}},
-\code{\link{cao}}.
+ \code{\link{vgam.control}},
+ \code{\link{vgam-class}},
+ \code{\link{vglmff-class}},
+ \code{\link{plotvgam}},
+ \code{\link{vglm}},
+ \code{\link[VGAM]{s}},
+ \code{\link{vsmooth.spline}},
+ \code{\link{cao}}.
+
+
}
\examples{ # Nonparametric proportional odds model
pneumo = transform(pneumo, let = log(exposure.time))
-vgam(cbind(normal, mild, severe) ~ s(let), cumulative(par = TRUE), pneumo)
+vgam(cbind(normal, mild, severe) ~ s(let),
+ cumulative(parallel = TRUE), pneumo)
# Nonparametric logistic regression
fit = vgam(agaaus ~ s(altitude, df = 2), binomialff, hunua)
@@ -268,7 +285,7 @@ pfit$sigma
# Fit two species simultaneously
fit2 = vgam(cbind(agaaus, kniexc) ~ s(altitude, df = c(2, 3)),
binomialff(mv = TRUE), hunua)
-coef(fit2, mat = TRUE) # Not really interpretable
+coef(fit2, matrix = TRUE) # Not really interpretable
\dontrun{ plot(fit2, se = TRUE, overlay = TRUE, lcol = 1:2, scol = 1:2)
ooo = with(hunua, order(altitude))
diff --git a/man/vgam.control.Rd b/man/vgam.control.Rd
index 81b0813..8a6900a 100644
--- a/man/vgam.control.Rd
+++ b/man/vgam.control.Rd
@@ -125,23 +125,27 @@ vgam.control(all.knots = FALSE, bf.epsilon = 1e-07, bf.maxit = 30,
}
\details{
+
Most of the control parameters are used within \code{vgam.fit} and
you will have to look at that to understand the full details. Many of
the control parameters are used in a similar manner by \code{vglm.fit}
(\code{\link{vglm}}) because the algorithm (IRLS) is very similar.
+
Setting \code{save.weight=FALSE} is useful for some models because the
\code{weights} slot of the object is often the largest and so less
memory is used to store the object. However, for some \pkg{VGAM}
family function, it is necessary to set \code{save.weight=TRUE} because
the \code{weights} slot cannot be reconstructed later.
+
}
\value{
A list with components matching the input names. A little error
checking is done, but not much.
The list is assigned to the \code{control} slot of \code{\link{vgam}} objects.
+
}
\references{
Yee, T. W. and Wild, C. J. (1996)
@@ -149,15 +153,17 @@ Vector generalized additive models.
\emph{Journal of the Royal Statistical Society, Series B, Methodological},
\bold{58}, 481--493.
-\url{http://www.stat.auckland.ac.nz/~yee}
+
+% \url{http://www.stat.auckland.ac.nz/~yee}
+
}
\author{ Thomas W. Yee}
\note{
- \code{\link{vgam}} does not implement half-stepsizing, therefore parametric
- models should be fitted with \code{\link{vglm}}. Also, \code{\link{vgam}} is
- slower than \code{\link{vglm}} too.
+ \code{\link{vgam}} does not implement half-stepsizing, therefore
+ parametric models should be fitted with \code{\link{vglm}}. Also,
+ \code{\link{vgam}} is slower than \code{\link{vglm}} too.
}
@@ -169,13 +175,13 @@ Vector generalized additive models.
\code{\link{vsmooth.spline}},
\code{\link{vglm}}.
+
}
\examples{
-data(pneumo)
pneumo = transform(pneumo, let = log(exposure.time))
-vgam(cbind(normal, mild, severe) ~ s(let, df = 3), multinomial,
- pneumo, trace = TRUE, eps = 1e-4, maxit = 10)
+vgam(cbind(normal, mild, severe) ~ s(let, df = 2), multinomial,
+ data = pneumo, trace = TRUE, eps = 1e-4, maxit = 10)
}
\keyword{models}
\keyword{regression}
diff --git a/man/vglm-class.Rd b/man/vglm-class.Rd
index e903e78..10dea2e 100644
--- a/man/vglm-class.Rd
+++ b/man/vglm-class.Rd
@@ -223,7 +223,7 @@ Vector generalized additive models.
\examples{
# Multinomial logit model
-pneumo = transform(pneumo, let=log(exposure.time))
-vglm(cbind(normal,mild,severe) ~ let, multinomial, pneumo)
+pneumo = transform(pneumo, let = log(exposure.time))
+vglm(cbind(normal, mild, severe) ~ let, multinomial, pneumo)
}
\keyword{classes}
diff --git a/man/vglm.Rd b/man/vglm.Rd
index 4b20816..6b974b0 100644
--- a/man/vglm.Rd
+++ b/man/vglm.Rd
@@ -69,7 +69,7 @@ vglm(formula, family, data = list(), weights = NULL, subset = NULL,
\item{etastart}{
starting values for the linear predictors.
It is a \eqn{M}-column matrix with the same number of rows as the response.
- If \eqn{M=1} then it may be a vector.
+ If \eqn{M = 1} then it may be a vector.
Note that \code{etastart} and the output of \code{predict(fit)}
should be comparable.
Here, \code{fit} is the fitted object.
@@ -353,7 +353,7 @@ The \code{VGAM} Package.
\code{\link{vgam}}.
Methods functions include
\code{coef.vlm},
- \code{\link{predict.vglm}},
+ \code{\link{predictvglm}},
\code{summary.vglm},
\code{AIC.vglm},
etc.
@@ -362,16 +362,16 @@ The \code{VGAM} Package.
\examples{
# Example 1. See help(glm)
-counts = c(18,17,15,20,10,20,25,13,12)
-outcome = gl(3,1,9)
-treatment = gl(3,3)
-print(d.AD <- data.frame(treatment, outcome, counts))
-vglm.D93 = vglm(counts ~ outcome + treatment, family=poissonff)
+print(d.AD <- data.frame(treatment = gl(3, 3),
+ outcome = gl(3, 1, 9),
+ counts = c(18,17,15,20,10,20,25,13,12)))
+vglm.D93 = vglm(counts ~ outcome + treatment, family=poissonff,
+ data = d.AD, trace = TRUE)
summary(vglm.D93)
# Example 2. Multinomial logit model
-pneumo = transform(pneumo, let=log(exposure.time))
+pneumo = transform(pneumo, let = log(exposure.time))
vglm(cbind(normal, mild, severe) ~ let, multinomial, pneumo)
@@ -379,15 +379,15 @@ vglm(cbind(normal, mild, severe) ~ let, multinomial, pneumo)
fit3 = vglm(cbind(normal,mild,severe) ~ let, propodds, pneumo, trace = TRUE)
coef(fit3, matrix = TRUE)
constraints(fit3)
-model.matrix(fit3, type="lm") # LM model matrix
-model.matrix(fit3) # Larger VGLM (or VLM) model matrix
+model.matrix(fit3, type = "lm") # LM model matrix
+model.matrix(fit3) # Larger VGLM (or VLM) model matrix
# Example 4. Bivariate logistic model
fit4 = vglm(cbind(nBnW, nBW, BnW, BW) ~ age, binom2.or, coalminers)
coef(fit4, matrix = TRUE)
fit4 at y # Response are proportions
-weights(fit4, type="prior")
+weights(fit4, type = "prior")
# Example 5. The use of the xij argument (simple case).
@@ -395,16 +395,16 @@ weights(fit4, type="prior")
nn = 1000
eyesdat = round(data.frame(lop = runif(nn),
rop = runif(nn),
- op = runif(nn)), dig=2)
+ op = runif(nn)), dig = 2)
eyesdat = transform(eyesdat, eta1 = -1+2*lop,
eta2 = -1+2*lop)
eyesdat = transform(eyesdat,
- leye = rbinom(nn, size=1, prob=logit(eta1, inv = TRUE)),
- reye = rbinom(nn, size=1, prob=logit(eta2, inv = TRUE)))
+ leye = rbinom(nn, size = 1, prob = logit(eta1, inv = TRUE)),
+ reye = rbinom(nn, size = 1, prob = logit(eta2, inv = TRUE)))
head(eyesdat)
fit5 = vglm(cbind(leye,reye) ~ op,
- binom2.or(exchangeable = TRUE, zero=3),
- data=eyesdat, trace = TRUE,
+ binom2.or(exchangeable = TRUE, zero = 3),
+ data = eyesdat, trace = TRUE,
xij = list(op ~ lop + rop + fill(lop)),
form2 = ~ op + lop + rop + fill(lop))
coef(fit5)
diff --git a/man/vglm.control.Rd b/man/vglm.control.Rd
index b4f2625..97b14f6 100644
--- a/man/vglm.control.Rd
+++ b/man/vglm.control.Rd
@@ -184,28 +184,28 @@ vglm(cbind(normal, mild, severe) ~ let, multinomial, data = pneumo,
# Example 2. The use of the xij argument (simple case).
-ymat = rdiric(n <- 1000, shape=rep(exp(2), len=4))
-mydat = data.frame(x1=runif(n), x2=runif(n), x3=runif(n), x4=runif(n),
- z1=runif(n), z2=runif(n), z3=runif(n), z4=runif(n))
-mydat = transform(mydat, X=x1, Z=z1)
-mydat = round(mydat, dig=2)
+ymat = rdiric(n <- 1000, shape = rep(exp(2), len = 4))
+mydat = data.frame(x1 = runif(n), x2 = runif(n), x3 = runif(n), x4 = runif(n),
+ z1 = runif(n), z2 = runif(n), z3 = runif(n), z4 = runif(n))
+mydat = transform(mydat, X = x1, Z = z1)
+mydat = round(mydat, dig = 2)
fit2 = vglm(ymat ~ X + Z,
- dirichlet(parallel=TRUE), data=mydat, trace=TRUE,
+ dirichlet(parallel = TRUE), data = mydat, trace = TRUE,
xij = list(Z ~ z1 + z2 + z3 + z4,
X ~ x1 + x2 + x3 + x4),
form2 = ~ Z + z1 + z2 + z3 + z4 +
X + x1 + x2 + x3 + x4)
-head(model.matrix(fit2, type="lm")) # LM model matrix
-head(model.matrix(fit2, type="vlm")) # Big VLM model matrix
+head(model.matrix(fit2, type = "lm")) # LM model matrix
+head(model.matrix(fit2, type = "vlm")) # Big VLM model matrix
coef(fit2)
-coef(fit2, matrix=TRUE)
-max(abs(predict(fit2)-predict(fit2, new=mydat))) # Predicts correctly
+coef(fit2, matrix = TRUE)
+max(abs(predict(fit2)-predict(fit2, new = mydat))) # Predicts correctly
summary(fit2)
\dontrun{
-# plotvgam(fit2, se=TRUE, xlab="x1", which.term=1) # Bug!
-# plotvgam(fit2, se=TRUE, xlab="z1", which.term=2) # Bug!
-plotvgam(fit2, xlab="x1") # Correct
-plotvgam(fit2, xlab="z1") # Correct
+# plotvgam(fit2, se = TRUE, xlab = "x1", which.term = 1) # Bug!
+# plotvgam(fit2, se = TRUE, xlab = "z1", which.term = 2) # Bug!
+plotvgam(fit2, xlab = "x1") # Correct
+plotvgam(fit2, xlab = "z1") # Correct
}
@@ -215,32 +215,30 @@ plotvgam(fit2, xlab="z1") # Correct
set.seed(123)
coalminers = transform(coalminers,
Age = (age - 42) / 5,
- dum1 = round(runif(nrow(coalminers)), dig=2),
- dum2 = round(runif(nrow(coalminers)), dig=2),
- dum3 = round(runif(nrow(coalminers)), dig=2),
- dumm = round(runif(nrow(coalminers)), dig=2))
-BS = function(x, ..., df=3) bs(c(x,...), df=df)[1:length(x),,drop=FALSE]
-NS = function(x, ..., df=3) ns(c(x,...), df=df)[1:length(x),,drop=FALSE]
+ dum1 = round(runif(nrow(coalminers)), dig = 2),
+ dum2 = round(runif(nrow(coalminers)), dig = 2),
+ dum3 = round(runif(nrow(coalminers)), dig = 2),
+ dumm = round(runif(nrow(coalminers)), dig = 2))
+BS = function(x, ..., df = 3) bs(c(x,...), df = df)[1:length(x),,drop = FALSE]
+NS = function(x, ..., df = 3) ns(c(x,...), df = df)[1:length(x),,drop = FALSE]
# Equivalently...
-BS = function(x, ..., df=3) head(bs(c(x,...), df=df), length(x), drop=FALSE)
-NS = function(x, ..., df=3) head(ns(c(x,...), df=df), length(x), drop=FALSE)
+BS = function(x, ..., df = 3) head(bs(c(x,...), df = df), length(x), drop = FALSE)
+NS = function(x, ..., df = 3) head(ns(c(x,...), df = df), length(x), drop = FALSE)
fit3 = vglm(cbind(nBnW,nBW,BnW,BW) ~ Age + NS(dum1,dum2),
- fam = binom2.or(exchang=TRUE, zero=3),
+ fam = binom2.or(exchang = TRUE, zero = 3),
xij = list(NS(dum1,dum2) ~ NS(dum1,dum2) +
NS(dum2,dum1) +
fill(NS(dum1))),
form2 = ~ NS(dum1,dum2) + NS(dum2,dum1) + fill(NS(dum1)) +
dum1 + dum2 + dum3 + Age + age + dumm,
- data = coalminers, trace=TRUE)
-head(model.matrix(fit3, type="lm")) # LM model matrix
-head(model.matrix(fit3, type="vlm")) # Big VLM model matrix
+ data = coalminers, trace = TRUE)
+head(model.matrix(fit3, type = "lm")) # LM model matrix
+head(model.matrix(fit3, type = "vlm")) # Big VLM model matrix
coef(fit3)
-coef(fit3, matrix=TRUE)
-\dontrun{
-plotvgam(fit3, se=TRUE, lcol="red", scol="blue", xlab="dum1")
-}
+coef(fit3, matrix = TRUE)
+\dontrun{ plotvgam(fit3, se = TRUE, lcol = "red", scol = "blue", xlab = "dum1") }
}
\keyword{models}
\keyword{regression}
diff --git a/man/vglmff-class.Rd b/man/vglmff-class.Rd
index 045a8cc..e7833ec 100644
--- a/man/vglmff-class.Rd
+++ b/man/vglmff-class.Rd
@@ -66,7 +66,7 @@ Objects can be created by calls of the form \code{new("vglmff", ...)}.
\code{x} and \code{w}.
}
- \item{\code{inverse}:}{
+ \item{\code{linkinv}:}{
Object of class \code{"function"} which
returns the fitted values, given the linear/additive predictors.
The function must have arguments
@@ -82,7 +82,7 @@ Objects can be created by calls of the form \code{new("vglmff", ...)}.
which becomes the \code{misc} slot on the fitted object.
}
- \item{\code{link}:}{
+ \item{\code{linkfun}:}{
Object of class \code{"function"} which,
given the fitted values, returns the linear/additive predictors.
If present, the function must have arguments
@@ -201,14 +201,14 @@ The file is amongst other \pkg{VGAM} PDF documentation.
A unified method of handling arguments is to use
\code{match.arg}. This allows, for example,
- \code{vglm(..., family = cratio(link=logit))}
+ \code{vglm(..., family = cratio(link = logit))}
and
- \code{vglm(..., family = cratio(link="logi"))}
+ \code{vglm(..., family = cratio(link = "logi"))}
to be equivalent (Nb. there is a \code{logit} function).
The \code{extra} argument in
- \code{inverse}, \code{link}, \code{deviance}, \code{loglikelihood}, etc.
+ \code{linkinv}, \code{linkfun}, \code{deviance}, \code{loglikelihood}, etc.
matches with the argument \code{extra}
in \code{vglm}, \code{vgam} and \code{rrvglm}. This allows input
to be fed into all slots of a \pkg{VGAM} family function.
@@ -242,6 +242,8 @@ The file is amongst other \pkg{VGAM} PDF documentation.
\pkg{VGAM} family functions are not compatible with
\code{\link[stats]{glm}}, nor \code{gam} (from either
\pkg{gam} or \pkg{mgcv} packages).
+
+
}
\seealso{
@@ -250,6 +252,7 @@ The file is amongst other \pkg{VGAM} PDF documentation.
\code{\link{rrvglm}},
\code{\link{rcam}}.
+
}
\examples{
cratio()
diff --git a/man/vonmises.Rd b/man/vonmises.Rd
index 8fca26f..a271ede 100644
--- a/man/vonmises.Rd
+++ b/man/vonmises.Rd
@@ -7,10 +7,10 @@
von Mises distribution by maximum likelihood estimation.
}
\usage{
-vonmises(llocation="elogit", lscale="loge",
- elocation=if(llocation=="elogit") list(min=0, max=2*pi)
- else list(), escale=list(), ilocation=NULL,
- iscale=NULL, imethod=1, zero=NULL)
+vonmises(llocation = "elogit", lscale = "loge",
+ elocation = if(llocation == "elogit") list(min = 0, max = 2*pi)
+ else list(), escale = list(), ilocation = NULL,
+ iscale = NULL, imethod = 1, zero = NULL)
}
%- maybe also 'usage' for other objects documented here.
\arguments{
@@ -123,10 +123,10 @@ New York: Wiley-Interscience, Third edition.
}
\examples{
-vdata = data.frame(x = runif(nn <- 1000))
-vdata = transform(vdata, y = rnorm(nn, m=2+x, sd=exp(0.2))) # Bad data!!
-fit = vglm(y ~ x, vonmises(zero=2), vdata, trace=TRUE)
-coef(fit, matrix=TRUE)
+vdata = data.frame(x2 = runif(nn <- 1000))
+vdata = transform(vdata, y = rnorm(nn, m = 2+x2, sd = exp(0.2))) # Bad data!!
+fit = vglm(y ~ x2, vonmises(zero = 2), vdata, trace = TRUE)
+coef(fit, matrix = TRUE)
Coef(fit)
with(vdata, range(y)) # original data
range(fit at y) # processed data is in [0,2*pi)
diff --git a/man/vsmooth.spline.Rd b/man/vsmooth.spline.Rd
index 9c19d50..cfbb249 100644
--- a/man/vsmooth.spline.Rd
+++ b/man/vsmooth.spline.Rd
@@ -123,8 +123,10 @@ See \code{\link[stats]{smooth.spline}}.
nonlinear part, and using B-splines.
The cost of the computation is \code{O(n M^3)}.
+
The argument \code{spar} contains \emph{scaled} smoothing parameters.
+
}
\value{
An object of class \code{"vsmooth.spline"} (see
@@ -139,6 +141,7 @@ In: Bethlehem, J. G. and van der Heijde, P. G. M.
\emph{Proceedings in Computational Statistics COMPSTAT 2000}.
Heidelberg: Physica-Verlag.
+
}
\author{ Thomas W. Yee }
\note{
@@ -148,12 +151,15 @@ Heidelberg: Physica-Verlag.
For \code{M = 1}, the results will be generally different,
mainly due to the different way the knots are selected.
+
The vector cubic smoothing spline which \code{s()} represents is
computationally demanding for large \eqn{M}.
The cost is approximately \eqn{O(M^3)}.
+
Yet to be done: return the \emph{unscaled} smoothing parameters.
+
}
\seealso{
@@ -168,9 +174,9 @@ Heidelberg: Physica-Verlag.
\examples{
nn = 20; x = 2 + 5*(nn:1)/nn
x[2:4] = x[5:7] # Allow duplication
-y1 = sin(x) + rnorm(nn, sd=0.13)
-y2 = cos(x) + rnorm(nn, sd=0.13)
-y3 = 1 + sin(x) + rnorm(nn, sd=0.13) # Run this for constraints
+y1 = sin(x) + rnorm(nn, sd = 0.13)
+y2 = cos(x) + rnorm(nn, sd = 0.13)
+y3 = 1 + sin(x) + rnorm(nn, sd = 0.13) # Run this for constraints
y = cbind(y1, y2, y3)
ww = cbind(rep(3,nn), 4, (1:nn)/nn)
@@ -180,20 +186,21 @@ plot(fit) # The 1st and 3rd functions do not differ by a constant
}
mat = matrix(c(1,0,1, 0,1,0), 3, 2)
-(fit2 = vsmooth.spline(x, y, w=ww, df=5, iconstr=mat, xconstr=mat))
+(fit2 = vsmooth.spline(x, y, w = ww, df = 5, iconstr = mat, xconstr = mat))
# The 1st and 3rd functions do differ by a constant:
-mycols = c("red","blue","red")
-\dontrun{ plot(fit2, lcol=mycols, pcol=mycols, las=1) }
+mycols = c("orange", "blue", "orange")
+\dontrun{ plot(fit2, lcol = mycols, pcol = mycols, las = 1) }
-p = predict(fit, x=fit at x, deriv=0)
+p = predict(fit, x = fit at x, deriv = 0)
max(abs(fit at y - with(p, y))) # Should be zero
-par(mfrow=c(3,1))
+par(mfrow = c(3, 1))
ux = seq(1, 8, len = 100)
for(d in 1:3) {
- p = predict(fit, x=ux, deriv = d)
-\dontrun{with(p, matplot(x, y, type="l", main=paste("deriv =", d), lwd=2,
- ylab="", cex.axis=1.5, cex.lab=1.5, cex.main=1.5))}
+ p = predict(fit, x = ux, deriv = d)
+\dontrun{with(p, matplot(x, y, type = "l", main = paste("deriv =", d),
+ lwd = 2, ylab = "", cex.axis = 1.5,
+ cex.lab = 1.5, cex.main = 1.5)) }
}
}
\keyword{regression}
diff --git a/man/waitakere.Rd b/man/waitakere.Rd
index a8203ed..09bbde2 100644
--- a/man/waitakere.Rd
+++ b/man/waitakere.Rd
@@ -38,20 +38,22 @@
of 17 plant species was recorded, as well as the altitude.
Each site was of area size 200\eqn{m^2}{m^2}.
+
}
\source{
Dr Neil Mitchell, University of Auckland.
+
}
%\references{
%None.
%}
\seealso{
\code{\link{hunua}}.
+
}
\examples{
-fit = vgam(agaaus ~ s(altitude, df=2), binomialff, waitakere)
-\dontrun{
-plot(fit, se=TRUE, lcol="red", scol="blue") }
-head(predict(fit, waitakere, type="response"))
+fit = vgam(agaaus ~ s(altitude, df = 2), binomialff, waitakere)
+head(predict(fit, waitakere, type = "response"))
+\dontrun{ plot(fit, se = TRUE, lcol = "red", scol = "blue") }
}
\keyword{datasets}
diff --git a/man/wald.Rd b/man/wald.Rd
index 08d24ba..c278c79 100644
--- a/man/wald.Rd
+++ b/man/wald.Rd
@@ -5,20 +5,17 @@
\description{
Estimates the parameter of the standard Wald distribution
by maximum likelihood estimation.
+
}
\usage{
wald(link.lambda = "loge", earg = list(), init.lambda = NULL)
}
%- maybe also 'usage' for other objects documented here.
\arguments{
- \item{link.lambda}{
- Parameter link function for the \eqn{\lambda}{lambda} parameter.
- See \code{\link{Links}} for more choices.
-
- }
- \item{earg}{
- List. Extra argument for the link.
- See \code{earg} in \code{\link{Links}} for general information.
+ \item{link.lambda, earg}{
+ Parameter link function and its extra argument for
+ the \eqn{\lambda}{lambda} parameter.
+ See \code{\link{Links}} for more choices and general information.
}
\item{init.lambda}{
diff --git a/man/weibull.Rd b/man/weibull.Rd
index 3951339..734f7e9 100644
--- a/man/weibull.Rd
+++ b/man/weibull.Rd
@@ -180,10 +180,10 @@ Weibull and GE distributions,
}
\examples{
# Complete data
-wdata = data.frame(x = runif(nn <- 1000))
-wdata = transform(wdata, y = rweibull(nn, shape = exp(1+x), scale = exp(-2)))
-fit = vglm(y ~ x, weibull, wdata, trace = TRUE)
-coef(fit, mat = TRUE)
+wdata = data.frame(x2 = runif(nn <- 1000))
+wdata = transform(wdata, y = rweibull(nn, shape = exp(1 + x2), scale = exp(-2)))
+fit = vglm(y ~ x2, weibull, wdata, trace = TRUE)
+coef(fit, matrix = TRUE)
vcov(fit)
summary(fit)
}
diff --git a/man/weightsvglm.Rd b/man/weightsvglm.Rd
index 52d9b8e..13189c9 100644
--- a/man/weightsvglm.Rd
+++ b/man/weightsvglm.Rd
@@ -50,22 +50,27 @@ weightsvglm(object, type = c("prior", "working"),
}
}
\details{
- Prior weights are usually inputted with the \code{weights} argument in
- functions such as \code{\link{vglm}} and \code{\link{vgam}}. It may
- refer to frequencies of the individual data or be weight matrices
- specified beforehand.
+ Prior weights are usually inputted with the \code{weights}
+ argument in functions such as \code{\link{vglm}} and
+ \code{\link{vgam}}. It may refer to frequencies of the
+ individual data or be weight matrices specified beforehand.
+
+
+ Working weights are used by the IRLS algorithm. They correspond
+ to the second derivatives of the log-likelihood function
+ with respect to the linear predictors. The working weights
+ correspond to positive-definite weight matrices and are returned
+ in \emph{matrix-band} form, e.g., the first \eqn{M} columns
+ correspond to the diagonals, etc.
- Working weights are used by the IRLS algorithm. They correspond to the
- second derivatives of the log-likelihood function with respect to the
- linear predictors. The working weights correspond to positive-definite
- weight matrices and are returned in \emph{matrix-band} form, e.g.,
- the first \eqn{M} columns correspond to the diagonals, etc.
}
\value{
- If \code{type="working"} and \code{deriv=TRUE} then a list is returned
- with the two components described below. Otherwise the prior or
- working weights are returned depending on the value of \code{type}.
+ If \code{type = "working"} and \code{deriv = TRUE} then a
+ list is returned with the two components described below.
+ Otherwise the prior or working weights are returned depending
+ on the value of \code{type}.
+
\item{deriv}{
Typically the first derivative of the
@@ -86,9 +91,12 @@ weightsvglm(object, type = c("prior", "working"),
\emph{Statistical Modelling},
\bold{3}, 15--41.
+
Chambers, J. M. and T. J. Hastie (eds) (1992)
\emph{Statistical Models in S}.
Wadsworth & Brooks/Cole.
+
+
}
\author{ Thomas W. Yee }
@@ -97,6 +105,7 @@ weightsvglm(object, type = c("prior", "working"),
This function is intended to be similar to
\code{weights.glm} (see \code{\link[stats]{glm}}).
+
}
% ~Make other sections like Warning with \section{Warning }{....} ~
@@ -105,6 +114,7 @@ weightsvglm(object, type = c("prior", "working"),
\code{\link[stats]{glm}},
\code{\link{vglmff-class}},
\code{\link{vglm}}.
+
}
\examples{
pneumo = transform(pneumo, let = log(exposure.time))
@@ -117,12 +127,12 @@ weights(fit, type = "prior", matrix = FALSE) # Number of observations
nn = nrow(model.matrix(fit, type = "lm"))
M = ncol(predict(fit))
-temp = weights(fit, type="working", deriv=TRUE)
-wz = m2adefault(temp$weights, M=M) # In array format
+temp = weights(fit, type = "working", deriv = TRUE)
+wz = m2adefault(temp$weights, M = M) # In array format
wzinv = array(apply(wz, 3, solve), c(M, M, nn))
wresid = matrix(NA, nn, M) # Working residuals
for(ii in 1:nn)
- wresid[ii,] = wzinv[,,ii, drop = TRUE] \%*\% temp$deriv[ii,]
+ wresid[ii,] = wzinv[, , ii, drop = TRUE] \%*\% temp$deriv[ii, ]
max(abs(c(resid(fit, type = "w")) - c(wresid))) # Should be 0
(z <- predict(fit) + wresid) # Adjusted dependent vector
diff --git a/man/wffc.P2star.Rd b/man/wffc.P2star.Rd
index 8e0d732..350f13f 100644
--- a/man/wffc.P2star.Rd
+++ b/man/wffc.P2star.Rd
@@ -63,7 +63,7 @@ wffc.P3star(length, c1 = 100, min.eligible = 0.18, ppm = 2000)
% \url{http://www.http://san2010.pl}
% was the official 2010 website.
- Yee, T. W. (2010)
+ Yee, T. W. (2011)
On strategies and issues raised by an analysis of
the 2008 World Fly Fishing Championships data.
\emph{In preparation}.
diff --git a/man/wffc.Rd b/man/wffc.Rd
index 54e9894..75a0f68 100644
--- a/man/wffc.Rd
+++ b/man/wffc.Rd
@@ -113,8 +113,8 @@ is rather poor and furthermore they were not recorded electronically.
these data do not represent individual fish but rather recorded captures.
- Note also that a few internal discrepancies may be found within and between
- the data frames
+ Note also that a few internal discrepancies may be found within
+ and between the data frames
\code{\link{wffc}},
\code{\link{wffc.nc}},
\code{\link{wffc.indiv}},
@@ -147,18 +147,20 @@ is rather poor and furthermore they were not recorded electronically.
The assistance and feedback of Colin Shepherd is gratefully
acknowledged.
+
}
\references{
% \url{http://www.2008worldflyfishingchamps.com}
% is the official website.
+
Yee, T. W. (2010)
VGLMs and VGAMs: an overview for applications in fisheries research.
\emph{Fisheries Research},
\bold{101}, 116--126.
- Yee, T. W. (2010b)
+ Yee, T. W. (2011)
On strategies and issues raised by an analysis of
the 2008 World Fly Fishing Championships data.
\emph{In preparation}.
@@ -177,36 +179,36 @@ otam = subset(wffc, water == "Otamangakau")
roto = subset(wffc, water == "Rotoaira")
minlength = min(wffc[,"length"])
maxlength = max(wffc[,"length"])
-nwater = c("Waihou"=nrow(waihou), "Waimakariri"=nrow(waimak),
- "Whanganui"=nrow(whang), "Otamangakau"=nrow(otam),
- "Rotoaira"=nrow(roto))
+nwater = c("Waihou" = nrow(waihou), "Waimakariri" = nrow(waimak),
+ "Whanganui" = nrow(whang), "Otamangakau" = nrow(otam),
+ "Rotoaira" = nrow(roto))
\dontrun{
-par(mfrow=c(2,3), las=1)
+par(mfrow = c(2,3), las = 1)
# Overall distribution of length
-with(wffc, boxplot(length/10 ~ water, ylim=c(minlength, maxlength)/10,
- border="blue", main="Length (cm)", cex.axis=0.5))
+with(wffc, boxplot(length/10 ~ water, ylim = c(minlength, maxlength)/10,
+ border = "blue", main = "Length (cm)", cex.axis = 0.5))
# Overall distribution of LOG length
-with(wffc, boxplot(length/10 ~ water, ylim=c(minlength, maxlength)/10,
- border="blue", log="y", cex.axis=0.5,
- main="Length (cm) on a log scale"))
+with(wffc, boxplot(length/10 ~ water, ylim = c(minlength, maxlength)/10,
+ border = "blue", log = "y", cex.axis = 0.5,
+ main = "Length (cm) on a log scale"))
# Overall distribution of number of captures
-pie(nwater, border="blue", main="Proportion of captures",
- labels=names(nwater), density=10, col=1:length(nwater),
- angle=85+30* 1:length(nwater))
+pie(nwater, border = "blue", main = "Proportion of captures",
+ labels = names(nwater), density = 10, col = 1:length(nwater),
+ angle = 85+30* 1:length(nwater))
# Overall distribution of number of captures
-with(wffc, barplot(nwater, main="Number of captures", cex.names=0.5,
- col="lightblue"))
+with(wffc, barplot(nwater, main = "Number of captures", cex.names = 0.5,
+ col = "lightblue"))
# Overall distribution of proportion of number of captures
-with(wffc, barplot(nwater / sum(nwater), cex.names=0.5, col="lightblue",
- main="Proportion of captures"))
+with(wffc, barplot(nwater / sum(nwater), cex.names = 0.5, col = "lightblue",
+ main = "Proportion of captures"))
# An interesting lake
-with(roto, hist(length/10, xlab="Fish length (cm)", col="lightblue",
- breaks=seq(18, 70, by=3), prob=TRUE, ylim=c(0, 0.08),
- border="blue", ylab="", main="Lake Rotoaira", lwd=2))
+with(roto, hist(length/10, xlab = "Fish length (cm)", col = "lightblue",
+ breaks = seq(18, 70, by = 3), prob = TRUE, ylim = c(0, 0.08),
+ border = "blue", ylab = "", main = "Lake Rotoaira", lwd = 2))
}
}
\keyword{datasets}
diff --git a/man/wffc.nc.Rd b/man/wffc.nc.Rd
index f26d73f..7ffa2ef 100644
--- a/man/wffc.nc.Rd
+++ b/man/wffc.nc.Rd
@@ -28,9 +28,11 @@
The key variable is \code{numbers}, which is
sector-session-beat specific.
+
Note that some fish may have been caught more than once, hence
these data do not represent individual fish.
+
}
%\source{
% \url{http://www.2008worldflyfishingchamps.com/}.
@@ -41,6 +43,7 @@
\emph{Fisheries Research},
\bold{101}, 116--126.
+
}
\seealso{
diff --git a/man/wffc.teams.Rd b/man/wffc.teams.Rd
index 18b89f8..4642edc 100644
--- a/man/wffc.teams.Rd
+++ b/man/wffc.teams.Rd
@@ -26,6 +26,7 @@
See also \code{\link{wffc}} and \code{\link{wffc.indiv}} for more
details and links.
+
}
%\source{
% \url{http://www.2008worldflyfishingchamps.com/}.
diff --git a/man/yeo.johnson.Rd b/man/yeo.johnson.Rd
index 9b449f9..33c6116 100644
--- a/man/yeo.johnson.Rd
+++ b/man/yeo.johnson.Rd
@@ -33,50 +33,58 @@ yeo.johnson(y, lambda, derivative = 0,
as to improve normality. They can be used to perform LMS
quantile regression.
+
}
\value{
The Yeo-Johnson transformation or its inverse, or its
derivatives with respect to \code{lambda}, of \code{y}.
+
}
\references{
+
Yeo, I.-K. and Johnson, R. A. (2000)
A new family of power transformations to improve normality or symmetry.
\emph{Biometrika},
\bold{87}, 954--959.
+
Yee, T. W. (2004)
Quantile regression via vector generalized additive models.
\emph{Statistics in Medicine}, \bold{23}, 2295--2315.
+
}
\author{ Thomas W. Yee }
\note{
-If \code{inverse=TRUE} then the argument \code{derivative=0} is required.
+ If \code{inverse = TRUE} then the
+ argument \code{derivative = 0} is required.
+
}
\seealso{
-\code{\link{lms.yjn}},
-\code{\link[MASS]{boxcox}}.
+ \code{\link{lms.yjn}},
+ \code{\link[MASS]{boxcox}}.
+
}
\examples{
-y = seq(-4, 4, len= (nn <- 200))
+y = seq(-4, 4, len = (nn <- 200))
ltry = c(0, 0.5, 1, 1.5, 2) # Try these values of lambda
lltry = length(ltry)
-psi = matrix(NA, nn, lltry)
+psi = matrix(as.numeric(NA), nn, lltry)
for(ii in 1:lltry)
- psi[,ii] = yeo.johnson(y, lambda=ltry[ii])
+ psi[,ii] = yeo.johnson(y, lambda = ltry[ii])
\dontrun{
-matplot(y, psi, type="l", ylim=c(-4, 4), lwd=2, lty=1:lltry,
- ylab="Yeo-Johnson transformation", col=1:lltry, las=1,
- main="Yeo-Johnson transformation with some values of lambda")
-abline(v=0, h=0)
-legend(x=c(1), y=c(-0.5), lty=1:lltry, legend=as.character(ltry),
- lwd=2, col=1:lltry) }
+matplot(y, psi, type = "l", ylim = c(-4, 4), lwd = 2, lty = 1:lltry,
+ ylab = "Yeo-Johnson transformation", col = 1:lltry, las = 1,
+ main = "Yeo-Johnson transformation with some values of lambda")
+abline(v = 0, h = 0)
+legend(x = 1, y = -0.5, lty = 1:lltry, legend = as.character(ltry),
+ lwd = 2, col = 1:lltry) }
}
\keyword{models}
\keyword{regression}
diff --git a/man/yip88.Rd b/man/yip88.Rd
index 250b219..06b1902 100644
--- a/man/yip88.Rd
+++ b/man/yip88.Rd
@@ -29,6 +29,7 @@ yip88(link.lambda = "loge", n.arg = NULL)
zeros from the data set, and is thus related to the positive Poisson
distribution (where \eqn{P(Y=0) = 0}).
+
The probability function of \eqn{Y} is 0 with probability
\eqn{\phi}{phi}, and
Poisson(\eqn{\lambda}{lambda}) with probability \eqn{1-\phi}{1-phi}.
@@ -39,19 +40,23 @@ yip88(link.lambda = "loge", n.arg = NULL)
The mean, \eqn{(1-\phi) \lambda}{(1-phi) * lambda}, can be obtained
by the extractor function \code{fitted} applied to the object.
+
This family function treats \eqn{\phi}{phi} as a scalar. If you want
to model both \eqn{\phi}{phi} and \eqn{\lambda}{lambda} as a function
of covariates, try \code{\link{zipoisson}}.
+
}
\value{
An object of class \code{"vglmff"} (see \code{\link{vglmff-class}}).
The object is used by modelling functions such as \code{\link{vglm}},
\code{\link{rrvglm}} and \code{\link{vgam}}.
+
}
\references{
+
Yip, P. (1988)
Inference about the mean of a Poisson distribution in the
presence of a nuisance parameter.
@@ -59,15 +64,14 @@ presence of a nuisance parameter.
\bold{30},
299--306.
+
Angers, J-F. and Biswas, A. (2003)
A Bayesian analysis of zero-inflated generalized Poisson
model.
\emph{Computational Statistics & Data Analysis},
\bold{42}, 37--46.
-Documentation accompanying the \pkg{VGAM} package at
-\url{http://www.stat.auckland.ac.nz/~yee}
-contains further information and examples.
+
}
\author{ Thomas W. Yee }
\note{
@@ -78,10 +82,12 @@ contains further information and examples.
trimmed off during the computation, and the \code{x} and \code{y}
slots of the object, if assigned, will reflect this.
+
The estimate of \eqn{\phi}{phi} is placed in the \code{misc} slot as
\code{@misc$phi}. However, this estimate is computed only for intercept
models, i.e., the formula is of the form \code{y ~ 1}.
+
}
\section{Warning }{
Under- or over-flow may occur if the data is ill-conditioned.
@@ -89,11 +95,13 @@ contains further information and examples.
modelled as a function of covariates. To get around this limitation,
try \code{\link{zipoisson}}.
+
Inference obtained from \code{summary.vglm} and \code{summary.vgam}
may or may not be correct. In particular, the p-values, standard
errors and degrees of freedom may need adjustment. Use simulation on
artificial data to check that these are reasonable.
+
}
\seealso{
\code{\link{zipoisson}},
@@ -102,42 +110,41 @@ contains further information and examples.
\code{\link{pospoisson}},
\code{\link{poissonff}},
\code{\link{dzipois}}.
+
+
}
\examples{
-# Generate some artificial data
-phi = 0.35; lambda = 2
+phi = 0.35; lambda = 2 # Generate some artificial data
y = rzipois(n <- 1000, lambda, phi)
table(y)
# Two equivalent ways of fitting the same model
-fit1 = vglm(y ~ 1, yip88(n=length(y)), subset=y>0, trace=TRUE, crit="c")
-fit2 = vglm(y ~ 1, yip88, trace=TRUE, crit="c")
+fit1 = vglm(y ~ 1, yip88(n = length(y)), subset = y > 0, trace = TRUE)
+fit2 = vglm(y ~ 1, yip88, trace = TRUE, crit = "c")
(true.mean = (1-phi) * lambda)
mean(y)
head(fitted(fit1))
fit1 at misc$phi # The estimate of phi
# Compare the ZIP with the positive Poisson distribution
-pp = vglm(y ~ 1, pospoisson, subset=y>0, tr=TRUE, crit="c")
+pp = vglm(y ~ 1, pospoisson, subset = y > 0, trace = TRUE, crit = "c")
coef(pp)
Coef(pp)
coef(fit1) - coef(pp) # Same
head(fitted(fit1) - fitted(pp)) # Different
-# Another example ------------------------------
-y = 0:7 # Data from Angers and Biswas (2003)
-w = c(182, 41, 12, 2, 2, 0, 0, 1)
-y = y[w>0]
-w = w[w>0]
-yy = rep(y,w)
-
-fit3 = vglm(yy ~ 1, yip88(n=length(yy)), subset=yy>0, trace=TRUE, crit="c")
-fit3 at misc$phi # Estimate of phi (they get 0.5154 with standard error 0.0707)
-coef(fit3, matrix=TRUE)
-Coef(fit3) # Estimate of lambda (they get 0.6997 with standard error 0.1520)
+# Another example (Angers and Biswas, 2003) ---------------------
+abdata = data.frame(y = 0:7, w = c(182, 41, 12, 2, 2, 0, 0, 1))
+abdata = subset(abdata, w > 0)
+
+yy = with(abdata, rep(y, w))
+fit3 = vglm(yy ~ 1, yip88(n = length(yy)), subset = yy > 0, trace = TRUE)
+fit3 at misc$phi # Estimate of phi (they get 0.5154 with SE 0.0707)
+coef(fit3, matrix = TRUE)
+Coef(fit3) # Estimate of lambda (they get 0.6997 with SE 0.1520)
head(fitted(fit3))
-mean(yy) # compare this with fitted(fit3)
+mean(yy) # Compare this with fitted(fit3)
}
\keyword{models}
\keyword{regression}
diff --git a/man/yulesimon.Rd b/man/yulesimon.Rd
index 472eb85..1013e00 100644
--- a/man/yulesimon.Rd
+++ b/man/yulesimon.Rd
@@ -7,7 +7,7 @@
}
\usage{
-yulesimon(link="loge", earg=list(), irho=NULL, nsimEIM=200)
+yulesimon(link = "loge", earg = list(), irho = NULL, nsimEIM = 200)
}
%- maybe also 'usage' for other objects documented here.
\arguments{
@@ -68,11 +68,11 @@ yulesimon(link="loge", earg=list(), irho=NULL, nsimEIM=200)
}
\examples{
-ydata = data.frame(x = runif(nn <- 1000))
-ydata = transform(ydata, y = ryules(nn, rho=exp(1.5-x)))
+ydata = data.frame(x2 = runif(nn <- 1000))
+ydata = transform(ydata, y = ryules(nn, rho = exp(1.5-x2)))
with(ydata, table(y))
-fit = vglm(y ~ x, yulesimon, ydata, trace=TRUE)
-coef(fit, matrix=TRUE)
+fit = vglm(y ~ x2, yulesimon, ydata, trace = TRUE)
+coef(fit, matrix = TRUE)
summary(fit)
}
\keyword{models}
diff --git a/man/yulesimonUC.Rd b/man/yulesimonUC.Rd
index a418bb2..024f713 100644
--- a/man/yulesimonUC.Rd
+++ b/man/yulesimonUC.Rd
@@ -6,12 +6,12 @@
\alias{ryules}
\title{ Yule-Simon Distribution }
\description{
- Density, distribution function, quantile function and random generation
- for the Yule-Simon distribution.
+ Density, distribution function, quantile function and random
+ generation for the Yule-Simon distribution.
}
\usage{
-dyules(x, rho, log=FALSE)
+dyules(x, rho, log = FALSE)
pyules(q, rho)
%qyules(p, rho)
ryules(n, rho)
@@ -19,8 +19,10 @@ ryules(n, rho)
%- maybe also 'usage' for other objects documented here.
\arguments{
\item{x, q}{
- Vector of quantiles. For the density, it should be a vector with
- positive integer values in order for the probabilities to be positive.
+ Vector of quantiles. For the density, it should be a vector
+ with positive integer values in order for the probabilities
+ to be positive.
+
}
% \item{p}{vector of probabilities.}
@@ -28,14 +30,16 @@ ryules(n, rho)
\item{rho}{
See \code{\link{yulesimon}}.
+
}
\item{log}{logical; if TRUE, the logarithm is returned. }
}
\details{
- See \code{\link{yulesimon}}, the \pkg{VGAM} family function
+ See \code{\link{yulesimon}}, the \pkg{VGAM} family function
for estimating the parameter,
for the formula of the probability density function and other details.
+
}
\value{
\code{dyules} gives the density,
@@ -62,9 +66,7 @@ ryules(20, 2.1)
round(1000 * dyules(1:8, 2))
table(ryules(1000, 2))
-\dontrun{
-x = 0:6
-plot(x, dyules(x, rho=2.2), type="h", las=1, col="blue")
-}
+\dontrun{ x = 0:6
+plot(x, dyules(x, rho = 2.2), type = "h", las = 1, col = "blue") }
}
\keyword{distribution}
diff --git a/man/zibinomial.Rd b/man/zibinomial.Rd
index 631da6c..b935e1a 100644
--- a/man/zibinomial.Rd
+++ b/man/zibinomial.Rd
@@ -9,7 +9,7 @@
}
\usage{
zibinomial(lphi = "logit", lmu = "logit", ephi = list(), emu = list(),
- iphi = NULL, zero = 1, mv = FALSE)
+ iphi = NULL, zero = 1, mv = FALSE, imethod = 1)
}
%- maybe also 'usage' for other objects documented here.
\arguments{
@@ -31,21 +31,25 @@ zibinomial(lphi = "logit", lmu = "logit", ephi = list(), emu = list(),
If a vector then recyling is used.
}
- \item{zero}{
- An integer specifying which linear/additive predictor is modelled
- as intercepts only. If given, the value must be either 1 or 2,
- and the default is the first. Setting \code{zero = NULL} enables both
- \eqn{\phi}{phi} and \eqn{\mu}{mu} to be modelled as a function of
- the explanatory variables.
- See \code{\link{CommonVGAMffArguments}} for more information.
-
- }
+% \item{zero}{
+% An integer specifying which linear/additive predictor is modelled
+% as intercepts only. If given, the value must be either 1 or 2,
+% and the default is the first. Setting \code{zero = NULL} enables both
+% \eqn{\phi}{phi} and \eqn{\mu}{mu} to be modelled as a function of
+% the explanatory variables.
+% See \code{\link{CommonVGAMffArguments}} for more information.
+
+% }
\item{mv}{
Logical. Currently it must be \code{FALSE} to mean the function does
not handle multivariate responses. This is to remain compatible with
the same argument in \code{\link{binomialff}}.
}
+ \item{zero, imethod}{
+ See \code{\link{CommonVGAMffArguments}} for information.
+
+ }
}
\details{
This function uses Fisher scoring and is based on
diff --git a/man/zigeomUC.Rd b/man/zigeomUC.Rd
new file mode 100644
index 0000000..c63d3fa
--- /dev/null
+++ b/man/zigeomUC.Rd
@@ -0,0 +1,81 @@
+\name{Zigeom}
+\alias{Zigeom}
+\alias{dzigeom}
+\alias{pzigeom}
+\alias{qzigeom}
+\alias{rzigeom}
+%- Also NEED an '\alias' for EACH other topic documented here.
+\title{ Zero-Inflated Geometric Distribution }
+\description{
+ Density, and random generation
+ for the zero-inflated geometric distribution with parameter \code{pszero}.
+
+}
+\usage{
+dzigeom(x, prob, pszero = 0, log = FALSE)
+pzigeom(q, prob, pszero = 0)
+qzigeom(p, prob, pszero = 0)
+rzigeom(n, prob, pszero = 0)
+}
+%- maybe also 'usage' for other objects documented here.
+\arguments{
+ \item{x, q}{vector of quantiles.}
+ \item{p}{vector of probabilities.}
+ \item{prob}{see \code{\link[stats]{dgeom}}.}
+ \item{n}{number of observations. }
+ \item{pszero}{
+ Probability of structural zero (ignoring the geometric distribution),
+ called \eqn{\phi}{phi}. The default value corresponds
+ to the response having an ordinary geometric distribution.
+
+ }
+ \item{log}{ Logical. Return the logarithm of the answer? }
+}
+\details{
+ The probability function of \eqn{Y} is 0 with probability
+ \eqn{\phi}{phi}, and \eqn{geometric(prob)} with
+ probability \eqn{1-\phi}{1-phi}. Thus
+ \deqn{P(Y=0) =\phi + (1-\phi) P(W=0)}{%
+ P(Y=0) = phi + (1-phi) * P(W=0)}
+ where \eqn{W} is distributed \eqn{geometric(prob)}.
+
+
+}
+\value{
+ \code{dzigeom} gives the density,
+ \code{pzigeom} gives the distribution function,
+ \code{qzigeom} gives the quantile function, and
+ \code{rzigeom} generates random deviates.
+
+
+}
+%\references{ }
+\author{ Thomas W. Yee }
+\note{
+ The argument \code{pszero} is recycled to the required length, and
+ must have values which lie in the interval \eqn{[0,1]}.
+
+}
+
+\seealso{
+ \code{\link{zigeometric}},
+ \code{\link[stats]{dgeom}}.
+
+
+}
+\examples{
+prob = 0.5; pszero = 0.2; x = (-1):20
+(ii = dzigeom(x, prob, pszero))
+max(abs(cumsum(ii) - pzigeom(x, prob, pszero))) # Should be 0
+table(rzigeom(1000, prob, pszero))
+
+\dontrun{ x = 0:10
+barplot(rbind(dzigeom(x, prob, pszero), dgeom(x, prob)),
+ beside = TRUE, col = c("blue","orange"),
+ ylab = "P[Y = y]", xlab = "y", las = 1,
+ main = paste("zigeometric(", prob, ", pszero = ", pszero,
+ ") (blue) vs",
+ " geometric(", prob, ") (orange)", sep = ""),
+ names.arg = as.character(x)) }
+}
+\keyword{distribution}
diff --git a/man/zigeometric.Rd b/man/zigeometric.Rd
new file mode 100644
index 0000000..84e9265
--- /dev/null
+++ b/man/zigeometric.Rd
@@ -0,0 +1,121 @@
+\name{zigeometric}
+\alias{zigeometric}
+%- Also NEED an '\alias' for EACH other topic documented here.
+\title{ Zero-Inflated Geometric Distribution Family Function }
+\description{
+ Fits a zero-inflated geometric distribution by maximum likelihood
+ estimation.
+
+}
+\usage{
+zigeometric(lprob = "logit", eprob = list(),
+ lpszero = "logit", epszero = list(),
+ iprob = NULL, ipszero = NULL,
+ imethod = 1, bias.red = 0.5, zero = 2)
+}
+%- maybe also 'usage' for other objects documented here.
+\arguments{
+ \item{lprob, lpszero}{
+ Link functions for the parameters \code{prob} and \eqn{\phi}{phi}.
+ The usual geometric probability parameter is the former.
+ The probability of a structural zero is the latter.
+ See \code{\link{Links}} for more choices.
+
+ }
+ \item{eprob, epszero}{
+ List. Extra argument for the respective links.
+ See \code{earg} in \code{\link{Links}} for general information.
+
+ }
+ \item{bias.red}{
+ A constant used in the initialization process of \code{pszero}.
+ It should lie between 0 and 1, with 1 having no effect.
+
+ }
+ \item{iprob, ipszero}{
+ See \code{\link{CommonVGAMffArguments}} for information.
+
+ }
+ \item{zero, imethod}{
+ See \code{\link{CommonVGAMffArguments}} for information.
+
+ }
+}
+\details{
+ This function uses Fisher scoring and is based on
+ \deqn{P(Y=0) = \phi + (1-\phi) prob,}{%
+ P(Y=0) = phi + (1-phi) * prob,}
+ for \eqn{y=0}, and
+ \deqn{P(Y=y) = (1-\phi) prob (1 - prob)^{y}.}{%
+ P(Y=y) = (1-phi) * prob * (1 - prob)^y.}
+ for \eqn{y=1,2,\ldots}.
+ The parameter \eqn{\phi}{phi} satisfies \eqn{0 < \phi < 1}{0 <
+ phi < 1}. The mean of \eqn{Y} is \eqn{E(Y)=(1-\phi) prob / (1-prob)}{E(Y)
+ = (1-phi) * prob / (1-prob)} and these are returned as the fitted values.
+ By default, the two linear/additive predictors are \eqn{(logit(prob),
+ logit(\phi))^T}{(logit(prob), logit(phi))^T}.
+
+
+}
+\value{
+ An object of class \code{"vglmff"} (see \code{\link{vglmff-class}}).
+ The object is used by modelling functions such as \code{\link{vglm}}
+ and \code{\link{vgam}}.
+
+
+}
+%\references{
+
+%}
+
+\author{ T. W. Yee }
+\note{
+ Numerical problems may occur since the initial values are currently
+ not very good.
+
+}
+
+\section{Warning }{
+ Numerical problems can occur.
+ Half-stepping is not uncommon.
+ If failure to converge occurs, make use of the argument \code{ipszero}.
+
+}
+
+\seealso{
+ \code{\link{rzigeom}},
+ \code{\link{geometric}},
+ \code{\link[stats]{rgeom}}.
+
+}
+\examples{
+gdata = data.frame(x2 = runif(nn <- 1000) - 0.5)
+gdata = transform(gdata, x3 = runif(nn) - 0.5,
+ x4 = runif(nn) - 0.5)
+gdata = transform(gdata, eta1 = 1.0 - 1.0 * x2 + 2.0 * x3,
+ eta2 = -1.0,
+ eta3 = 0.5)
+gdata = transform(gdata, prob1 = logit(eta1, inverse = TRUE),
+ prob2 = logit(eta2, inverse = TRUE),
+ prob3 = logit(eta3, inverse = TRUE))
+gdata = transform(gdata, y1 = rzigeom(nn, prob1, pszero = prob3),
+ y2 = rzigeom(nn, prob2, pszero = prob3),
+ y3 = rzigeom(nn, prob2, pszero = prob3))
+with(gdata, table(y1))
+with(gdata, table(y2))
+with(gdata, table(y3))
+head(gdata)
+
+fit1 = vglm(y1 ~ x2 + x3 + x4, zigeometric, gdata, trace = TRUE)
+coef(fit1, matrix = TRUE)
+
+fit2 = vglm(y2 ~ 1, zigeometric, gdata, trace = TRUE)
+coef(fit2, matrix = TRUE)
+
+fit3 = vglm(y3 ~ 1, zigeometric, gdata, trace = TRUE)
+coef(fit3, matrix = TRUE)
+summary(fit3)
+}
+\keyword{models}
+\keyword{regression}
+
diff --git a/man/zipoisUC.Rd b/man/zipoisUC.Rd
index 32919b6..b46e038 100644
--- a/man/zipoisUC.Rd
+++ b/man/zipoisUC.Rd
@@ -19,8 +19,8 @@ rzipois(n, lambda, phi = 0)
}
%- maybe also 'usage' for other objects documented here.
\arguments{
- \item{x, q}{vector of quantiles.}
- \item{p}{vector of probabilities.}
+ \item{x, q}{vector of quantiles. }
+ \item{p}{vector of probabilities. }
\item{n}{number of observations. Must be a single positive integer. }
\item{lambda}{ Vector of positive means. }
\item{phi}{
@@ -75,9 +75,9 @@ round(dzipois(0:10, lambda, phi) * 100) # Should be similar
\dontrun{ x = 0:10
barplot(rbind(dzipois(x, lambda, phi), dpois(x, lambda)),
- beside = TRUE, col = c("blue","green"),
+ beside = TRUE, col = c("blue","orange"),
main = paste("ZIP(", lambda, ", phi = ", phi, ") (blue) vs",
- " Poisson(", lambda, ") (green)", sep = ""),
+ " Poisson(", lambda, ") (orange)", sep = ""),
names.arg = as.character(x)) }
}
\keyword{distribution}
diff --git a/man/zipoisson.Rd b/man/zipoisson.Rd
index 579568c..9ad2b0a 100644
--- a/man/zipoisson.Rd
+++ b/man/zipoisson.Rd
@@ -20,15 +20,11 @@ zipoisson(lphi = "logit", llambda = "loge",
}
%- maybe also 'usage' for other objects documented here.
\arguments{
- \item{lphi, llambda}{
- Link function for the parameter \eqn{\phi}{phi}
+ \item{lphi, llambda, ephi, elambda}{
+ Link function and extra argument for the parameter \eqn{\phi}{phi}
and the usual \eqn{\lambda}{lambda} parameter.
- See \code{\link{Links}} for more choices.
-
- }
- \item{ephi, elambda}{
- List. Extra argument for the respective links.
- See \code{earg} in \code{\link{Links}} for general information.
+ See \code{\link{Links}} for more choices,
+ and \code{earg} in \code{\link{Links}} for general information.
See \code{\link{CommonVGAMffArguments}} for more information.
}
@@ -91,6 +87,8 @@ zipoisson(lphi = "logit", llambda = "loge",
\eqn{0 < \phi < 1}{0 < phi < 1}.
The mean of \eqn{Y} is \eqn{(1-\phi) \lambda}{(1-phi)*lambda} and these
are returned as the fitted values.
+ The variance of \eqn{Y} is \eqn{(1-\phi) \lambda (1 + \phi \lambda)}{
+ (1-phi)*lambda*(1 + phi lambda)}.
By default, the two linear/additive predictors are
\eqn{(logit(\phi), \log(\lambda))^T}{(logit(phi), log(lambda))^T}.
This function implements Fisher scoring.
@@ -164,7 +162,7 @@ zipoisson(lphi = "logit", llambda = "loge",
See \pkg{COZIGAM}.
A RR-ZINB model can also be fitted easily;
see \code{\link{zinegbinomial}}.
- Jargon-wies, a COZIGLM might be better described as a
+ Jargon-wise, a COZIGLM might be better described as a
COZIVGLM-ZIP.
diff --git a/src/lms.f b/src/lms.f
index 5c0e908..05953c2 100644
--- a/src/lms.f
+++ b/src/lms.f
@@ -81,7 +81,7 @@
double precision ghz9vuba, i9mwnvqt, mymu, sigma, kpzavbj3mat(4),
&lfu2qhid
integer hbsl0gto, itwo2
- double precision psi, pim12, tad5vhsu(2), two12
+ double precision psi, pim12, tad5vhsu(3), two12
itwo2 = 2
hbsl0gto = 1
if(.not.(lenkpzavbj3mat .gt. 0))goto 23016
@@ -104,7 +104,7 @@
double precision ghz9vuba, i9mwnvqt, mymu, sigma, kpzavbj3mat(4),
&lfu2qhid
integer hbsl0gto, itwo2
- double precision psi, mtpim12, tad5vhsu(2), two12
+ double precision psi, mtpim12, tad5vhsu(3), two12
itwo2 = 2
hbsl0gto = 1
if(.not.(lenkpzavbj3mat .gt. 0))goto 23018
diff --git a/src/zeta3.c b/src/zeta3.c
index 41711f9..d0172c9 100644
--- a/src/zeta3.c
+++ b/src/zeta3.c
@@ -193,7 +193,7 @@ void conmax_Z(double *lamvec, double *nuvec, double *bqelz3cy,
double *qaltf0nz) {
- double *pq6zdcwxk, ssum = 0.0, denom = 0.0, yq6lorbx, prevterm;
+ double *pq6zdcwxk, denom = 0.0, yq6lorbx, prevterm;
int ayfnwr1v;
*qaltf0nz = 1.0e-6;
--
Alioth's /usr/local/bin/git-commit-notice on /srv/git.debian.org/git/debian-science/packages/r-cran-vgam.git
More information about the debian-science-commits
mailing list