[r-cran-vgam] 29/63: Import Upstream version 0.8-7
Andreas Tille
tille at debian.org
Tue Jan 24 13:54:30 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 c2118409064080d8f7079f48a9b5e745a0d8e4ba
Author: Andreas Tille <tille at debian.org>
Date: Tue Jan 24 14:16:55 2017 +0100
Import Upstream version 0.8-7
---
DESCRIPTION | 8 +-
MD5 | 194 +--
NAMESPACE | 23 +-
NEWS | 33 +
R/deviance.vlm.q | 37 +-
R/family.aunivariate.R | 176 ++-
R/family.basics.R | 857 +++++++------
R/family.binomial.R | 609 +++++-----
R/family.categorical.R | 2770 +++++++++++++++++++++++-------------------
R/family.exp.R | 59 +-
R/family.extremes.R | 1141 +++++++++--------
R/family.functions.R | 72 +-
R/family.glmgam.R | 342 +++---
R/family.normal.R | 648 +++++-----
R/family.positive.R | 252 ++--
R/family.qreg.R | 1698 ++++++++++++++------------
R/family.rcam.R | 77 +-
R/family.rrr.R | 572 +++++----
R/family.univariate.R | 1129 ++++++++++-------
R/family.zeroinf.R | 28 +-
R/links.q | 5 +-
R/model.matrix.vglm.q | 448 ++++++-
R/mux.q | 255 ++--
R/predict.vlm.q | 50 +
R/vglm.R | 301 ++---
R/vglm.control.q | 2 +
R/vglm.fit.q | 727 +++++------
data/alclevels.rda | Bin 561 -> 567 bytes
data/alcoff.rda | Bin 558 -> 563 bytes
data/auuc.rda | Bin 243 -> 245 bytes
data/backPain.rda | Bin 469 -> 487 bytes
data/car.all.rda | Bin 6944 -> 6979 bytes
data/crashbc.rda | Bin 388 -> 392 bytes
data/crashf.rda | Bin 355 -> 358 bytes
data/crashi.rda | Bin 501 -> 508 bytes
data/crashmc.rda | Bin 397 -> 401 bytes
data/crashp.rda | Bin 389 -> 393 bytes
data/crashtr.rda | Bin 375 -> 379 bytes
data/crime.us.rda | Bin 3977 -> 3976 bytes
data/datalist | 1 +
data/fibre15.rda | Bin 245 -> 247 bytes
data/fibre1dot5.rda | Bin 295 -> 296 bytes
data/finney44.rda | Bin 207 -> 209 bytes
data/gala.rda | Bin 1050 -> 1051 bytes
data/hspider.rda | Bin 1343 -> 1344 bytes
data/hued.rda | Bin 410 -> 414 bytes
data/huie.rda | Bin 416 -> 418 bytes
data/huse.rda | Bin 321 -> 324 bytes
data/leukemia.rda | Bin 327 -> 329 bytes
data/marital.nz.rda | Bin 10424 -> 10504 bytes
data/mmt.rda | Bin 4223 -> 4222 bytes
data/pneumo.rda | Bin 263 -> 267 bytes
data/rainfall.rda | Bin 11062 -> 11063 bytes
data/ruge.rda | Bin 255 -> 257 bytes
data/toxop.rda | Bin 472 -> 473 bytes
data/ucberk.txt.gz | Bin 0 -> 125 bytes
data/ugss.rda | Bin 11609 -> 11579 bytes
data/venice.rda | Bin 988 -> 976 bytes
data/venice90.rda | Bin 8056 -> 8072 bytes
data/wffc.indiv.rda | Bin 2567 -> 2570 bytes
data/wffc.nc.rda | Bin 4265 -> 4244 bytes
data/wffc.rda | Bin 10245 -> 10253 bytes
data/wffc.teams.rda | Bin 540 -> 541 bytes
data/xs.nz.rda | Bin 221352 -> 221580 bytes
inst/doc/categoricalVGAM.pdf | Bin 677826 -> 677833 bytes
man/CommonVGAMffArguments.Rd | 22 +
man/acat.Rd | 7 +-
man/alaplace3.Rd | 79 +-
man/betaII.Rd | 7 +-
man/binom2.orUC.Rd | 44 +-
man/bratUC.Rd | 25 +-
man/cauchit.Rd | 77 +-
man/cratio.Rd | 10 +-
man/cumulative.Rd | 8 +-
man/dagum.Rd | 8 +-
man/df.residual.Rd | 75 ++
man/fisk.Rd | 9 +-
man/fsqrt.Rd | 103 +-
man/genbetaII.Rd | 24 +-
man/hatvalues.Rd | 263 ++++
man/invlomax.Rd | 9 +-
man/invparalogistic.Rd | 10 +-
man/logit.Rd | 64 +-
man/lomax.Rd | 8 +-
man/model.matrixvlm.Rd | 32 +-
man/multinomial.Rd | 4 +-
man/notdocumentedyet.Rd | 14 +-
man/paralogistic.Rd | 10 +-
man/posbinomUC.Rd | 72 +-
man/posgeomUC.Rd | 18 +-
man/posnegbinUC.Rd | 64 +-
man/pospoisUC.Rd | 15 +-
man/probit.Rd | 37 +-
man/propodds.Rd | 16 +-
man/sinmad.Rd | 7 +-
man/sratio.Rd | 14 +-
man/ucberk.Rd | 69 ++
man/undocumented-methods.Rd | 37 +
man/vglm.Rd | 4 +-
man/vglm.control.Rd | 14 +-
100 files changed, 8059 insertions(+), 5734 deletions(-)
diff --git a/DESCRIPTION b/DESCRIPTION
index ef4d161..854527e 100755
--- a/DESCRIPTION
+++ b/DESCRIPTION
@@ -1,6 +1,6 @@
Package: VGAM
-Version: 0.8-6
-Date: 2012-02-27
+Version: 0.8-7
+Date: 2012-04-13
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>
@@ -17,6 +17,6 @@ Imports: methods, stats, stats4
URL: http://www.stat.auckland.ac.nz/~yee/VGAM
LazyLoad: yes
LazyData: yes
-Packaged: 2012-02-27 06:43:51 UTC; ripley
+Packaged: 2012-04-12 20:01:03 UTC; tyee001
Repository: CRAN
-Date/Publication: 2012-02-27 06:46:06
+Date/Publication: 2012-04-13 10:59:27
diff --git a/MD5 b/MD5
index 7d6d4d4..7bbeab4 100644
--- a/MD5
+++ b/MD5
@@ -1,8 +1,8 @@
60b13c57b66bb77e65321c5c0a3b1dab *BUGS
-9983282911eb6c26048f19ae07b5eb78 *DESCRIPTION
+26f074100689286861a47e26ab4b79cc *DESCRIPTION
dd959d3a0cd680792122813a7d58d506 *DISCLAIMER
-ffdf65e3366ca30fd782477833b83e48 *NAMESPACE
-0834f6f2fc163691846e9f3ed30775df *NEWS
+322232b1f64840d3d3360872f22c9adc *NAMESPACE
+7458e7dbf78a957471b691b3b11bf6ab *NEWS
dd21b3270922941c5f772fcbc0fdbb53 *R/aamethods.q
b3239d3ffdffe1de9581354b05d66016 *R/add1.vglm.q
95904ca107a7d51b5a7a6603304e962b *R/attrassign.R
@@ -14,52 +14,52 @@ b09327ef1094ac0ff74c3283155ea3fb *R/cao.R
9e68dd0424ac75874e253c22099ce952 *R/coef.vlm.q
a3f5ad1bd124d07a69c74b7f917a9a58 *R/cqo.R
e94fae353c86c2ece43792e9c2f777a0 *R/cqo.fit.q
-7b8cf0f581c96ff945342e9b9a86bd48 *R/deviance.vlm.q
+6d76c673deadaf7f4e502bc435292331 *R/deviance.vlm.q
80861c2c2454b9c298e11cbadc431056 *R/effects.vglm.q
-e4f630778920ecc97ae9e561eeb651f9 *R/family.aunivariate.R
-d05c94ac56886d1455d4f47322384a0e *R/family.basics.R
-3d4b21ad6ce25d7ff8a32efdfedbce78 *R/family.binomial.R
+472f0fb8bc4a8adbc9cce363058fbfc7 *R/family.aunivariate.R
+1c8fd0fe2496973ee5916e33de041cd4 *R/family.basics.R
+d66f94ecff21e65dbd27417f0b485a47 *R/family.binomial.R
37abad6c4eaa05fea096bb1f4e3da8cc *R/family.bivariate.R
-011da662eaecf74a957909307678476d *R/family.categorical.R
+ea284e385d89be09aa051fb36c70f785 *R/family.categorical.R
aa067e1804876a7cb4b091aa328af510 *R/family.censored.R
ba2f3c8fe4b2e8ba26973027fa2d676d *R/family.circular.R
-e890b1d9e0081a2ec9972ded68a83c4c *R/family.exp.R
-35cc6d95647629042edfc020e2e128e5 *R/family.extremes.R
+0a25502954db9644a4a2aea9e28992c4 *R/family.exp.R
+b184220a0cd72dac2a00bb463b0cc0a5 *R/family.extremes.R
938226f9a34e4f6fd80108a9a89c2651 *R/family.fishing.R
-e2045b675e24fef59298e82a20604d2d *R/family.functions.R
+b0910b3f615575850e1417740dedaaa7 *R/family.functions.R
1a2e09d03675bb6dff6e61cb2e7c76d5 *R/family.genetic.R
-e4443878ff13242dd5d4591512003cd8 *R/family.glmgam.R
+ebe0608572becf749103b7737c7a7acc *R/family.glmgam.R
3c3fabbb223815ee25a4a5c62c2e3c7b *R/family.loglin.R
e159913225b326c326e2c8bffde57dcc *R/family.math.R
5bb0c3ac9343bbf891bfa432f93dea17 *R/family.mixture.R
0fa3e3d6a3138cc8eac0f320a389ae11 *R/family.nonlinear.R
-bc8a8da5dded0eae4286c2d009c0a227 *R/family.normal.R
+55fc63680ad925f0e69e0fa3af97e2aa *R/family.normal.R
9135d29542ca7103b3a9155b79f65f94 *R/family.others.R
-05a4cbbc15d57f0338680ab0fcc9a314 *R/family.positive.R
-99a2aa62776d03bc8729be73a2f243c1 *R/family.qreg.R
+c60af8cd9158271bb3bf1ae0c8807b56 *R/family.positive.R
+a9ba39cf263d370afa214a38294b6e87 *R/family.qreg.R
fdca4da3063c9acfb9c5abe845c333af *R/family.quantal.R
-17bae8bf7bbd291cc85c48057a975ee1 *R/family.rcam.R
+b7b27b87e010b4a4bcd91a94a65476b9 *R/family.rcam.R
f9ae840ae9e77833947050013e493a29 *R/family.rcqo.R
edc9ff129ca91ba61a4f885131870024 *R/family.robust.R
-f1bbd70c6e43f075af67a6dc9a867e39 *R/family.rrr.R
+fe7dc2264950869720ee398b61893324 *R/family.rrr.R
4b07bd955d32ceb26d12eb62ce121867 *R/family.survival.R
c737f9809bc0727f6733906db4fc8f9e *R/family.ts.R
-501352c1bf58a75dc2f4dab35af013ad *R/family.univariate.R
+fa0b72d0e2ea47b644e8571f0e7ecb6e *R/family.univariate.R
ba86e91c886455a19a223ab62d72910b *R/family.vglm.R
-1b2fccb12954c194140ad6d289666328 *R/family.zeroinf.R
+d1f08f0da3445ebfbdc13a9a67f40b90 *R/family.zeroinf.R
c4209518badc8f38d39cd2d7b8405d24 *R/fittedvlm.R
c6167af1886c3d0340b9b41a66f8d1a9 *R/formula.vlm.q
33aa96487bc94130897db4ca82ec9559 *R/generic.q
-c7ee34c4632f6fe2c8dfc13b9050071c *R/links.q
+204b9b2d8db1b10b17e96e798ea907b1 *R/links.q
0aef958fdd7db1b20ee26c818807d2c1 *R/logLik.vlm.q
12c9c7e7246afe10034cdd60a90a73d0 *R/lrwaldtest.R
-5a4b0002356f5155a223d37c4db23cdf *R/model.matrix.vglm.q
-1d7b6abb53d483524b70173b582cc60a *R/mux.q
+2ad7539a7b037d7e542f7d90378f8591 *R/model.matrix.vglm.q
+76b26cdae089197c27a697d06ad16c30 *R/mux.q
939ddbb40d567790aba7c2e0fbf84ad2 *R/nobs.R
0cb5b755110ed2ada83d8621c94db5ee *R/plot.vglm.q
01e3395c8bf121d1c2a648942397411c *R/predict.vgam.q
b72b8be0e0cccf16319dd8faf03f90c7 *R/predict.vglm.q
-2700d35af398314cbfc29efb3eda71da *R/predict.vlm.q
+e8f63b7ca71b2dc7778c0ae10c13b70d *R/predict.vlm.q
d56618bb580ea017562efbb27aa69ee5 *R/print.vglm.q
04a7a1cc3e40dc1b4e861e191e91edfd *R/print.vlm.q
9fb95687e7080c3b216ee7c79cb1be0a *R/qrrvglm.control.q
@@ -80,62 +80,63 @@ f223707b00020c752536ef95ea7150bb *R/vgam.R
6cc23d07c2031dcad93254f092118ce9 *R/vgam.control.q
726aa9b28c1fb045753253af10152e71 *R/vgam.fit.q
a4c1ebcffe0e1e65daaff53ae414da4c *R/vgam.match.q
-a55a151f6dfe2b990f53bda1ba05d7db *R/vglm.R
-6a90cb8ef0c7344688f28b8c1fa91d23 *R/vglm.control.q
-8848400124bd09e82f5505d5d0f4683a *R/vglm.fit.q
+f03cb94631bcfdccf01e1542fb0f976e *R/vglm.R
+2ef254676e032cb2aca91352565b46d4 *R/vglm.control.q
+fb812b12aaf59ab251153fcc3482e556 *R/vglm.fit.q
38aeb51b3ed4d9a4a5f1af56da21b32b *R/vlm.R
e76f5e142ff6bc7ad92fc0eece93bb9d *R/vlm.wfit.q
991035d00cfe83ca882204627e8c226f *R/vsmooth.spline.q
c1c2fce6995f00d9ec512f818662a7c1 *R/zzz.R
-20af71b6e9c7941180f5cac65b3a2008 *data/alclevels.rda
-aab70e1d478ff0276394f41092ccf175 *data/alcoff.rda
-c807bdeb53b4f84166301dda661a9489 *data/auuc.rda
-5106b445716171a69266916bc7e055e6 *data/backPain.rda
+b67ef2298d32cb077295be681423afb0 *data/alclevels.rda
+7429c1f9203204dadbebc711d77702e1 *data/alcoff.rda
+ef1b7340ee80284a710aa9928f0715c1 *data/auuc.rda
+19326343d8314f353c3191387bcf99f9 *data/backPain.rda
4fa3eac69a59ea5ed0123d54528e5595 *data/backPain.txt.gz
e039fd36c33b359830b2ac811ca7fc49 *data/bmi.nz.txt.xz
-94632d36530fafb1043397ba0db32802 *data/car.all.rda
+845731a9561bc0b05164462304498662 *data/car.all.rda
b29c1a4125f0898885b0a723442d6a92 *data/chest.nz.txt.bz2
0f45f6779a3c3583f4edf68da4045509 *data/chinese.nz.txt.gz
3cb8bc8e1fc615416f0c8838a50b3f51 *data/coalminers.txt.gz
-671d8bbafbccc6f6b9a4b70cec7df06a *data/crashbc.rda
-7b344ca8042a5c2e2d54e992dccca638 *data/crashf.rda
-4585390d90110664136b1a51344427d4 *data/crashi.rda
-c0db241aef6494f367b41abf8e1af762 *data/crashmc.rda
-b88ad849a8715489bc8180d9643c735f *data/crashp.rda
-94fa571b96154f0837f7bac9a21ea780 *data/crashtr.rda
-8d41cbf9902f7253a4b6d783ed4b0175 *data/crime.us.rda
-b94c51afb0b6dbb8bfda5dc65592ab5c *data/datalist
+58964029796c2023e5daedb35933dcf3 *data/crashbc.rda
+fca2a442510ee3bf511baafb954ea2fb *data/crashf.rda
+c8b9f611102c76691de2c8b7eef3e9e8 *data/crashi.rda
+642d9ec5d352c3147f2f508eb49ce511 *data/crashmc.rda
+b84768569fedb251d7a11828e5759829 *data/crashp.rda
+a4735d92081129344077aa4e2ba5897c *data/crashtr.rda
+8332de0e748c5a8b26e45a16b68a95a5 *data/crime.us.rda
+589b28f1ffeffcae40d7135ec24ac92c *data/datalist
08e87bb80a2364697b17ccec6260387c *data/enzyme.txt.gz
-56de06b778fd5bf4e3e764738ad964b6 *data/fibre15.rda
-ea4644affa39d5565a6c3541340cdaf5 *data/fibre1dot5.rda
-cc6a260748efa38f06589f1cdbeee06a *data/finney44.rda
-36cc34dd8ea5279d55a4ff4a5858e940 *data/gala.rda
+ffdcf902fc068c144c21d6a16f8dd842 *data/fibre15.rda
+3000afab70d6fc680758f78b63ed237c *data/fibre1dot5.rda
+c6882bf02d56aa739aa6d983966ec0bb *data/finney44.rda
+8877f885aec9b36d566e89eab1967903 *data/gala.rda
8508a1cb5a09b65616ed9dfe1fc7a7a9 *data/gew.txt.gz
bec512b2d2d680889c9b71c7b97dbffd *data/grain.us.txt.bz2
-353f60a0a152a6680dd73e18313ce351 *data/hspider.rda
-7bdca06f01a53d2f6627d7f16fbcb5c0 *data/hued.rda
-edd2b1de54d57beab99b6df27e80473e *data/huie.rda
+3770872fdbf09060872e7f8f717b02ef *data/hspider.rda
+783ddd6effb518bdac2ae1dd7d2f82f0 *data/hued.rda
+be83d8afb5b70f433d01492faa009ebe *data/huie.rda
dffe21fbabf645127bccc3f3733098a7 *data/hunua.txt.bz2
-55fe633c571d9959b381eff64790be4f *data/huse.rda
-ecea04e7d259d48a8f99bfb98f484113 *data/leukemia.rda
+53a45bc0ea38d4709b7de98e128db620 *data/huse.rda
+129d2d5a1a0b299ea098bec1baff1129 *data/leukemia.rda
aba4885e0eeda8ee887a422fee01e02a *data/lirat.txt.gz
-788d027738638ea01bb2be8f176b8151 *data/marital.nz.rda
-da16695dff97279ba7d1e0ddc58baf32 *data/mmt.rda
+74278085ea65524ef068214bdcc2bea7 *data/marital.nz.rda
+c13925d4856f9a209178ceff2dba4460 *data/mmt.rda
1017612628ed904e97e5a426d307b16f *data/olympic.txt.gz
3ed63397c4a34f3233326ade6cfd1279 *data/oxtemp.txt.gz
-a7bd35ce047757423918ec3df1d0c64f *data/pneumo.rda
-114f50258909aa549be0682ea76f1cbd *data/rainfall.rda
-363e6a27dc9e81112bd600c7edda300a *data/ruge.rda
-c7834fcfd9a9b7189f1a2dc4f4ad93ed *data/toxop.rda
-dd568cf936049ae6856176a9467c42d0 *data/ugss.rda
-6d4ffc05cebc82f53718240ff8f365c8 *data/venice.rda
-927ac069625c6c27255640d027f27ad1 *data/venice90.rda
+e3d97c5cee5ee7827697c89879103fa8 *data/pneumo.rda
+f1a96f02d1e62da318c96bfb05fc1306 *data/rainfall.rda
+2727500fb75423a5ced3144cfc858575 *data/ruge.rda
+bd8941dad8eb9beead509fa807dd4934 *data/toxop.rda
+1b059fc42c890bf89f2282298828d098 *data/ucberk.txt.gz
+232ee16be25487ae3ebd5752da883785 *data/ugss.rda
+7bd431745898cb1f7dcc804fe342a116 *data/venice.rda
+70f931d05360444db16f16db9d5d4bde *data/venice90.rda
e990ca4deea25b60febd2d315a6a9ec4 *data/waitakere.txt.bz2
-2270fe985a9b1a1b28c8e2b3b5809126 *data/wffc.indiv.rda
-563d6436ed4ac5a762037855e2d36ff9 *data/wffc.nc.rda
-8cc72d7b3ec762ed0c78306cf8269906 *data/wffc.rda
-82ecda3285b2922b63e2493a20ccdffe *data/wffc.teams.rda
-352e18b15cd0acc11e30d2b742ab0305 *data/xs.nz.rda
+be09fbf98efe72fdcb84735763d37352 *data/wffc.indiv.rda
+e76a86753610c12b5fa243b067b59ba1 *data/wffc.nc.rda
+a9a2b76507470c917a481f6f4bfe2862 *data/wffc.rda
+57c7609bb51329e07f9f530817b95eca *data/wffc.teams.rda
+c6c0d32c7457735e3fede0d3688dfd2a *data/xs.nz.rda
81f7f0844a196dc48e91870c4cfafc99 *demo/00Index
532aba4ad4cac611141491a5bb886236 *demo/binom2.or.R
a7db0d0c4cc964b01ddbe0cb74153304 *demo/cqo.R
@@ -145,7 +146,7 @@ a3d2728927fc5a3090f8f4ae9af19e1a *demo/vgam.R
00eee385e1a5c716a6f37797c3b4bec5 *demo/zipoisson.R
45d6563f929e021db90f9c0289e6093e *inst/CITATION
51437c0e17cd2de2d3548017336eb8b1 *inst/doc/categoricalVGAM.Rnw
-77fe125caa46c0f8512e84ce87857143 *inst/doc/categoricalVGAM.pdf
+a3ca882ababc2b49df5a6d6ddda3d185 *inst/doc/categoricalVGAM.pdf
e4c5415e487f533b70695b17e40d97bc *inst/doc/categoricalVGAMbib.bib
ae4c252ab1ff7ea5097b50925524c6c8 *man/AA.Aa.aa.Rd
6e6488fe17bda74157417f38f7d63df1 *man/AB.Ab.aB.ab.Rd
@@ -158,7 +159,7 @@ 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
+323c95578027a70f32ccdee741eb7e00 *man/CommonVGAMffArguments.Rd
4c84f8608e7e5a2a69fbb22198aadf95 *man/DeLury.Rd
2243f6f66449d96a9c370d9cb118bc85 *man/G1G2G3.Rd
8594694ec7498eb252846e5e98930532 *man/Inv.gaussian.Rd
@@ -173,8 +174,8 @@ a11e8355c8a19a851bf46809073b526a *man/Qvar.Rd
4f4e89cb6c8d7db676f3e5224d450271 *man/SurvS4.Rd
56b6bf93ed5da4c3e8324758bfde36aa *man/Tol.Rd
69e999f635cae6333515c98a09a8b7c0 *man/VGAM-package.Rd
-a092ccdd940f1f911845d1e4e7ca8f2e *man/acat.Rd
-9d8a50479e0a331261a834e5fe82c65b *man/alaplace3.Rd
+0ac2556ab681b59598ad2170e475f25a *man/acat.Rd
+21abefde36c66867cc91bab989cc28ff *man/alaplace3.Rd
0faf4d7fdfb9526dec05f6ff87680b90 *man/alaplaceUC.Rd
fc94162782c395640db18e1ff7c6ebb5 *man/amh.Rd
df8c8413b03b440d0451f50d92321e0f *man/amhUC.Rd
@@ -188,7 +189,7 @@ ba175111a99a5dd998a544b32e3390d4 *man/auuc.Rd
103d6afe4d897881692170608c47e7a4 *man/benini.Rd
b3e26d0011014d3722b4ecb3675c4aea *man/beniniUC.Rd
73192be7a4732b3e32cdc0edef65010e *man/beta.ab.Rd
-e661e278644730ad0602065afea6c240 *man/betaII.Rd
+5af71e0de7839a5d7661cb20a5431f85 *man/betaII.Rd
41820caae54231fdfe4f43c64c8b2aa6 *man/betabinomUC.Rd
1600b3f2a75c6a60546d1d01523b1b98 *man/betabinomial.Rd
0258e72615475b5afbae20655f7d60f7 *man/betabinomial.ab.Rd
@@ -200,7 +201,7 @@ f2729cad5024784c73e0d9fa6aaef394 *man/betanormUC.Rd
7adaeed3dae23da1a0cc5eb9358d4597 *man/bilogis4UC.Rd
992e6e71ae8c5a12ef3664da492829bc *man/bilogistic4.Rd
c1fe467f3523193935adfd6b8e3ead1a *man/binom2.or.Rd
-e4d7d902c5c17c65f48b0eb17cd14cd9 *man/binom2.orUC.Rd
+048aeadf836fe881f654f34004ae7040 *man/binom2.orUC.Rd
bb62a8e00f036e4c1ffd7b6c24793d78 *man/binom2.rho.Rd
0a679878123b41e3eb8f7ec074c83dd9 *man/binom2.rhoUC.Rd
4863f87dee822d43731cb82da063c443 *man/binomialff.Rd
@@ -213,7 +214,7 @@ bdad9ecfb116c4f30f930bcaf7208735 *man/biplot-methods.Rd
ca0505aeb6143228b5ce142954ed3ba7 *man/borel.tanner.Rd
adc7dfd546ab8430e0806c3b965c4366 *man/bortUC.Rd
d0f5ac12609fb094d86da4a90af85508 *man/brat.Rd
-2753db368f4c6ac8f145ed1988ff599e *man/bratUC.Rd
+0eaf999500ce9554156f37acbfe1e01a *man/bratUC.Rd
124bbd982a378dca2151fcc854a07dfa *man/bratt.Rd
f640961a0c1a206ce052a54bb7b4ca34 *man/calibrate-methods.Rd
702754aad58a33aba1594bc7d2d45acf *man/calibrate.Rd
@@ -223,7 +224,7 @@ f640961a0c1a206ce052a54bb7b4ca34 *man/calibrate-methods.Rd
f15b81668cd82879e8f00897fb30eea9 *man/cao.control.Rd
d42538f50f7b5ce49b81b59403485955 *man/cardUC.Rd
8a2a5e9dfece6f88bc99a4c36cf59457 *man/cardioid.Rd
-56bacf0502ac46e8929d6a8afcef50cf *man/cauchit.Rd
+1981e97b7ba95bd8f97053e46044053f *man/cauchit.Rd
e7b9c33bacc1d02d937453ab6ef7234a *man/cauchy.Rd
2ab80616c05e7aebdcf769c35316eab1 *man/ccoef-methods.Rd
8805fcc3975bce184bc92154da60bc6e *man/ccoef.Rd
@@ -241,15 +242,16 @@ fc640335c7cd7df304a7396820bd46c0 *man/chinese.nz.Rd
c34d8e18e49ac22df6e9e9e0d59ca2a1 *man/constraints.Rd
8d5b5435cea0a91ffdadc459fa8f7905 *man/cqo.Rd
4b6e07b4fe4a71094c99e824f5b3cd91 *man/crashes.Rd
-5c964fdf03906470eaddbbf3d39076ef *man/cratio.Rd
+3c35c47bd05e52f2b596563f05379cd0 *man/cratio.Rd
6fb9db2b54b6b351d5fa6ee4c1e0334e *man/crime.us.Rd
-1ecf20c4f89f51b6c4a4c0345c910b5c *man/cumulative.Rd
-13da678f2c718e0dc6bbbcd38d06ddf4 *man/dagum.Rd
+301fe0cc28a36f05fa5a2b5895f0fa20 *man/cumulative.Rd
+03a50f7a29344538e0d0a64de82d8b46 *man/dagum.Rd
69387a098ea4f01d352f9b3faafbd504 *man/dagumUC.Rd
1f1a2e048bcc0061b8aa5f0d7fcb600b *man/dcennormal1.Rd
b2a696abb80c47fa0497c245c180ba13 *man/deplot.lmscreg.Rd
7f57d255543bc7d13dadf322805c99c0 *man/depvar.Rd
40a6d820457d0015ca60fe3a752ca80d *man/dexpbinomial.Rd
+577b7f18bc996c2d977201415ecd56f1 *man/df.residual.Rd
1bfcb86a014b0b758f50d132bd885679 *man/dirichlet.Rd
47abfbb23c120dd2611c990f1a82b72f *man/dirmul.old.Rd
56435343450179e964797e28af0437e6 *man/dirmultinomial.Rd
@@ -277,7 +279,7 @@ e89421f88d21f4867aec746c47b5e804 *man/fff.Rd
0f91dd411c054004631a677eda63db79 *man/fill.Rd
b929e2ab670eb59700bc4a1db07bbbc0 *man/finney44.Rd
2a71cba3122f180deefc7eac6fd9500f *man/fisherz.Rd
-67865f518cabb0413c9e08042efd55fb *man/fisk.Rd
+72f9c0c153b97d8c9ca99772e65b0d6e *man/fisk.Rd
8a4d96c331c9bd0f8a630a672f1cc2cd *man/fiskUC.Rd
f50d6af678d60e23e1285f5d2c6255cc *man/fittedvlm.Rd
f0dd850a571209fb251db51db2b3d9a7 *man/fnormUC.Rd
@@ -287,14 +289,14 @@ cdfcf8fb1eb1799a197dd90a5a245d9c *man/frankUC.Rd
6f7745678b1aeec1b8dddea8db6f83b3 *man/frechet.Rd
2716982ec8d58016f0d08737aecd8843 *man/frechetUC.Rd
a064b35aec006934e5667bdbbedd1b97 *man/freund61.Rd
-bc47c6ee3e74df598d758b5e16abac90 *man/fsqrt.Rd
+47db6280a78b01c89bc971cc1be5bb3a *man/fsqrt.Rd
13cc0e1a0a95d020031deddecb4af563 *man/gamma1.Rd
152972ee5cd8c6d903ea1faba8d2b207 *man/gamma2.Rd
bc93b6e6e71256cee791e31125b0b1e7 *man/gamma2.ab.Rd
cf2ba12145a4e1626df9585d8fc72987 *man/gammahyp.Rd
66237ca3553faaf444f36b592a1cfc4b *man/garma.Rd
dbdc01466b43ed8302f46b2a63da17bb *man/gaussianff.Rd
-e69868e255358424343cd680205ea6f9 *man/genbetaII.Rd
+72a33bfafdbb835024823d29b540e3b4 *man/genbetaII.Rd
988ec82425b040c71e0bfee8dcef00dd *man/gengamma.Rd
bd63e15c3ac9ad8a8213d4cdc8bb3440 *man/gengammaUC.Rd
47fd021736f77a04595d5c12e7ad4842 *man/genpoisson.Rd
@@ -315,6 +317,7 @@ d262446f558ffbaba51cc8ff86e5ab1a *man/grain.us.Rd
fce5cc2b341eb7e67c00f8c0d91ea287 *man/gumbelIbiv.Rd
c3115a24f1bcd264b17912ed76c8fdb6 *man/gumbelUC.Rd
d60aa16831b87c86aaa5648b6c4afc76 *man/guplot.Rd
+c1a9370d3c80cd92d9510442da0ff940 *man/hatvalues.Rd
00b132289191052ac14659de9ab936fc *man/hspider.Rd
b5224b8a3e3ed7eae77129374e17c95c *man/huber.Rd
bbd60b4a3ab257638df3ca1d0e99df63 *man/huberUC.Rd
@@ -332,9 +335,9 @@ f134ace4dd0689809500d58933cff6dc *man/hypersecant.Rd
7266e5dba641098cd882cb62a8e33244 *man/identity.Rd
7736014b1a24efd32b9f35eda358fe5e *man/inv.gaussianff.Rd
941470d5ff5e3a83089d1ec1af026f35 *man/invbinomial.Rd
-126b1730f039090da87aaf947455c98b *man/invlomax.Rd
+15700926fcf2de393742f4758736b2a3 *man/invlomax.Rd
01cb2a27a9c0eae7d315f3ca158749f5 *man/invlomaxUC.Rd
-25bf1baa9a1a4e7c9074e94572318db6 *man/invparalogistic.Rd
+91301add8e408d69c13e469769c8370f *man/invparalogistic.Rd
c0161485e2448b7abdfd3da5ab738c0e *man/invparalogisticUC.Rd
a286dd7874899803d31aa0a72aad64f2 *man/is.smart.Rd
2e3e9b010e6c48ebc38720fe7a1d88fc *man/koenker.Rd
@@ -361,7 +364,7 @@ c362d03bf3e2c4c24f8e0f46af093a09 *man/logc.Rd
f3d3ed74f201143d09a98f938b684c6a *man/loge.Rd
e5c36efa7e692fd32de85fd9c4a347db *man/logff.Rd
5b7b7b672758091d20d8ff0f358f2550 *man/logistic.Rd
-117884ae7e831a397caedf145a434c28 *man/logit.Rd
+6f266ae1d6b63a114aa4b8ae6ead9ecd *man/logit.Rd
1da3783f1662d799690fdd081f721ee0 *man/loglapUC.Rd
3ffe1e60703b15f818cd7972cd8f44a9 *man/loglaplace.Rd
8232a213dfc8899703f6e57664efae69 *man/loglinb2.Rd
@@ -369,7 +372,7 @@ dcbd827fd3586f46fc4ca1a1495a9ea1 *man/loglinb3.Rd
dd9c84ba9c07cc9414175b41d94fe1f0 *man/loglog.Rd
ff85df21653d22ed4cbf3138f82049d8 *man/lognormal.Rd
aad78245c7c13be5d22efbff8774adf8 *man/logoff.Rd
-448a8a2f7e4dbec62a07f699bceb0650 *man/lomax.Rd
+0e3d32a8a20c59a5d7c7a4b1e9afb7bf *man/lomax.Rd
1fa1bf8d11541be8d48de2ff954462b4 *man/lomaxUC.Rd
138808d36f9fb37444e28e0d2c426dd1 *man/lqnorm.Rd
f6ce6b9c84be7adf18b37a78ea6622b6 *man/lrtest.Rd
@@ -389,10 +392,10 @@ f08033557088369199e94547b1740580 *man/maxwell.Rd
032b58b8746fb0d18ed355acd28afa7f *man/mix2normal1.Rd
4aaae69710cd08f08bb7ce432cf2108d *man/mix2poisson.Rd
1d7e090a54f5524e6fe0711bb942be47 *man/model.framevlm.Rd
-0db10fd10f2e69997d9fe9242aea3c7d *man/model.matrixvlm.Rd
+1ba41606eeea0ea3cd41bfc2098cc35d *man/model.matrixvlm.Rd
febba2e46a2084aff84e8c76a388e400 *man/moffset.Rd
dde2999ddb57cc4af821b2d2e2b65251 *man/morgenstern.Rd
-07fe33dc7b8afa5a25c52d7030788266 *man/multinomial.Rd
+056cc7964ecd77586d22a375ad879322 *man/multinomial.Rd
29ce3642cdb940b4bdbba7f6173a6a60 *man/nakagami.Rd
d87f98ccf030b9925fa27475890cd27e *man/nakagamiUC.Rd
38c45f8d05c910a957456dcb22c2cd4f *man/nbcanlink.Rd
@@ -400,11 +403,11 @@ d87f98ccf030b9925fa27475890cd27e *man/nakagamiUC.Rd
285532c1c7ad5b17bc7ad287bef549d8 *man/negbinomial.Rd
4511975c94fcfbe834ba7ca3e457c98d *man/negbinomial.size.Rd
4c8b84458e8ee97cf8ec3189da73a78d *man/normal1.Rd
-b1b213e6113e6896acd7e8b2acaba125 *man/notdocumentedyet.Rd
+6df574ccfad885dcffa172e12a14904b *man/notdocumentedyet.Rd
8a118515f4955e425adcd83f7da456ec *man/olympic.Rd
1ca5bd6a9ee667125ba379e48e66c99e *man/ordpoisson.Rd
9ecbe9ab6cc7d40f41f10a71fdae5996 *man/oxtemp.Rd
-af3da753da81709490046832ea545701 *man/paralogistic.Rd
+ae5c6514e182459fe0d59771b49246c3 *man/paralogistic.Rd
e82353ff6171e11bbeae4e3687bca231 *man/paralogisticUC.Rd
97dc353975a803fd33bebd083c85713d *man/pareto1.Rd
3c9ba189fa4f71114f3aa7248c169951 *man/paretoIV.Rd
@@ -423,21 +426,21 @@ de61bd1899e2bd101d3977d2e25f163f *man/poissonff.Rd
aea0d6dabf75a88fc5bbf4cf77fef7ec *man/poissonp.Rd
8abbf4f53f755542e7197830d026f514 *man/polf.Rd
a2fb4efb4037aaa2362579d73e78defa *man/polonoUC.Rd
-0d1147afa73af7ae0860f36d2d7732f3 *man/posbinomUC.Rd
+2d239f593b34e2342faaf3ba2e8f55c2 *man/posbinomUC.Rd
67c1153ac99b572401e73d68f665b2ab *man/posbinomial.Rd
-e73cb6828656ad718bbef4a46548e2ee *man/posgeomUC.Rd
-76788187cad5a084cb5ad798b934bd07 *man/posnegbinUC.Rd
+6ec345e5d20c36bdde7b7d09c9b71893 *man/posgeomUC.Rd
+a5f4a74e36b56b1b6799650c38a95f22 *man/posnegbinUC.Rd
ccfe5f42d992cf7aa5f5309dade4aaf5 *man/posnegbinomial.Rd
0e2ea2f46537b34ccc6603fe56303983 *man/posnormUC.Rd
c4f9abd34a4cd9ea5b8a6fc3b88abd83 *man/posnormal1.Rd
-fdc592c22ffaf895ff085a9010bf7a17 *man/pospoisUC.Rd
+bfa5a34fbeeca1ee107e2fc332f1ec1a *man/pospoisUC.Rd
6cde192a6dbad131523057890c565ab2 *man/pospoisson.Rd
95386d432e396127192e5516a35059cd *man/powl.Rd
f5ca83cbbe57ce6a7e98a0318ddc6aac *man/predictqrrvglm.Rd
10003ea86273bd156fdbd6990c5f80d5 *man/predictvglm.Rd
d2b5e03b84a6c8b6ba9553155445c694 *man/prentice74.Rd
-b0913ae27b2f0ab1e032bf3398a78d5a *man/probit.Rd
-f400ce682e069e8cdacf3f6bbe187d69 *man/propodds.Rd
+1de751c9f36f6a6d826458e0006acf36 *man/probit.Rd
+e7a5908f988925eed1f176d91086b578 *man/propodds.Rd
dc7a643eba4c2ac7bbd842ed27eb1023 *man/prplot.Rd
de570e252375d7052edaa7fb175f67eb *man/put.smart.Rd
602637ecc0fab44f08f45caab838f1fb *man/qrrvglm.control.Rd
@@ -468,7 +471,7 @@ b5936590eb374807b15d3d6f10257496 *man/ruge.Rd
71367fe3b494a45c98f9a96e1fd791e0 *man/setup.smart.Rd
fa349f195a44efe47ba19726c6d96725 *man/simplex.Rd
0b224135695156ba53178b78ba64690d *man/simplexUC.Rd
-d214ee1c6de6c4c8150be022d0b37c3a *man/sinmad.Rd
+407c6118fc59774474e3a15832de6c49 *man/sinmad.Rd
d406cb5ce0d23612220d9011346b96e0 *man/sinmadUC.Rd
6e0c8526ef9dc5b8088eacec6d611448 *man/skellam.Rd
3b158a36468b4e9cb6ac33c6ecb7e59a *man/skellamUC.Rd
@@ -479,7 +482,7 @@ d406cb5ce0d23612220d9011346b96e0 *man/sinmadUC.Rd
163cdb3e4a225aceee82e2d19488d56e *man/smart.mode.is.Rd
2b68a9e20182e8892bb7be344e58e997 *man/smartpred.Rd
bd869816cc0a7a1af02285c8ff7b6fbc *man/snormUC.Rd
-930706a4ce59b848dd733a0944ca41dc *man/sratio.Rd
+fc8592ac8305dddbed31b11be3b532b4 *man/sratio.Rd
6842d2562b09bd347aeb9e7cdb55f11e *man/studentt.Rd
5585a51bdfb69f8366df3eb46b950885 *man/tikuv.Rd
da0473cfe60820a64e74d4e2d7492927 *man/tikuvUC.Rd
@@ -491,8 +494,9 @@ d656850a7fba6056bfcaf07a00510110 *man/triangle.Rd
8c327c816d9d56403d617a32fa704e9d *man/triangleUC.Rd
8fb0fbd98a56b1afced6cdceabea5c34 *man/trplot.Rd
5cab3d39bc52ba50848cdfcf64199d4c *man/trplot.qrrvglm.Rd
+50ada9ecd189456ce9f218d22b49089c *man/ucberk.Rd
1fc91e082e70251f46af4261f7d48f78 *man/ugss.Rd
-fc7e9713ea6a1c4216edd99f11bb8eb9 *man/undocumented-methods.Rd
+e9c44e172adbcba6a3818e74b180d343 *man/undocumented-methods.Rd
8d8835dd870d94aafa3259ecd2568337 *man/uqo.Rd
f9eeeaeacdb82471c5230468b61d7bdd *man/uqo.control.Rd
986f3ae218b563bae795b67131082609 *man/venice.Rd
@@ -500,8 +504,8 @@ f9eeeaeacdb82471c5230468b61d7bdd *man/uqo.control.Rd
6b001b0875c0a2b48f0bb61c683acdcf *man/vgam.Rd
1d53ebf6fecfac1f339841ef9b3e8dac *man/vgam.control.Rd
b2bdeb9d2a6e9c2e7b8964d334b4378e *man/vglm-class.Rd
-4712b2fd1c5052f11b9c4fe7a02d8dbf *man/vglm.Rd
-d942f0381dec1582da7f219f4f4dfeca *man/vglm.control.Rd
+fc5b02dd911753d18db07a25d7da3352 *man/vglm.Rd
+3332b24703a86d05ce7f4f17417b6e15 *man/vglm.control.Rd
d7e7f317461e888a57ee1082db178328 *man/vglmff-class.Rd
e12f38d6fc651548bc7badbbee4b6d49 *man/vonmises.Rd
060df7afe140d1ef3b498e1492a9c1bb *man/vsmooth.spline.Rd
diff --git a/NAMESPACE b/NAMESPACE
index fedd5c1..511566c 100644
--- a/NAMESPACE
+++ b/NAMESPACE
@@ -8,6 +8,12 @@ useDynLib(VGAM)
+
+importFrom("stats4", nobs)
+exportMethods(nobs)
+
+
+
importMethodsFrom("stats4")
@@ -16,6 +22,19 @@ importFrom(stats4, AIC, coef, summary, plot, logLik, vcov)
exportMethods(AIC, coef, summary, plot, logLik, vcov)
+export(npred, npred.vlm)
+exportMethods(npred)
+export(hatvalues, hatvaluesvlm)
+exportMethods(hatvalues)
+importFrom("stats", hatvalues)
+
+
+export(dfbeta, dfbetavlm)
+exportMethods(dfbeta)
+
+
+export(hatplot, hatplot.vlm)
+exportMethods(hatplot)
export(VGAMenv)
@@ -29,7 +48,6 @@ export(nvar, nvar.vlm, nvar.vgam, nvar.rrvglm, nvar.qrrvglm, nvar.cao, nvar.rcam
export( nobs.vlm)
-
export(plota21)
@@ -173,7 +191,8 @@ coefvsmooth.spline, coefvsmooth.spline.fit,
constraints, constraints.vlm,
deplot, deplot.default, deplot.lms.bcg, deplot.lms.bcn,
deplot.lms.yjn, deplot.lms.yjn2, deplot.vglm,
-deviance.uqo, deviance.vglm, deviance.vlm, df.residual.vlm,
+deviance.uqo, deviance.vglm, deviance.vlm,
+df.residual_vlm,
dirmultinomial, dirmul.old,
dnorm2,
dtheta.deta)
diff --git a/NEWS b/NEWS
index 61ea009..c7b3e45 100755
--- a/NEWS
+++ b/NEWS
@@ -6,6 +6,39 @@
+ CHANGES IN VGAM VERSION 0.8-7
+
+NEW FEATURES
+
+ o Modified VGAM family functions:
+ genbetaII()@initialize has been improved, as well as
+ those special cases of that distribution (such as sinmad,
+ lomax, paralogistic, dagum, etc.).
+ o Argument 'lapred.index' added to model.matrix().
+ o npred() is now defined as a generic function (returns M).
+ o hatvalues() and hatplot() written for vglm() objects.
+ o The argument 'qr.arg' is set TRUE now by default in vglm().
+ o df.residual() supports the argument 'type = c("vlm", "lm")'.
+ o Argument 'nowarning' added to vglm.control().
+ o New data set: ucberk.
+ o Improved functions: rposbinom(), rposgeom(), rposnegbin(),
+ rpospois().
+ o Tested okay on R 2.15.0.
+
+
+BUG FIXES and CHANGES
+
+ o Labelling of the linear predictors for sratio(), cratio()
+ etc. was faulty.
+ o pbetabinom.ab() did not recycle shape1 correctly
+ [found by David Venet].
+ o Arguments lower.tail and log.p not supported (temporarily) in
+ pposbinom() and qposbinom().
+
+
+
+
+
CHANGES IN VGAM VERSION 0.8-6
NEW FEATURES
diff --git a/R/deviance.vlm.q b/R/deviance.vlm.q
index 6c8c194..8db09b2 100644
--- a/R/deviance.vlm.q
+++ b/R/deviance.vlm.q
@@ -4,50 +4,45 @@
+
+
deviance.vlm <- function(object, ...)
object at criterion$deviance
+
deviance.vglm <- function(object, ...)
object at criterion$deviance
-
if(!isGeneric("deviance"))
- setGeneric("deviance", function(object, ...) standardGeneric("deviance"))
+ setGeneric("deviance", function(object, ...)
+ standardGeneric("deviance"))
setMethod("deviance", "vlm", function(object, ...)
deviance.vlm(object, ...))
-if(is.R()) {
+setMethod("deviance", "vglm", function(object, ...)
+ deviance.vglm(object, ...))
- setMethod("deviance", "vglm", function(object, ...)
- deviance.vglm(object, ...))
-} else {
- setMethod("deviance", "vglm", function(object, ...)
- deviance.vglm(object, ...))
-}
+df.residual_vlm <- function(object, type = c("vlm", "lm"), ...) {
+ type <- type[1]
+ switch(type,
+ vlm = object at df.residual,
+ lm = nobs(object, type = "lm") - nvar(object, type = "lm"),
+ stop("argument 'type' unmatched"))
+}
-df.residual.vlm <- function(object, ...)
- object at df.residual
-if(is.R()) {
- setMethod("df.residual", "vlm", function(object, ...)
- df.residual.vlm(object, ...))
-} else {
- if (!isGeneric("df.residual"))
- setGeneric("df.residual", function(object, ...)
- standardGeneric("df.residual"))
- setMethod("df.residual", "vlm", function(object, ...)
- df.residual.vlm(object, ...))
-}
+setMethod("df.residual", "vlm", function(object, ...)
+ df.residual_vlm(object, ...))
diff --git a/R/family.aunivariate.R b/R/family.aunivariate.R
index d079f5a..7d0e828 100644
--- a/R/family.aunivariate.R
+++ b/R/family.aunivariate.R
@@ -266,7 +266,9 @@ riceff.control <- function(save.weight = TRUE, ...) {
stop("bad input for argument 'isigma'")
if (!is.list(evee)) evee = list()
if (!is.list(esigma)) esigma = list()
- if (!is.Numeric(nsimEIM, allowable.length = 1, integer.valued = TRUE) || nsimEIM <= 50)
+ if (!is.Numeric(nsimEIM, allowable.length = 1,
+ integer.valued = TRUE) ||
+ nsimEIM <= 50)
stop("'nsimEIM' should be an integer greater than 50")
new("vglmff",
@@ -295,10 +297,12 @@ riceff.control <- function(save.weight = TRUE, ...) {
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.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)
+ 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))
@@ -437,18 +441,22 @@ skellam.control <- function(save.weight = TRUE, ...) {
nsimEIM = 100, parallel = FALSE, zero = NULL)
{
if (mode(lmu1) != "character" && mode(lmu1) != "name")
- lmu1 = as.character(substitute(lmu1))
+ lmu1 = as.character(substitute(lmu1))
if (mode(lmu2) != "character" && mode(lmu2) != "name")
- lmu2 = as.character(substitute(lmu2))
- if (length(imu1) && !is.Numeric(imu1, positive = TRUE))
- stop("bad input for argument 'imu1'")
- if (length(imu2) && !is.Numeric(imu2, positive = TRUE))
- stop("bad input for argument 'imu2'")
+ lmu2 = as.character(substitute(lmu2))
+ if (length(imu1) &&
+ !is.Numeric(imu1, positive = TRUE))
+ stop("bad input for argument 'imu1'")
+ if (length(imu2) &&
+ !is.Numeric(imu2, positive = TRUE))
+ stop("bad input for argument 'imu2'")
+
if (!is.list(emu1)) emu1 = list()
if (!is.list(emu2)) emu2 = list()
- if (!is.Numeric(nsimEIM, allowable.length = 1, integer.valued = TRUE) ||
+ if (!is.Numeric(nsimEIM, allowable.length = 1,
+ integer.valued = TRUE) ||
nsimEIM <= 50)
- stop("'nsimEIM' should be an integer greater than 50")
+ stop("'nsimEIM' should be an integer greater than 50")
new("vglmff",
blurb = c("Skellam distribution\n\n",
@@ -476,8 +484,10 @@ skellam.control <- function(save.weight = TRUE, ...) {
mean.init = weighted.mean(y, w)
mu1.init = max((var.y.est + mean.init)/2, 0.01)
mu2.init = max((var.y.est - mean.init)/2, 0.01)
- mu1.init = rep(if(length( .imu1)) .imu1 else mu1.init, length=n)
- mu2.init = rep(if(length( .imu2)) .imu2 else mu2.init, length=n)
+ mu1.init = rep(if(length( .imu1 )) .imu1 else mu1.init,
+ length = n)
+ mu2.init = rep(if(length( .imu2 )) .imu2 else mu2.init,
+ length = n)
etastart = cbind(theta2eta(mu1.init, .lmu1, earg = .emu1),
theta2eta(mu2.init, .lmu2, earg = .emu2))
}
@@ -608,17 +618,20 @@ yulesimon.control <- function(save.weight = TRUE, ...) {
yulesimon = function(link = "loge", earg = list(), irho = NULL, nsimEIM = 200)
{
- if (length(irho) && !is.Numeric(irho, positive = TRUE))
- stop("argument 'irho' must be > 0")
+ if (length(irho) &&
+ !is.Numeric(irho, positive = TRUE))
+ stop("argument 'irho' must be > 0")
if (mode(link) != "character" && mode(link) != "name")
- link = as.character(substitute(link))
+ link = as.character(substitute(link))
if (!is.list(earg)) earg = list()
- if (!is.Numeric(nsimEIM, allowable.length = 1, integer.valued = TRUE) ||
+ if (!is.Numeric(nsimEIM, allowable.length = 1,
+ integer.valued = TRUE) ||
nsimEIM <= 50)
- stop("'nsimEIM' should be an integer greater than 50")
+ stop("'nsimEIM' should be an integer greater than 50")
new("vglmff",
- blurb = c("Yule-Simon distribution f(y) = rho*beta(y,rho+1), rho>0, y=1,2,..\n\n",
+ blurb = c("Yule-Simon distribution f(y) = rho*beta(y,rho+1), ",
+ "rho>0, y=1,2,..\n\n",
"Link: ",
namesof("p", link, earg =earg), "\n\n",
"Mean: rho/(rho-1), provided rho>1\n",
@@ -636,7 +649,8 @@ yulesimon.control <- function(save.weight = TRUE, ...) {
if (!length(etastart)) {
wmeany = weighted.mean(y, w) + 1/8
rho.init = wmeany / (wmeany - 1)
- rho.init = rep( if (length( .irho )) .irho else rho.init, len = n)
+ 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 ))),
@@ -698,7 +712,10 @@ dslash <- function(x, mu = 0, sigma = 1, log = FALSE,
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)
+ 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)),
@@ -707,11 +724,15 @@ dslash <- function(x, mu = 0, sigma = 1, log = FALSE,
-expm1(-zedd^2/2)/(sqrt(2*pi)*sigma*zedd^2))
}
+
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))
- q = rep(q, len = L); mu = rep(mu, len = L); sigma = rep(sigma, len = L)
+ q = rep(q, len = L);
+ mu = rep(mu, len = L);
+ sigma = rep(sigma, len = L)
+
ans = q * NA
for (ii in 1:L) {
temp = integrate(dslash, lower = -Inf, upper = q[ii])
@@ -723,17 +744,21 @@ pslash <- function(q, mu = 0, sigma = 1){
ans
}
+
rslash <- function (n, mu = 0, sigma = 1){
- if (!is.Numeric(n, positive = TRUE, integer.valued = TRUE, allowable.length = 1))
- stop("bad input for argument 'n'")
- if (any(sigma <= 0))
- stop("argument 'sigma' must be positive")
- rnorm(n = n, mean=mu, sd=sigma) / runif(n = n)
+ if (!is.Numeric(n, positive = TRUE, integer.valued = TRUE,
+ allowable.length = 1))
+ stop("bad input for argument 'n'")
+ if (any(sigma <= 0))
+ stop("argument 'sigma' must be positive")
+ rnorm(n = n, mean = mu, sd = sigma) / runif(n = n)
}
+
+
slash.control <- function(save.weight = TRUE, ...)
{
- list(save.weight = save.weight)
+ list(save.weight = save.weight)
}
slash = function(lmu = "identity", lsigma = "loge",
@@ -744,22 +769,31 @@ slash.control <- function(save.weight = TRUE, ...)
smallno = .Machine$double.eps*1000)
{
if (mode(lmu) != "character" && mode(lmu) != "name")
- lmu = as.character(substitute(lmu))
+ lmu = as.character(substitute(lmu))
if (mode(lsigma) != "character" && mode(lsigma) != "name")
- lsigma = as.character(substitute(lsigma))
- if (length(isigma) && !is.Numeric(isigma, positive = TRUE))
- stop("'isigma' must be > 0")
- if (length(zero) && !is.Numeric(zero, integer.valued = TRUE, positive = TRUE))
- stop("bad input for argument 'zero'")
+ lsigma = as.character(substitute(lsigma))
+ if (length(isigma) &&
+ !is.Numeric(isigma, positive = TRUE))
+ stop("'isigma' must be > 0")
+ if (length(zero) &&
+ !is.Numeric(zero, integer.valued = TRUE, positive = TRUE))
+ stop("bad input for argument 'zero'")
+
if (!is.list(emu)) emu = list()
if (!is.list(esigma)) esigma = list()
- if (!is.Numeric(nsimEIM, allowable.length = 1, integer.valued = TRUE) || nsimEIM <= 50)
- stop("'nsimEIM' should be an integer greater than 50")
- if (!is.Numeric(iprobs, positive = TRUE) || max(iprobs) >= 1 ||
- length(iprobs)!=2)
- stop("bad input for argument 'iprobs'")
- if (!is.Numeric(smallno, positive = TRUE) || smallno > 0.1)
- stop("bad input for argument 'smallno'")
+ if (!is.Numeric(nsimEIM, allowable.length = 1,
+ integer.valued = TRUE) ||
+ nsimEIM <= 50)
+ stop("'nsimEIM' should be an integer greater than 50")
+
+ if (!is.Numeric(iprobs, positive = TRUE) ||
+ max(iprobs) >= 1 ||
+ length(iprobs) != 2)
+ stop("bad input for argument 'iprobs'")
+ if (!is.Numeric(smallno, positive = TRUE) ||
+ smallno > 0.1)
+ stop("bad input for argument 'smallno'")
+
new("vglmff",
blurb = c("Slash distribution\n\n",
@@ -767,7 +801,8 @@ slash.control <- function(save.weight = TRUE, ...)
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)",
+ "1-exp(-(((y-mu)/sigma)^2)/2))/(sqrt(2*pi)*",
+ "sigma*((y-mu)/sigma)^2)",
"\ty!=mu",
"\n1/(2*sigma*sqrt(2*pi))",
"\t\t\t\t\t\t\ty=mu\n")),
@@ -799,7 +834,9 @@ slash.control <- function(save.weight = TRUE, ...)
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)
@@ -906,14 +943,19 @@ dnefghs = function(x, tau, log = FALSE) {
nefghs <- function(link = "logit", earg = list(), itau = NULL,
imethod = 1)
{
- if (length(itau) && !is.Numeric(itau, positive = TRUE) || any(itau >= 1))
- stop("argument 'itau' must be in (0,1)")
+ if (length(itau) &&
+ !is.Numeric(itau, positive = TRUE) ||
+ any(itau >= 1))
+ stop("argument 'itau' must be in (0,1)")
if (mode(link) != "character" && mode(link) != "name")
- link = as.character(substitute(link))
+ link = as.character(substitute(link))
+
if (!is.list(earg)) earg = list()
- if (!is.Numeric(imethod, allowable.length = 1, integer.valued = TRUE, positive = TRUE) ||
- imethod > 2)
- stop("argument 'imethod' must be 1 or 2")
+ if (!is.Numeric(imethod, allowable.length = 1,
+ integer.valued = TRUE, positive = TRUE) ||
+ imethod > 2)
+ stop("argument 'imethod' must be 1 or 2")
+
new("vglmff",
blurb = c("Natural exponential family generalized hyperbolic ",
@@ -992,11 +1034,13 @@ dlogF = function(x, shape1, shape2, log = FALSE) {
ishape1 = NULL, ishape2 = 1,
imethod = 1)
{
- if (length(ishape1) && !is.Numeric(ishape1, positive = TRUE))
+ if (length(ishape1) &&
+ !is.Numeric(ishape1, positive = TRUE))
stop("argument 'ishape1' must be positive")
if ( # length(ishape2) &&
- !is.Numeric(ishape2, positive = TRUE))
+ !is.Numeric(ishape2, positive = 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")
@@ -1104,9 +1148,10 @@ dlogF = function(x, shape1, shape2, log = FALSE) {
dbenf <- function(x, ndigits = 1, log = FALSE) {
- if (!is.Numeric(ndigits, allowable.length = 1, positive = TRUE, integer.valued = TRUE) ||
+ if (!is.Numeric(ndigits, allowable.length = 1,
+ positive = TRUE, integer.valued = TRUE) ||
ndigits > 2)
- stop("argument 'ndigits' must be 1 or 2")
+ stop("argument 'ndigits' must be 1 or 2")
lowerlimit <- ifelse(ndigits == 1, 1, 10)
upperlimit <- ifelse(ndigits == 1, 9, 99)
log.arg <- log; rm(log)
@@ -1123,14 +1168,16 @@ dbenf <- function(x, ndigits = 1, log = FALSE) {
rbenf <- function(n, ndigits = 1) {
- if (!is.Numeric(ndigits, allowable.length = 1, positive = TRUE, integer.valued = TRUE) ||
+ if (!is.Numeric(ndigits, allowable.length = 1,
+ positive = TRUE, integer.valued = TRUE) ||
ndigits > 2)
- stop("argument 'ndigits' must be 1 or 2")
+ stop("argument 'ndigits' must be 1 or 2")
lowerlimit <- ifelse(ndigits == 1, 1, 10)
upperlimit <- ifelse(ndigits == 1, 9, 99)
use.n <- if ((length.n <- length(n)) > 1) length.n else
- if (!is.Numeric(n, integer.valued = TRUE, allowable.length = 1, positive = TRUE))
- stop("bad input for argument 'n'") else n
+ if (!is.Numeric(n, integer.valued = TRUE,
+ allowable.length = 1, positive = TRUE))
+ stop("bad input for argument 'n'") else n
myrunif <- runif(use.n)
ans <- rep(lowerlimit, length = use.n)
@@ -1144,16 +1191,18 @@ rbenf <- function(n, ndigits = 1) {
pbenf <- function(q, ndigits = 1, log.p = FALSE) {
- if (!is.Numeric(ndigits, allowable.length = 1, positive = TRUE, integer.valued = TRUE) ||
+ if (!is.Numeric(ndigits, allowable.length = 1,
+ positive = TRUE, integer.valued = TRUE) ||
ndigits > 2)
- stop("argument 'ndigits' must be 1 or 2")
+ stop("argument 'ndigits' must be 1 or 2")
lowerlimit <- ifelse(ndigits == 1, 1, 10)
upperlimit <- ifelse(ndigits == 1, 9, 99)
ans <- q * NA
floorq <- floor(q)
indexTF <- is.finite(q) & (floorq >= lowerlimit)
- ans[indexTF] <- log10(1 + floorq[indexTF]) - ifelse(ndigits == 1, 0, 1)
+ ans[indexTF] <- log10(1 + floorq[indexTF]) -
+ ifelse(ndigits == 1, 0, 1)
ans[!is.na(q) & !is.nan(q) & (q >= upperlimit)] <- 1
ans[!is.na(q) & !is.nan(q) & (q < lowerlimit)] <- 0
if (log.p) log(ans) else ans
@@ -1163,9 +1212,10 @@ pbenf <- function(q, ndigits = 1, log.p = FALSE) {
qbenf <- function(p, ndigits = 1) {
- if (!is.Numeric(ndigits, allowable.length = 1, positive = TRUE, integer.valued = TRUE) ||
+ if (!is.Numeric(ndigits, allowable.length = 1,
+ positive = TRUE, integer.valued = TRUE) ||
ndigits > 2)
- stop("argument 'ndigits' must be 1 or 2")
+ stop("argument 'ndigits' must be 1 or 2")
lowerlimit <- ifelse(ndigits == 1, 1, 10)
upperlimit <- ifelse(ndigits == 1, 9, 99)
bad <- !is.na(p) & !is.nan(p) & ((p < 0) | (p > 1))
diff --git a/R/family.basics.R b/R/family.basics.R
index 60af74d..f288285 100644
--- a/R/family.basics.R
+++ b/R/family.basics.R
@@ -20,7 +20,7 @@ getind <- function(constraints, M, ncolx) {
}
ans <- vector("list", M+1)
- names(ans) <- c(paste("eta", 1:M, sep=""), "ncolX_vlm")
+ names(ans) <- c(paste("eta", 1:M, sep = ""), "ncolX_vlm")
temp2 <- matrix(unlist(constraints), nrow=M)
for (kk in 1:M) {
@@ -118,38 +118,38 @@ getind <- function(constraints, M, ncolx) {
cm.nointercept.vgam <- function(constraints, x, nointercept, M)
{
- asgn <- attr(x, "assign")
- nasgn <- names(asgn)
- if (is.null(constraints)) {
- constraints <- vector("list", length(nasgn)) # list()
- names(constraints) <- nasgn
- }
- if (!is.list(constraints))
- stop("'constraints' must be a list")
- for (ii in 1:length(asgn))
- constraints[[nasgn[ii]]] <- if (is.null(constraints[[nasgn[ii]]]))
- diag(M) else eval(constraints[[nasgn[ii]]])
-
- if (is.null(nointercept))
- return(constraints)
- if (!is.numeric(nointercept))
- stop("'nointercept' must be numeric")
-
- nointercept <- unique(sort(nointercept))
- if (length(nointercept) == 0 || length(nointercept) >= M)
- stop("too few or too many values")
-
- if (any(nointercept < 1 | nointercept > M))
- stop("'nointercept' out of range")
- if (nasgn[1] != "(Intercept)" || M == 1)
- stop("Need an (Intercept) constraint matrix with M>1")
- if (!all.equal(constraints[["(Intercept)"]], diag(M)))
- warning("Constraint matrix of (Intercept) not diagonal")
-
- temp <- constraints[["(Intercept)"]]
- temp <- temp[, -nointercept, drop = FALSE]
- constraints[["(Intercept)"]] <- temp
- constraints
+ asgn <- attr(x, "assign")
+ nasgn <- names(asgn)
+ if (is.null(constraints)) {
+ constraints <- vector("list", length(nasgn)) # list()
+ names(constraints) <- nasgn
+ }
+ if (!is.list(constraints))
+ stop("'constraints' must be a list")
+ for (ii in 1:length(asgn))
+ constraints[[nasgn[ii]]] <- if (is.null(constraints[[nasgn[ii]]]))
+ diag(M) else eval(constraints[[nasgn[ii]]])
+
+ if (is.null(nointercept))
+ return(constraints)
+ if (!is.numeric(nointercept))
+ stop("'nointercept' must be numeric")
+
+ nointercept <- unique(sort(nointercept))
+ if (length(nointercept) == 0 || length(nointercept) >= M)
+ stop("too few or too many values")
+
+ if (any(nointercept < 1 | nointercept > M))
+ stop("'nointercept' out of range")
+ if (nasgn[1] != "(Intercept)" || M == 1)
+ stop("Need an (Intercept) constraint matrix with M>1")
+ if (!all.equal(constraints[["(Intercept)"]], diag(M)))
+ warning("Constraint matrix of (Intercept) not diagonal")
+
+ temp <- constraints[["(Intercept)"]]
+ temp <- temp[, -nointercept, drop = FALSE]
+ constraints[["(Intercept)"]] <- temp
+ constraints
}
@@ -157,41 +157,41 @@ cm.nointercept.vgam <- function(constraints, x, nointercept, M)
cm.zero.vgam <- function(constraints, x, zero, M)
{
- asgn <- attr(x, "assign")
- nasgn <- names(asgn)
- if (is.null(constraints)) {
- constraints <- vector("list", length(nasgn)) # list()
- names(constraints) <- nasgn
- }
- if (!is.list(constraints))
- stop("'constraints' must be a list")
- for (ii in 1:length(asgn))
- constraints[[nasgn[ii]]] <- if (is.null(constraints[[nasgn[ii]]]))
- diag(M) else eval(constraints[[nasgn[ii]]])
-
- if (is.null(zero))
- return(constraints)
- if (!is.numeric(zero))
- stop("'zero' must be numeric")
- if (any(zero < 1 | zero > M))
- stop("'zero' out of range")
- if (nasgn[1] != "(Intercept)")
- stop("cannot fit an intercept to a no-intercept model")
-
- if (2 <= length(constraints))
- for (ii in 2:length(constraints)) {
- Hmatk <- constraints[[nasgn[ii]]]
- Hmatk[zero, ] <- 0
- index <- NULL
- for (kk in 1:ncol(Hmatk))
- if (all(Hmatk[,kk] == 0)) index <- c(index, kk)
- if (length(index) == ncol(Hmatk))
- stop("constraint matrix has no columns!")
- if (!is.null(index))
- Hmatk <- Hmatk[, -index, drop = FALSE]
- constraints[[nasgn[ii]]] <- Hmatk
- }
- constraints
+ asgn <- attr(x, "assign")
+ nasgn <- names(asgn)
+ if (is.null(constraints)) {
+ constraints <- vector("list", length(nasgn)) # list()
+ names(constraints) <- nasgn
+ }
+ if (!is.list(constraints))
+ stop("'constraints' must be a list")
+ for (ii in 1:length(asgn))
+ constraints[[nasgn[ii]]] <- if (is.null(constraints[[nasgn[ii]]]))
+ diag(M) else eval(constraints[[nasgn[ii]]])
+
+ if (is.null(zero))
+ return(constraints)
+ if (!is.numeric(zero))
+ stop("'zero' must be numeric")
+ if (any(zero < 1 | zero > M))
+ stop("'zero' out of range")
+ if (nasgn[1] != "(Intercept)")
+ stop("cannot fit an intercept to a no-intercept model")
+
+ if (2 <= length(constraints))
+ for (ii in 2:length(constraints)) {
+ Hmatk <- constraints[[nasgn[ii]]]
+ Hmatk[zero, ] <- 0
+ index <- NULL
+ for (kk in 1:ncol(Hmatk))
+ if (all(Hmatk[,kk] == 0)) index <- c(index, kk)
+ if (length(index) == ncol(Hmatk))
+ stop("constraint matrix has no columns!")
+ if (!is.null(index))
+ Hmatk <- Hmatk[, -index, drop = FALSE]
+ constraints[[nasgn[ii]]] <- Hmatk
+ }
+ constraints
}
@@ -205,69 +205,69 @@ process.constraints <- function(constraints, x, M,
asgn <- attr(x, "assign")
nasgn <- names(asgn)
- if (is.null(constraints)) {
- constraints <- vector("list", length(nasgn))
- for (ii in 1:length(nasgn))
- constraints[[ii]] <- diag(M)
- names(constraints) <- nasgn
- }
+ if (is.null(constraints)) {
+ constraints <- vector("list", length(nasgn))
+ for (ii in 1:length(nasgn))
+ constraints[[ii]] <- diag(M)
+ names(constraints) <- nasgn
+ }
- if (is.matrix(constraints))
- constraints <- list(constraints)
+ if (is.matrix(constraints))
+ constraints <- list(constraints)
- if (!is.list(constraints))
- stop("'constraints' must be a list")
-
- lenconstraints <- length(constraints)
- if (lenconstraints > 0)
- for (ii in 1:lenconstraints) {
- constraints[[ii]] <- eval(constraints[[ii]])
- if (!is.null (constraints[[ii]]) &&
- !is.matrix(constraints[[ii]]))
- stop("'constraints[[", ii, "]]' is not a matrix")
- }
+ if (!is.list(constraints))
+ stop("'constraints' must be a list")
- if (is.null(names(constraints)))
- names(constraints) <- rep(nasgn, length.out = lenconstraints)
+ lenconstraints <- length(constraints)
+ if (lenconstraints > 0)
+ for (ii in 1:lenconstraints) {
+ constraints[[ii]] <- eval(constraints[[ii]])
+ if (!is.null (constraints[[ii]]) &&
+ !is.matrix(constraints[[ii]]))
+ stop("'constraints[[", ii, "]]' is not a matrix")
+ }
- temp <- if (!is.R()) list() else {
- junk <- vector("list", length(nasgn))
- names(junk) <- nasgn
- junk
- }
- for (ii in 1:length(nasgn))
- temp[[nasgn[ii]]] <-
- if (is.null(constraints[[nasgn[ii]]])) diag(M) else
- eval(constraints[[nasgn[ii]]])
-
- for (ii in 1:length(asgn)) {
- if (!is.matrix(temp[[ii]])) {
- stop("not a constraint matrix")
- }
- if (ncol(temp[[ii]]) > M)
- stop("constraint matrix has too many columns")
- }
+ if (is.null(names(constraints)))
+ names(constraints) <- rep(nasgn, length.out = lenconstraints)
- if (!by.col)
- return(temp)
-
- constraints <- temp
- Blist <- vector("list", ncol(x))
- for (ii in 1:length(asgn)) {
- cols <- asgn[[ii]]
- ictr = 0
- for (jay in cols) {
- ictr = ictr + 1
- cm = if (is.list(specialCM) &&
- any(nasgn[ii] == names(specialCM))) {
- slist = specialCM[[(nasgn[ii])]]
- slist[[ictr]]
- } else constraints[[ii]]
- Blist[[jay]] <- cm
- }
- }
- names(Blist) <- dimnames(x)[[2]]
- Blist
+ temp <- if (!is.R()) list() else {
+ junk <- vector("list", length(nasgn))
+ names(junk) <- nasgn
+ junk
+ }
+ for (ii in 1:length(nasgn))
+ temp[[nasgn[ii]]] <-
+ if (is.null(constraints[[nasgn[ii]]])) diag(M) else
+ eval(constraints[[nasgn[ii]]])
+
+ for (ii in 1:length(asgn)) {
+ if (!is.matrix(temp[[ii]])) {
+ stop("not a constraint matrix")
+ }
+ if (ncol(temp[[ii]]) > M)
+ stop("constraint matrix has too many columns")
+ }
+
+ if (!by.col)
+ return(temp)
+
+ constraints <- temp
+ Blist <- vector("list", ncol(x))
+ for (ii in 1:length(asgn)) {
+ cols <- asgn[[ii]]
+ ictr = 0
+ for (jay in cols) {
+ ictr = ictr + 1
+ cm = if (is.list(specialCM) &&
+ any(nasgn[ii] == names(specialCM))) {
+ slist = specialCM[[(nasgn[ii])]]
+ slist[[ictr]]
+ } else constraints[[ii]]
+ Blist[[jay]] <- cm
+ }
+ }
+ names(Blist) <- dimnames(x)[[2]]
+ Blist
}
@@ -276,31 +276,32 @@ process.constraints <- function(constraints, x, M,
trivial.constraints <- function(Blist, target = diag(M))
{
- if (is.null(Blist))
- return(1)
-
- if (is.matrix(Blist))
- Blist <- list(Blist)
- M <- dim(Blist[[1]])[1]
-
- if (!is.matrix(target))
- stop("target is not a matrix")
- dimtar = dim(target)
-
- trivc <- rep(1, length(Blist))
- names(trivc) <- names(Blist)
- for (ii in 1:length(Blist)) {
- d <- dim(Blist[[ii]])
- if (d[1] != dimtar[1]) trivc[ii] <- 0
- if (d[2] != dimtar[2]) trivc[ii] <- 0
- if (d[1] != M) trivc[ii] <- 0
- if (length(Blist[[ii]]) != length(target)) trivc[ii] <- 0
- if (trivc[ii] == 0) next
- if (!all(c(Blist[[ii]]) == c(target)))
- trivc[ii] <- 0
- if (trivc[ii] == 0) next
- }
- trivc
+ if (is.null(Blist))
+ return(1)
+
+ if (is.matrix(Blist))
+ Blist <- list(Blist)
+ M <- dim(Blist[[1]])[1]
+
+ if (!is.matrix(target))
+ stop("target is not a matrix")
+ dimtar = dim(target)
+
+ trivc <- rep(1, length(Blist))
+ names(trivc) <- names(Blist)
+ for (ii in 1:length(Blist)) {
+ d <- dim(Blist[[ii]])
+ if (d[1] != dimtar[1]) trivc[ii] <- 0
+ if (d[2] != dimtar[2]) trivc[ii] <- 0
+ if (d[1] != M) trivc[ii] <- 0
+ if (length(Blist[[ii]]) != length(target))
+ trivc[ii] <- 0
+ if (trivc[ii] == 0) next
+ if (!all(c(Blist[[ii]]) == c(target)))
+ trivc[ii] <- 0
+ if (trivc[ii] == 0) next
+ }
+ trivc
}
@@ -308,44 +309,44 @@ add.constraints <- function(constraints, new.constraints,
overwrite = FALSE, check = FALSE)
{
- empty.list <- function(l)
- (is.null(l) || (is.list(l) && length(l) == 0))
-
- if (empty.list(constraints))
- if (is.list(new.constraints))
- return(new.constraints) else
- return(list()) # Both NULL probably
-
- constraints <- as.list(constraints)
- new.constraints <- as.list(new.constraints)
- nc <- names(constraints) # May be NULL
- nn <- names(new.constraints) # May be NULL
-
- if (is.null(nc) || is.null(nn))
- stop("lists must have names")
- if (any(nc == "") || any(nn == ""))
- stop("lists must have names")
-
- if (!empty.list(constraints) && !empty.list(new.constraints)) {
- for (ii in nn) {
- if (any(ii == nc)) {
- if (check &&
- (!(all(dim(constraints[[ii]]) == dim(new.constraints[[ii]])) &&
- all( constraints[[ii]] == new.constraints[[ii]]))))
- stop("apparent contradiction in the specification ",
- "of the constraints")
- if (overwrite)
- constraints[[ii]] <- new.constraints[[ii]]
- } else
- constraints[[ii]] <- new.constraints[[ii]]
- }
- } else {
- if (!empty.list(constraints))
- return(as.list(constraints)) else
- return(as.list(new.constraints))
+ empty.list <- function(l)
+ (is.null(l) || (is.list(l) && length(l) == 0))
+
+ if (empty.list(constraints))
+ if (is.list(new.constraints))
+ return(new.constraints) else
+ return(list()) # Both NULL probably
+
+ constraints <- as.list(constraints)
+ new.constraints <- as.list(new.constraints)
+ nc <- names(constraints) # May be NULL
+ nn <- names(new.constraints) # May be NULL
+
+ if (is.null(nc) || is.null(nn))
+ stop("lists must have names")
+ if (any(nc == "") || any(nn == ""))
+ stop("lists must have names")
+
+ if (!empty.list(constraints) && !empty.list(new.constraints)) {
+ for (ii in nn) {
+ if (any(ii == nc)) {
+ if (check &&
+ (!(all(dim(constraints[[ii]]) == dim(new.constraints[[ii]])) &&
+ all( constraints[[ii]] == new.constraints[[ii]]))))
+ stop("apparent contradiction in the specification ",
+ "of the constraints")
+ if (overwrite)
+ constraints[[ii]] <- new.constraints[[ii]]
+ } else
+ constraints[[ii]] <- new.constraints[[ii]]
}
+ } else {
+ if (!empty.list(constraints))
+ return(as.list(constraints)) else
+ return(as.list(new.constraints))
+ }
- constraints
+ constraints
}
@@ -355,51 +356,57 @@ add.constraints <- function(constraints, new.constraints,
-iam <- function(j, k, M, hbw = M, both = FALSE, diag = TRUE)
-{
- jay <- j
- kay <- k
- if (M == 1)
- if (!diag) stop("cannot handle this")
- if (M == 1)
- if (both) return(list(row.index = 1, col.index = 1)) else return(1)
- upper <- if (diag) M else M-1
- i2 <- as.list(upper:1)
- i2 <- lapply(i2, seq)
- i2 <- unlist(i2)
- i1 <- matrix(1:M, M, M)
- i1 <- if (diag) c(i1[row(i1) >= col(i1)]) else
- c(i1[row(i1) > col(i1)])
+iam <- function(j, k, M, hbw = M, both = FALSE, diag = TRUE) {
- if (both) list(row.index = i2, col.index = i1) else {
- if (jay > M || kay > M || jay < 1 || kay < 1)
- stop("range error in j or k")
- both <- (i1 == jay & i2 == kay) |
- (i1 == kay & i2 == jay)
- (1:length(i2))[both]
- }
+ jay <- j
+ kay <- k
+
+ if (M == 1)
+ if (!diag) stop("cannot handle this")
+
+ if (M == 1)
+ if (both) return(list(row.index = 1, col.index = 1)) else return(1)
+
+ upper <- if (diag) M else M - 1
+ i2 <- as.list(upper:1)
+ i2 <- lapply(i2, seq)
+ i2 <- unlist(i2)
+
+ i1 <- matrix(1:M, M, M)
+ i1 <- if (diag) c(i1[row(i1) >= col(i1)]) else
+ c(i1[row(i1) > col(i1)])
+
+ if (both) {
+ list(row.index = i2, col.index = i1)
+ } else {
+ if (jay > M || kay > M || jay < 1 || kay < 1)
+ stop("range error in j or k")
+ both <- (i1 == jay & i2 == kay) |
+ (i1 == kay & i2 == jay)
+ (1:length(i2))[both]
+ }
}
-dimm <- function(M, hbw = M)
-{
- if (!is.numeric(hbw))
- hbw <- M
+dimm <- function(M, hbw = M) {
+
+ if (!is.numeric(hbw))
+ hbw <- M
- if (hbw > M || hbw < 1)
- stop("range error in hbw")
- hbw * (2*M - hbw +1) / 2
+ if (hbw > M || hbw < 1)
+ stop("range error in argument 'hbw'")
+ hbw * (2 * M - hbw +1) / 2
}
@@ -407,103 +414,111 @@ dimm <- function(M, hbw = M)
-m2avglm <- function(object, upper = FALSE, allow.vector = FALSE) {
- m2adefault(wweights(object), M=object at misc$M,
- upper=upper, allow.vector=allow.vector)
+
+
+
+ m2avglm <- function(object, upper = FALSE, allow.vector = FALSE) {
+ m2adefault(wweights(object), M = object at misc$M,
+ upper = upper, allow.vector = allow.vector)
}
-m2adefault <- function(m, M, upper = FALSE, allow.vector = FALSE)
+ m2adefault <- function(m, M, upper = FALSE, allow.vector = FALSE)
{
- if (!is.numeric(m))
- stop("argument 'm' is not numeric")
-
- if (!is.matrix(m))
- m <- cbind(m)
- n <- nrow(m)
- dimm <- ncol(m)
- index <- iam(NA, NA, M=M, both = TRUE, diag = TRUE)
- if (dimm > length(index$row.index))
- stop("bad value for M; it is too small")
- if (dimm < M) {
- stop("bad value for M; it is too big")
- }
+ if (!is.numeric(m))
+ stop("argument 'm' is not numeric")
+
+ if (!is.matrix(m))
+ m <- cbind(m)
+ n <- nrow(m)
+ dimm <- ncol(m)
+ index <- iam(NA, NA, M = M, both = TRUE, diag = TRUE)
+ if (dimm > length(index$row.index))
+ stop("bad value for 'M'; it is too small")
+ if (dimm < M) {
+ stop("bad value for 'M'; it is too big")
+ }
- fred <- dotC(name="m2a", as.double(t(m)), ans=double(M*M*n),
- as.integer(dimm),
- as.integer(index$row-1),
- as.integer(index$col-1),
- as.integer(n), as.integer(M),
- as.integer(as.numeric(upper)), NAOK = TRUE)
- dim(fred$ans) <- c(M,M,n)
- alpn <- NULL
- dimnames(fred$ans) <- list(alpn, alpn, dimnames(m)[[1]])
- fred$a
+ fred <- dotC(name = "m2a", as.double(t(m)), ans=double(M*M*n),
+ as.integer(dimm),
+ as.integer(index$row-1),
+ as.integer(index$col-1),
+ as.integer(n), as.integer(M),
+ as.integer(as.numeric(upper)), NAOK = TRUE)
+ dim(fred$ans) <- c(M, M, n)
+ alpn <- NULL
+ dimnames(fred$ans) <- list(alpn, alpn, dimnames(m)[[1]])
+ fred$a
}
-a2m <- function(a, hbw = M)
-{
+a2m <- function(a, hbw = M) {
- if (is.matrix(a) && ncol(a) == nrow(a))
- a <- array(a, c(nrow(a), ncol(a), 1))
- if (!is.array(a))
- dim(a) <- c(1,1,length(a))
- M <- dim(a)[1]
- n <- dim(a)[3]
- dimm.value <- dimm(M, hbw)
- index <- iam(NA, NA, M, both = TRUE, diag = TRUE)
+ if (is.matrix(a) && ncol(a) == nrow(a))
+ a <- array(a, c(nrow(a), ncol(a), 1))
+ if (!is.array(a))
+ dim(a) <- c(1,1,length(a))
+ M <- dim(a)[1]
+ n <- dim(a)[3]
+ dimm.value <- dimm(M, hbw)
+ index <- iam(NA, NA, M, both = TRUE, diag = TRUE)
- fred <- dotC(name="a2m", as.double(a), m=double(dimm.value*n),
- as.integer(dimm.value),
- as.integer(index$row-1),
- as.integer(index$col-1),
- as.integer(n), as.integer(M), NAOK = TRUE)
- dim(fred$m) <- c(dimm.value,n)
- fred$m <- t(fred$m)
- if (hbw != M)
- attr(fred$m, "hbw") <- hbw
- if (length(lpn <- dimnames(a)[[1]]) != 0)
- attr(fred$m, "predictors.names") <- lpn
- fred$m
+ fred <- dotC(name = "a2m", as.double(a), m=double(dimm.value*n),
+ as.integer(dimm.value),
+ as.integer(index$row-1),
+ as.integer(index$col-1),
+ as.integer(n), as.integer(M), NAOK = TRUE)
+ dim(fred$m) <- c(dimm.value,n)
+ fred$m <- t(fred$m)
+
+ if (hbw != M)
+ attr(fred$m, "hbw") <- hbw
+ if (length(lpn <- dimnames(a)[[1]]) != 0)
+ attr(fred$m, "predictors.names") <- lpn
+ fred$m
}
+
vindex <- function(M, row.arg = FALSE, col.arg = FALSE,
- length.arg = M*(M+1)/2)
+ length.arg = M * (M + 1) / 2)
{
- if ((row.arg + col.arg) != 1)
- stop("only one of row and col must be TRUE")
- if (M == 1) {
- ans <- 1
+ if ((row.arg + col.arg) != 1)
+ stop("only one of row and col must be TRUE")
+ if (M == 1) {
+ ans <- 1
+ } else {
+ if (row.arg) {
+ i1 <- matrix(1:M, M, M)
+ ans <- c(i1[row(i1) + col(i1) <= (M + 1)])
} else {
- if (row.arg) {
- i1 <- matrix(1:M, M, M)
- ans <- c(i1[row(i1)+col(i1) <= (M+1)])
- } else {
- i1 <- matrix(1:M, M, M)
- ans <- c(i1[row(i1) >= col(i1)])
- }
+ i1 <- matrix(1:M, M, M)
+ ans <- c(i1[row(i1) >= col(i1)])
}
- if (length.arg>length(ans))
- stop("length argument too big")
- rep(ans, len=length.arg)
+ }
+ if (length.arg > length(ans))
+ stop("argument 'length.arg' too big")
+ rep(ans, length.out = length.arg)
}
-if(!exists("is.R")) is.R <- function()
- exists("version") &&
- !is.null(version$language) &&
- version$language == "R"
+if(!exists("is.R"))
+ is.R <- function()
+ exists("version") &&
+ !is.null(version$language) &&
+ version$language == "R"
+
+
+
wweights <- function(object, matrix.arg = TRUE, deriv.arg = FALSE,
@@ -544,7 +559,7 @@ wweights <- function(object, matrix.arg = TRUE, deriv.arg = FALSE,
x <- object at x
if (!length(x))
- x <- model.matrixvlm(object, type="lm")
+ x <- model.matrixvlm(object, type = "lm")
y <- object at y
if (any(slotNames(object) == "control"))
@@ -574,19 +589,24 @@ wweights <- function(object, matrix.arg = TRUE, deriv.arg = FALSE,
}
+
+
pweights <- function(object, ...) {
- ans = object at prior.weights
- if (length(ans)) {
- ans
- } else {
- temp = object at y
- ans = rep(1, nrow(temp)) # Assumed all equal and unity.
- names(ans) = dimnames(temp)[[1]]
- ans
- }
+ ans = object at prior.weights
+ if (length(ans)) {
+ ans
+ } else {
+ temp = object at y
+ ans = rep(1, nrow(temp)) # Assumed all equal and unity.
+ names(ans) = dimnames(temp)[[1]]
+ ans
+ }
}
+
+
+
procVec <- function(vec, yn, Default) {
@@ -611,10 +631,11 @@ procVec <- function(vec, yn, Default) {
if (length(nvec2)) {
if (any(!is.element(nvec2, yn)))
stop("some names given which are superfluous")
- answer = rep(as.numeric(NA), len=length(yn))
+ answer = rep(as.numeric(NA), length.out = length(yn))
names(answer) = yn
answer[nvec2] = vec[nvec2]
- answer[is.na(answer)] = rep(default, len=sum(is.na(answer)))
+ answer[is.na(answer)] =
+ rep(default, length.out = sum(is.na(answer)))
}
}
@@ -624,21 +645,25 @@ procVec <- function(vec, yn, Default) {
if (FALSE) {
+
+
if (!isGeneric("m2a"))
setGeneric("m2a", function(object, ...) standardGeneric("m2a"))
+
setMethod("m2a", "vglm",
function(object, ...)
m2avglm(object, ...))
}
+
weightsvglm <- function(object, type = c("prior", "working"),
matrix.arg = TRUE, ignore.slot = FALSE,
deriv.arg = FALSE, ...) {
- weightsvlm(object, type = type, matrix.arg=matrix.arg,
- ignore.slot=ignore.slot,
- deriv.arg=deriv.arg, ...)
+ weightsvlm(object, type = type, matrix.arg = matrix.arg,
+ ignore.slot = ignore.slot,
+ deriv.arg = deriv.arg, ...)
}
@@ -646,26 +671,32 @@ weightsvglm <- function(object, type = c("prior", "working"),
weightsvlm <- function(object, type = c("prior", "working"),
matrix.arg = TRUE, ignore.slot = FALSE,
deriv.arg = FALSE, ...) {
- if (mode(type) != "character" && mode(type) != "name")
- type = as.character(substitute(type))
- type = match.arg(type, c("prior", "working"))[1]
-
- if (type == "working") {
- wweights(object=object,
- matrix.arg=matrix.arg, deriv.arg=deriv.arg,
- ignore.slot=ignore.slot, ...)
- } else {
- if (deriv.arg)
- stop("cannot set 'deriv = TRUE' when 'type=\"prior\"'")
- ans = pweights(object)
- if (matrix.arg) as.matrix(ans) else c(ans)
- }
+ if (mode(type) != "character" && mode(type) != "name")
+ type = as.character(substitute(type))
+ type = match.arg(type, c("prior", "working"))[1]
+
+ if (type == "working") {
+ wweights(object = object,
+ matrix.arg = matrix.arg, deriv.arg = deriv.arg,
+ ignore.slot = ignore.slot, ...)
+ } else {
+ if (deriv.arg)
+ stop("cannot set 'deriv = TRUE' when 'type=\"prior\"'")
+ ans = pweights(object)
+ if (matrix.arg) as.matrix(ans) else c(ans)
+ }
}
+
+if (!isGeneric("weights"))
+ setGeneric("weights", function(object, ...) standardGeneric("weights"))
+
+
setMethod("weights", "vlm",
function(object, ...)
weightsvlm(object, ...))
+
setMethod("weights", "vglm",
function(object, ...)
weightsvglm(object, ...))
@@ -675,6 +706,7 @@ setMethod("weights", "vglm",
+
dotFortran <- function(name, ..., NAOK = FALSE, DUP = TRUE,
PACKAGE = "VGAM") {
if (is.R()) {
@@ -684,45 +716,47 @@ dotFortran <- function(name, ..., NAOK = FALSE, DUP = TRUE,
}
}
-dotC <- function(name, ..., NAOK = FALSE, DUP = TRUE, PACKAGE="VGAM") {
+
+dotC <- function(name, ..., NAOK = FALSE, DUP = TRUE, PACKAGE = "VGAM") {
.C(name=name, ..., NAOK = NAOK, DUP = DUP, PACKAGE = PACKAGE)
}
+
qnupdate <- function(w, wzold, dderiv, deta, M, keeppd = TRUE,
trace = FALSE, reset = FALSE,
effpos=.Machine$double.eps^0.75) {
- if (M == 1) {
- dderiv = cbind(dderiv)
- deta = cbind(deta)
- }
- Bs = mux22(t(wzold), deta, M=M, upper = FALSE, as.matrix = TRUE) # n x M
- sBs = c( (deta * Bs) %*% rep(1, M) ) # should have positive values
- sy = c( (dderiv * deta) %*% rep(1, M) )
- wznew = wzold
- index = iam(NA, NA, M=M, both = TRUE)
- index$row.index = rep(index$row.index, len=ncol(wzold))
- 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] *
- Bs[updateThese,index$col] / sBs[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")
- } else {
- warning("no BFGS quasi-Newton update made at all")
- cat("no BFGS quasi-Newton update made at all\n")
- flush.console()
- }
- wznew
+ if (M == 1) {
+ dderiv = cbind(dderiv)
+ deta = cbind(deta)
+ }
+ Bs = mux22(t(wzold), deta, M = M, upper = FALSE, as.matrix = TRUE) # n x M
+ sBs = c( (deta * Bs) %*% rep(1, M) ) # should have positive values
+ sy = c( (dderiv * deta) %*% rep(1, M) )
+ wznew = wzold
+ index = iam(NA, NA, M = M, both = TRUE)
+ index$row.index = rep(index$row.index, len=ncol(wzold))
+ 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] *
+ Bs[updateThese,index$col] / sBs[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")
+ } else {
+ warning("no BFGS quasi-Newton update made at all")
+ cat("no BFGS quasi-Newton update made at all\n")
+ flush.console()
+ }
+ wznew
}
@@ -731,7 +765,8 @@ qnupdate <- function(w, wzold, dderiv, deta, M, keeppd = TRUE,
mbesselI0 <- function(x, deriv.arg = 0) {
- if (!is.Numeric(deriv.arg, allowable.length = 1, integer.valued = TRUE, positive = TRUE) &&
+ if (!is.Numeric(deriv.arg, allowable.length = 1,
+ integer.valued = TRUE, positive = 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))
@@ -753,18 +788,21 @@ mbesselI0 <- function(x, deriv.arg = 0) {
-VGAM.matrix.norm <- function(A, power=2, suppressWarning = FALSE) {
- if ((nrow(A) != ncol(A)) && !suppressWarning)
- warning("norms should be calculated for square matrices; A is not square")
- if (power == "F") {
- sqrt(sum(A^2))
- } else if (power == 1) {
- max(colSums(abs(A)))
- } else if (power == 2) {
- sqrt(max(eigen(t(A) %*% A)$value))
- } else if (!is.finite(power)) {
- max(colSums(abs(A)))
- } else stop("argument 'power' not recognised")
+VGAM.matrix.norm <- function(A, power = 2, suppressWarning = FALSE) {
+ if ((nrow(A) != ncol(A)) && !suppressWarning)
+ warning("norms should be calculated for square matrices; ",
+ "'A' is not square")
+ if (power == "F") {
+ sqrt(sum(A^2))
+ } else if (power == 1) {
+ max(colSums(abs(A)))
+ } else if (power == 2) {
+ sqrt(max(eigen(t(A) %*% A)$value))
+ } else if (!is.finite(power)) {
+ max(colSums(abs(A)))
+ } else {
+ stop("argument 'power' not recognized")
+ }
}
@@ -773,73 +811,79 @@ VGAM.matrix.norm <- function(A, power=2, suppressWarning = FALSE) {
rmfromVGAMenv <- function(varnames, prefix = "") {
- evarnames = paste(prefix, varnames, sep = "")
- if (is.R()) {
- for (ii in evarnames) {
- mytext1 = "exists(x = ii, envir = VGAM:::VGAMenv)"
- myexp1 = parse(text = mytext1)
- is.there = eval(myexp1)
- if (is.there) {
- rm(list = ii, envir = VGAM:::VGAMenv)
- }
- }
- } else {
- warning("this code needs checking 9")
- for (ii in evarnames)
- while(exists(ii, inherits = TRUE))
- rm(ii, inherits = TRUE)
-
+ evarnames = paste(prefix, varnames, sep = "")
+ if (is.R()) {
+ for (ii in evarnames) {
+ mytext1 = "exists(x = ii, envir = VGAM:::VGAMenv)"
+ myexp1 = parse(text = mytext1)
+ is.there = eval(myexp1)
+ if (is.there) {
+ rm(list = ii, envir = VGAM:::VGAMenv)
+ }
}
+ } else {
+ warning("this code needs checking 9")
+ for (ii in evarnames)
+ while(exists(ii, inherits = TRUE))
+ rm(ii, inherits = TRUE)
+
+ }
}
-existsinVGAMenv <- function(varnames, prefix="") {
- evarnames = paste(prefix, varnames, sep="")
- ans = NULL
- if (is.R()) {
- for (ii in evarnames) {
- mytext1 = "exists(x = ii, envir = VGAM:::VGAMenv)"
- myexp1 = parse(text = mytext1)
- is.there = eval(myexp1)
- ans = c(ans, is.there)
- }
- } else {
+
+
+
+existsinVGAMenv <- function(varnames, prefix = "") {
+ evarnames = paste(prefix, varnames, sep = "")
+ ans = NULL
+ if (is.R()) {
+ for (ii in evarnames) {
+ mytext1 = "exists(x = ii, envir = VGAM:::VGAMenv)"
+ myexp1 = parse(text = mytext1)
+ is.there = eval(myexp1)
+ ans = c(ans, is.there)
+ }
+ } else {
warning("this code needs checking 8")
- for (ii in evarnames) {
- is.there = exists(ii, inherits = TRUE)
- ans = c(ans, is.there)
- }
+ for (ii in evarnames) {
+ is.there = exists(ii, inherits = TRUE)
+ ans = c(ans, is.there)
}
- ans
+ }
+ ans
}
-assign2VGAMenv <- function(varnames, mylist, prefix="") {
- evarnames = paste(prefix, varnames, sep="")
- if (is.R()) {
- for (ii in 1:length(varnames)) {
- assign(evarnames[ii], mylist[[(varnames[ii])]],
- envir = VGAM:::VGAMenv)
- }
- } else {
- stop("uncomment the lines below")
+
+assign2VGAMenv <- function(varnames, mylist, prefix = "") {
+ evarnames = paste(prefix, varnames, sep = "")
+ if (is.R()) {
+ for (ii in 1:length(varnames)) {
+ assign(evarnames[ii], mylist[[(varnames[ii])]],
+ envir = VGAM:::VGAMenv)
}
+ } else {
+ stop("uncomment the lines below")
+ }
}
-getfromVGAMenv <- function(varname, prefix="") {
- varname = paste(prefix, varname, sep="")
+
+getfromVGAMenv <- function(varname, prefix = "") {
+ varname = paste(prefix, varname, sep = "")
if (length(varname) > 1) stop("'varname' must be of length 1")
get(varname, envir = VGAM:::VGAMenv)
}
+
lerch <- function(x, s, v, tolerance = 1.0e-10, iter = 100) {
if (!is.Numeric(x) || !is.Numeric(s) || !is.Numeric(v))
- stop("bad input in x, s, and/or v")
+ stop("bad input in 'x', 's', and/or 'v'")
if (is.complex(c(x,s,v)))
- stop("complex arguments not allowed in x, s and v")
+ stop("complex arguments not allowed in 'x', 's' and 'v'")
if (!is.Numeric(tolerance, allowable.length = 1, positive = TRUE) ||
tolerance > 0.01)
stop("bad input for argument 'tolerance'")
@@ -853,10 +897,12 @@ lerch <- function(x, s, v, tolerance = 1.0e-10, iter = 100) {
v = rep(v, length.out = L);
xok = abs(x) < 1 & !(v <= 0 & v == round(v))
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))
+
ifelse(ans$err == 0 & xok , ans$result, NA)
}
@@ -877,7 +923,8 @@ negzero.expression <- expression({
bigUniqInt <- 1080
zneg_index <- if (length(negdotzero)) {
- if (!is.Numeric(-negdotzero, positive = TRUE, integer.valued = TRUE) ||
+ if (!is.Numeric(-negdotzero, positive = TRUE,
+ integer.valued = TRUE) ||
max(-negdotzero) > Musual)
stop("bad input for argument 'zero'")
@@ -900,10 +947,10 @@ negzero.expression <- expression({
- is.empty.list = function(mylist) {
- is.list(mylist) &&
- length(unlist(mylist)) == 0
- }
+is.empty.list = function(mylist) {
+ is.list(mylist) &&
+ length(unlist(mylist)) == 0
+}
diff --git a/R/family.binomial.R b/R/family.binomial.R
index 2ba8ca1..f6d9b21 100644
--- a/R/family.binomial.R
+++ b/R/family.binomial.R
@@ -166,10 +166,12 @@ betabinomial.control <- function(save.weight = TRUE, ...)
nvec = if (is.numeric(extra$orig.w))
round(w / extra$orig.w) else round(w),
mustart = mustart.use))
- init.rho <- if (is.Numeric( .irho )) rep( .irho , length = n) else
- rep(try.this, length = n)
- etastart <- cbind(theta2eta(mustart.use, .lmu , earg = .emu),
- theta2eta(init.rho, .lrho , earg = .erho))
+ init.rho <- if (is.Numeric( .irho ))
+ rep( .irho , length = n) else
+ rep(try.this, length = n)
+ etastart <-
+ cbind(theta2eta(mustart.use, .lmu , earg = .emu),
+ theta2eta(init.rho, .lrho , earg = .erho))
mustart <- NULL # Since etastart has been computed.
}
}), list( .lmu = lmu, .lrho = lrho,
@@ -345,13 +347,15 @@ dbinom2.or = function(mu1,
n = max(length(mu1), length(mu2), length(oratio))
oratio = rep(oratio, len = n)
- mu1 = rep(mu1, len = n)
- mu2 = rep(mu2, 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)))
+ 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
@@ -362,13 +366,14 @@ dbinom2.or = function(mu1,
rbinom2.or = function(n, mu1,
- mu2 = if (exchangeable) mu1 else
- stop("'mu2' not specified"),
+ mu2 = if (exchangeable) mu1 else
+ stop("argument 'mu2' not specified"),
oratio = 1,
exchangeable = FALSE,
tol = 0.001,
twoCols = TRUE,
- colnames = if (twoCols) c("y1","y2") else c("00", "01", "10", "11"),
+ colnames = if (twoCols) c("y1","y2") else
+ c("00", "01", "10", "11"),
ErrorCheck = TRUE)
{
if (ErrorCheck) {
@@ -385,7 +390,7 @@ rbinom2.or = function(n, mu1,
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")
+ stop("argument 'exchangeable' is TRUE but 'mu1' and 'mu2' differ")
}
dmat = dbinom2.or(mu1 = mu1, mu2 = mu2, oratio = oratio,
@@ -421,24 +426,26 @@ rbinom2.or = function(n, mu1,
zero = 3, exchangeable = FALSE, tol = 0.001,
morerobust = FALSE)
{
- if (mode(lmu) != "character" && mode(lmu) != "name")
- lmu = as.character(substitute(lmu))
- if (mode(lmu1) != "character" && mode(lmu1) != "name")
- lmu1 = as.character(substitute(lmu1))
- if (mode(lmu2) != "character" && mode(lmu2) != "name")
- lmu2 = as.character(substitute(lmu2))
- if (mode(loratio) != "character" && mode(loratio) != "name")
- loratio = as.character(substitute(loratio))
-
- 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, allowable.length = 1) || tol > 0.1)
- stop("bad input for argument 'tol'")
-
- if (!is.list(emu1)) emu1 = list()
- if (!is.list(emu2)) emu2 = list()
- if (!is.list(eoratio)) eoratio = list()
+ if (mode(lmu) != "character" && mode(lmu) != "name")
+ lmu = as.character(substitute(lmu))
+ if (mode(lmu1) != "character" && mode(lmu1) != "name")
+ lmu1 = as.character(substitute(lmu1))
+ if (mode(lmu2) != "character" && mode(lmu2) != "name")
+ lmu2 = as.character(substitute(lmu2))
+ if (mode(loratio) != "character" && mode(loratio) != "name")
+ loratio = as.character(substitute(loratio))
+
+ 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, allowable.length = 1) ||
+ tol > 0.1)
+ stop("bad input for argument 'tol'")
+
+ if (!is.list(emu1)) emu1 = list()
+ if (!is.list(emu2)) emu2 = list()
+ if (!is.list(eoratio)) eoratio = list()
+
new("vglmff",
blurb = c("Bivariate binomial regression with an odds ratio\n",
@@ -452,34 +459,34 @@ rbinom2.or = function(n, mu1,
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
+ 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
- predictors.names =
- c(namesof("mu1", .lmu1, earg = .emu1, short = TRUE),
- namesof("mu2", .lmu2, earg = .emu2, short = TRUE),
- namesof("oratio", .loratio, earg = .eoratio, short = TRUE))
+ predictors.names =
+ c(namesof("mu1", .lmu1, earg = .emu1, short = TRUE),
+ namesof("mu2", .lmu2, earg = .emu2, short = TRUE),
+ namesof("oratio", .loratio, earg = .eoratio, short = TRUE))
- if (!length(etastart)) {
- pmargin = cbind(mustart[, 3] + mustart[, 4],
- mustart[, 2] + mustart[, 4])
- ioratio = if (length( .ioratio)) rep( .ioratio, len = n) else
- mustart[, 4] * mustart[, 1] / (mustart[, 2] *
- mustart[, 3])
- if (length( .imu1 )) pmargin[, 1] = .imu1
- if (length( .imu2 )) pmargin[, 2] = .imu2
- etastart = cbind(theta2eta(pmargin[,1], .lmu1, earg = .emu1),
- theta2eta(pmargin[,2], .lmu2, earg = .emu2),
- theta2eta(ioratio, .loratio, earg = .eoratio))
- }
- }), list( .lmu1 = lmu1, .lmu2 = lmu2, .loratio = loratio,
- .emu1 = emu1, .emu2 = emu2, .eoratio = eoratio,
- .imu1 = imu1, .imu2 = imu2, .ioratio = ioratio ))),
- linkinv = eval(substitute(function(eta, extra = NULL) {
+ if (!length(etastart)) {
+ pmargin = cbind(mustart[, 3] + mustart[, 4],
+ mustart[, 2] + mustart[, 4])
+ ioratio = if (length( .ioratio)) rep( .ioratio , len = n) else
+ mustart[, 4] * mustart[, 1] / (mustart[, 2] *
+ mustart[, 3])
+ if (length( .imu1 )) pmargin[, 1] = .imu1
+ if (length( .imu2 )) pmargin[, 2] = .imu2
+ etastart = cbind(theta2eta(pmargin[,1], .lmu1, earg = .emu1),
+ theta2eta(pmargin[,2], .lmu2, earg = .emu2),
+ theta2eta(ioratio, .loratio, earg = .eoratio))
+ }
+ }), list( .lmu1 = lmu1, .lmu2 = lmu2, .loratio = loratio,
+ .emu1 = emu1, .emu2 = emu2, .eoratio = eoratio,
+ .imu1 = imu1, .imu2 = imu2, .ioratio = ioratio ))),
+ 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)
@@ -606,73 +613,78 @@ dbinom2.rho = function(mu1,
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(rho) || min(rho) <= -1 || max(rho) >= 1)
- stop("bad input for argument 'rho'")
- if (exchangeable && max(abs(mu1 - mu2)) > 0.00001)
- stop("argument 'exchangeable' is TRUE but 'mu1' and 'mu2' differ")
- }
+ 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(rho) || min(rho) <= -1 || max(rho) >= 1)
+ stop("bad input for argument 'rho'")
+ if (exchangeable && max(abs(mu1 - mu2)) > 0.00001)
+ stop("argument 'exchangeable' is TRUE but 'mu1' and 'mu2' differ")
+ }
- nn = max(length(mu1), length(mu2), length(rho))
- rho = rep(rho, len = nn)
- mu1 = rep(mu1, len = nn)
- mu2 = rep(mu2, len = nn)
- eta1 = qnorm(mu1)
- eta2 = qnorm(mu2)
- p11 = pnorm2(eta1, eta2, rho)
- p01 = mu2 - p11
- p10 = mu1 - p11
- p00 = 1.0 - p01 - p10 - p11
- matrix(c(p00, p01, p10, p11), nn, 4, dimnames = list(NULL, colnames))
+ nn = max(length(mu1), length(mu2), length(rho))
+ rho = rep(rho, len = nn)
+ mu1 = rep(mu1, len = nn)
+ mu2 = rep(mu2, len = nn)
+ eta1 = qnorm(mu1)
+ eta2 = qnorm(mu2)
+ p11 = pnorm2(eta1, eta2, rho)
+ p01 = mu2 - p11
+ p10 = mu1 - p11
+ p00 = 1.0 - p01 - p10 - p11
+ matrix(c(p00, p01, p10, p11), nn, 4,
+ dimnames = list(NULL, colnames))
}
rbinom2.rho = function(n, mu1,
- mu2 = if (exchangeable) mu1 else stop("'mu2' not specified"),
+ mu2 = if (exchangeable) mu1 else
+ stop("'mu2' not specified"),
rho=0,
exchangeable = FALSE,
twoCols = TRUE,
- colnames = if (twoCols) c("y1","y2") else c("00", "01", "10", "11"),
+ colnames = if (twoCols) c("y1","y2") else
+ c("00", "01", "10", "11"),
ErrorCheck = TRUE)
{
- if (ErrorCheck) {
- if (!is.Numeric(n, integer.valued = TRUE, positive = TRUE, allowable.length = 1))
- stop("bad input for argument 'n'")
- 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(rho) || min(rho) <= -1 || max(rho) >= 1)
- stop("bad input for argument 'rho'")
- if (exchangeable && max(abs(mu1 - mu2)) > 0.00001)
- stop("argument 'exchangeable' is TRUE but 'mu1' and 'mu2' differ")
- }
+ if (ErrorCheck) {
+ if (!is.Numeric(n, integer.valued = TRUE,
+ positive = TRUE, allowable.length = 1))
+ stop("bad input for argument 'n'")
+ 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(rho) || min(rho) <= -1 || max(rho) >= 1)
+ stop("bad input for argument 'rho'")
+ if (exchangeable && max(abs(mu1 - mu2)) > 0.00001)
+ stop("argument 'exchangeable' is TRUE but 'mu1' and 'mu2' differ")
+ }
- dmat = dbinom2.rho(mu1 = mu1, mu2 = mu2, rho = rho,
- exchangeable = exchangeable,
- ErrorCheck = ErrorCheck)
-
- answer = matrix(0, n, 2,
- dimnames = list(NULL, if (twoCols) colnames else NULL))
- yy = runif(n)
- cs1 = dmat[,"00"] + dmat[,"01"]
- cs2 = cs1 + dmat[,"10"]
- index = (dmat[,"00"] < yy) & (yy <= cs1)
- answer[index,2] = 1
- index = (cs1 < yy) & (yy <= cs2)
- answer[index,1] = 1
- index = (yy > cs2)
- answer[index,] = 1
- if (twoCols) answer else {
- answer4 = matrix(0, n, 4, dimnames = list(NULL, colnames))
- answer4[cbind(1:n, 1 + 2*answer[,1] + answer[,2])] = 1
- answer4
- }
+ dmat = dbinom2.rho(mu1 = mu1, mu2 = mu2, rho = rho,
+ exchangeable = exchangeable,
+ ErrorCheck = ErrorCheck)
+
+ answer = matrix(0, n, 2,
+ dimnames = list(NULL,
+ if (twoCols) colnames else NULL))
+ yy = runif(n)
+ cs1 = dmat[,"00"] + dmat[,"01"]
+ cs2 = cs1 + dmat[,"10"]
+ index = (dmat[,"00"] < yy) & (yy <= cs1)
+ answer[index,2] = 1
+ index = (cs1 < yy) & (yy <= cs2)
+ answer[index,1] = 1
+ index = (yy > cs2)
+ answer[index,] = 1
+ if (twoCols) answer else {
+ answer4 = matrix(0, n, 4, dimnames = list(NULL, colnames))
+ answer4[cbind(1:n, 1 + 2*answer[,1] + answer[,2])] = 1
+ answer4
+ }
}
@@ -701,7 +713,8 @@ binom2.rho.control <- function(save.weight = TRUE, ...)
emu12 = list()
if (is.Numeric(nsimEIM)) {
- if (!is.Numeric(nsimEIM, allowable.length = 1, integer.valued = TRUE))
+ if (!is.Numeric(nsimEIM, allowable.length = 1,
+ integer.valued = TRUE))
stop("bad input for argument 'nsimEIM'")
if (nsimEIM <= 100)
warning("'nsimEIM' should be an integer greater than 100")
@@ -765,10 +778,10 @@ binom2.rho.control <- function(save.weight = TRUE, ...)
mu2.init = fitted(glm2.fit)
} else if ( .imethod == 2) {
mu1.init = if (is.Numeric( .imu1 ))
- rep( .imu1, length = n) else
+ rep( .imu1 , length = n) else
mu[,3] + mu[,4]
mu2.init = if (is.Numeric( .imu2 ))
- rep( .imu2, length = n) else
+ rep( .imu2 , length = n) else
mu[,2] + mu[,4]
} else {
stop("bad value for argument 'imethod'")
@@ -807,7 +820,7 @@ binom2.rho.control <- function(save.weight = TRUE, ...)
rho.init = if (is.Numeric( .irho ))
- rep( .irho, len = n) else {
+ rep( .irho , len = n) else {
try.this
}
@@ -1010,10 +1023,10 @@ my.dbinom <- function(x,
" Var(size) is intractable"),
initialize = eval(substitute(expression({
predictors.names <- "size"
- extra$temp2 <- rep( .prob , length=n)
+ extra$temp2 <- rep( .prob , length = n)
if (is.null(etastart)) {
nvec <- (y+0.1)/extra$temp2
- etastart <- theta2eta(nvec, .link)
+ etastart <- theta2eta(nvec, .link )
}
}), list( .prob = prob, .link = link ))),
linkinv = eval(substitute(function(eta, extra = NULL) {
@@ -1107,7 +1120,7 @@ my.dbinom <- function(x,
log = log.arg)
if (sum.okay3 <- sum(okay3)) {
if (length(.dontuse.prob) != LLL)
- .dontuse.prob = rep(.dontuse.prob, len = LLL)
+ .dontuse.prob = rep( .dontuse.prob , len = LLL)
ans[okay3] = dbinom(x = x[okay3], size = size[okay3],
prob = .dontuse.prob[okay3],
log = log.arg)
@@ -1135,7 +1148,7 @@ my.dbinom <- function(x,
if (length(q) != LLL) q = rep(q, len = LLL)
if (length(shape1) != LLL) shape1 = rep(shape1, len = LLL)
- if (length(shape1) != LLL) shape2 = rep(shape2, len = LLL)
+ if (length(shape2) != LLL) shape2 = rep(shape2, len = LLL)
if (length(size) != LLL) size = rep(size, len = LLL);
ans = q * 0 # Retains names(q)
@@ -1169,7 +1182,8 @@ my.dbinom <- function(x,
- rbetabinom.ab = function(n, size, shape1, shape2, .dontuse.prob = NULL) {
+ rbetabinom.ab = function(n, size, shape1, shape2,
+ .dontuse.prob = NULL) {
if (!is.Numeric(size, integer.valued = TRUE))
stop("bad input for argument 'size'")
@@ -1302,6 +1316,7 @@ betabinomial.ab.control <- function(save.weight = TRUE, ...) {
warning("'nsimEIM' should be an integer greater than 10, say")
}
+
new("vglmff",
blurb = c("Beta-binomial model\n",
"Links: ",
@@ -1334,9 +1349,9 @@ betabinomial.ab.control <- function(save.weight = TRUE, ...) {
mustart.use = if (length(mustart.orig)) mustart.orig else
mustart
- shape1 = rep( .i1, len = n)
+ shape1 = rep( .i1 , len = n)
shape2 = if (length( .i2 )) {
- rep( .i2, len = n)
+ rep( .i2 , len = n)
} else if (length(mustart.orig)) {
shape1 * (1 / mustart.use - 1)
} else if ( .imethod == 1) {
@@ -1469,30 +1484,32 @@ betabinomial.ab.control <- function(save.weight = TRUE, ...) {
betageometric = function(lprob = "logit", lshape = "loge",
eprob = list(), eshape = list(),
iprob = NULL, ishape = 0.1,
- moreSummation = c(2, 100), tolerance = 1.0e-10,
+ moreSummation = c(2, 100),
+ tolerance = 1.0e-10,
zero = NULL)
{
- if (mode(lprob) != "character" && mode(lprob) != "name")
- lprob = as.character(substitute(lprob))
- if (mode(lshape) != "character" && mode(lshape) != "name")
- lshape = as.character(substitute(lshape))
-
- if (!is.Numeric(ishape, positive = TRUE))
- stop("bad input for argument 'ishape'")
- if (!is.Numeric(moreSummation, positive = TRUE,
- allowable.length = 2, integer.valued = TRUE))
- stop("bad input for argument 'moreSummation'")
- if (!is.Numeric(tolerance, positive = TRUE, allowable.length = 1) ||
- 1.0-tolerance >= 1.0)
- stop("bad input for argument 'tolerance'")
-
- if (!is.list(eprob)) eprob = list()
- if (!is.list(eshape)) eshape = list()
+ if (mode(lprob) != "character" && mode(lprob) != "name")
+ lprob = as.character(substitute(lprob))
+ if (mode(lshape) != "character" && mode(lshape) != "name")
+ lshape = as.character(substitute(lshape))
+
+ if (!is.Numeric(ishape, positive = TRUE))
+ stop("bad input for argument 'ishape'")
+ if (!is.Numeric(moreSummation, positive = TRUE,
+ allowable.length = 2, integer.valued = TRUE))
+ stop("bad input for argument 'moreSummation'")
+ if (!is.Numeric(tolerance, positive = TRUE, allowable.length = 1) ||
+ 1.0 - tolerance >= 1.0)
+ stop("bad input for argument 'tolerance'")
+
+ if (!is.list(eprob)) eprob = list()
+ if (!is.list(eshape)) eshape = list()
new("vglmff",
blurb = c("Beta-geometric distribution\n",
- "Links: ", namesof("prob", lprob, earg = eprob), ", ",
- namesof("shape", lshape, earg = eshape)),
+ "Links: ",
+ namesof("prob", lprob, earg = eprob), ", ",
+ namesof("shape", lshape, earg = eshape)),
constraints = eval(substitute(expression({
constraints <- cm.zero.vgam(constraints, x, .zero, M)
}), list( .zero = zero ))),
@@ -1502,9 +1519,9 @@ betabinomial.ab.control <- function(save.weight = TRUE, ...) {
c(namesof("prob", .lprob, earg = .eprob, tag = FALSE),
namesof("shape", .lshape, earg = .eshape, short = FALSE))
if (length( .iprob))
- prob.init = rep( .iprob, len = n)
+ prob.init = rep( .iprob , len = n)
if (!length(etastart) || ncol(cbind(etastart)) != 2) {
- shape.init = rep( .ishape, len = n)
+ shape.init = rep( .ishape , len = n)
etastart = cbind(theta2eta(prob.init, .lprob, earg = .eprob),
theta2eta(shape.init, .lshape, earg = .eshape))
}
@@ -1616,147 +1633,164 @@ seq2binomial = function(lprob1 = "logit", lprob2 = "logit",
iprob1 = NULL, iprob2 = NULL,
zero = NULL)
{
- if (mode(lprob1) != "character" && mode(lprob1) != "name")
- lprob1 = as.character(substitute(lprob1))
- if (mode(lprob2) != "character" && mode(lprob2) != "name")
- lprob2 = as.character(substitute(lprob2))
+ if (mode(lprob1) != "character" && mode(lprob1) != "name")
+ lprob1 = as.character(substitute(lprob1))
+ if (mode(lprob2) != "character" && mode(lprob2) != "name")
+ lprob2 = as.character(substitute(lprob2))
- if (length(iprob1) &&
- (!is.Numeric(iprob1, positive = TRUE) || max(iprob1) >= 1))
- stop("bad input for argument 'iprob1'")
- if (length(iprob2) &&
- (!is.Numeric(iprob2, positive = TRUE) || max(iprob2) >= 1))
- stop("bad input for argument 'iprob2'")
+ if (length(iprob1) &&
+ (!is.Numeric(iprob1, positive = TRUE) ||
+ max(iprob1) >= 1))
+ stop("bad input for argument 'iprob1'")
+ if (length(iprob2) &&
+ (!is.Numeric(iprob2, positive = TRUE) ||
+ max(iprob2) >= 1))
+ stop("bad input for argument 'iprob2'")
- if (!is.list(eprob1)) eprob1 = list()
- if (!is.list(eprob2)) eprob2 = list()
+ if (!is.list(eprob1)) eprob1 = list()
+ if (!is.list(eprob2)) eprob2 = list()
- new("vglmff",
- blurb = c("Sequential binomial distribution ",
- "(Crowder and Sweeting, 1989)\n",
- "Links: ", namesof("prob1", lprob1, earg = eprob1), ", ",
- namesof("prob2", lprob2, earg = eprob2)),
- constraints = eval(substitute(expression({
- constraints <- cm.zero.vgam(constraints, x, .zero, M)
- }), list( .zero = zero ))),
- initialize = eval(substitute(expression({
- if (!is.vector(w))
- stop("the 'weights' argument must be a vector")
- if (any(abs(w - round(w)) > 0.000001))
- stop("the 'weights' argument does not seem to be integer-valued")
- if (ncol(y <- cbind(y)) != 2)
- stop("the response must be a 2-column matrix")
- if (any(y < 0 | y > 1))
- stop("the response must have values between 0 and 1")
-
- w = round(w)
- rvector = w * y[,1]
- if (any(abs(rvector - round(rvector)) > 1.0e-8))
- warning("number of successes in column one should be integer-valued")
- svector = rvector * y[,2]
- if (any(abs(svector - round(svector)) > 1.0e-8))
- warning("number of successes in column two should be integer-valued")
- predictors.names =
- c(namesof("prob1", .lprob1,earg= .eprob1, tag = FALSE),
- namesof("prob2", .lprob2,earg= .eprob2, tag = FALSE))
- prob1.init = if (is.Numeric( .iprob1)) rep( .iprob1, len = n) else
- rep(weighted.mean(y[,1], w = w), len = n)
- prob2.init = if (is.Numeric( .iprob2)) rep( .iprob2, length = n) else
- rep(weighted.mean(y[,2], w = w*y[,1]), length = n)
- if (!length(etastart)) {
- etastart = cbind(theta2eta(prob1.init, .lprob1, earg = .eprob1),
- theta2eta(prob2.init, .lprob2, earg = .eprob2))
- }
- }), list( .iprob1 = iprob1, .iprob2 = iprob2,
- .lprob1 = lprob1, .lprob2 = lprob2,
- .eprob1 = eprob1, .eprob2 = eprob2 ))),
- linkinv = eval(substitute(function(eta, extra = NULL) {
- prob1 = eta2theta(eta[,1], .lprob1, earg = .eprob1)
- prob2 = eta2theta(eta[,2], .lprob2, earg = .eprob2)
- cbind(prob1, prob2)
- }, list( .lprob1 = lprob1, .lprob2 = lprob2,
- .eprob1 = eprob1, .eprob2 = eprob2 ))),
- last = eval(substitute(expression({
- misc$link = c("prob1" = .lprob1, "prob2" = .lprob2)
- misc$earg <- list(prob1 = .eprob1, prob2 = .eprob2)
- misc$expected = TRUE
- misc$zero = .zero
- }), list( .lprob1 = lprob1, .lprob2 = lprob2,
- .eprob1 = eprob1, .eprob2 = eprob2,
- .zero = zero ))),
- loglikelihood = eval(substitute(
- function(mu,y,w,residuals = FALSE,eta, extra = NULL) {
- prob1 = eta2theta(eta[,1], .lprob1, earg = .eprob1)
- prob2 = eta2theta(eta[,2], .lprob2, earg = .eprob2)
- smallno = 100 * .Machine$double.eps
- prob1 = pmax(prob1, smallno)
- prob1 = pmin(prob1, 1-smallno)
- prob2 = pmax(prob2, smallno)
- prob2 = pmin(prob2, 1-smallno)
- mvector = w
- rvector = w * y[,1]
- svector = rvector * y[,2]
- if (residuals)
- stop("loglikelihood residuals not implemented yet") else {
- sum(rvector * log(prob1) + (mvector-rvector) * log1p(-prob1) +
- svector * log(prob2) + (rvector-svector) * log1p(-prob2))
- }
- }, list( .lprob1 = lprob1, .lprob2 = lprob2,
- .eprob1 = eprob1, .eprob2 = eprob2 ))),
- vfamily = c("seq2binomial"),
- deriv = eval(substitute(expression({
- prob1 = eta2theta(eta[,1], .lprob1, earg = .eprob1)
- prob2 = eta2theta(eta[,2], .lprob2, earg = .eprob2)
- smallno = 100 * .Machine$double.eps
- prob1 = pmax(prob1, smallno)
- prob1 = pmin(prob1, 1-smallno)
- prob2 = pmax(prob2, smallno)
- prob2 = pmin(prob2, 1-smallno)
- dprob1.deta = dtheta.deta(prob1, .lprob1, earg = .eprob1)
- dprob2.deta = dtheta.deta(prob2, .lprob2, earg = .eprob2)
- mvector = w
- rvector = w * y[,1]
- svector = rvector * y[,2]
- dl.dprob1 = rvector / prob1 - (mvector-rvector) / (1-prob1)
- dl.dprob2 = svector / prob2 - (rvector-svector) / (1-prob2)
- cbind(dl.dprob1 * dprob1.deta, dl.dprob2 * dprob2.deta)
- }), list( .lprob1 = lprob1, .lprob2 = lprob2,
- .eprob1 = eprob1, .eprob2 = eprob2 ))),
- weight = eval(substitute(expression({
- wz = matrix(0, n, M)
- wz[,iam(1,1,M)] = (dprob1.deta^2) / (prob1 * (1-prob1))
- wz[,iam(2,2,M)] = (dprob2.deta^2) * prob1 / (prob2 * (1-prob2))
- c(w) * wz
- }), list( .lprob1 = lprob1, .lprob2 = lprob2,
- .eprob1 = eprob1, .eprob2 = eprob2 ))))
+
+ new("vglmff",
+ blurb = c("Sequential binomial distribution ",
+ "(Crowder and Sweeting, 1989)\n",
+ "Links: ", namesof("prob1", lprob1, earg = eprob1), ", ",
+ namesof("prob2", lprob2, earg = eprob2)),
+ constraints = eval(substitute(expression({
+ constraints <- cm.zero.vgam(constraints, x, .zero, M)
+ }), list( .zero = zero ))),
+ initialize = eval(substitute(expression({
+ if (!is.vector(w))
+ stop("the 'weights' argument must be a vector")
+ if (any(abs(w - round(w)) > 0.000001))
+ stop("the 'weights' argument does not seem to be integer-valued")
+ if (ncol(y <- cbind(y)) != 2)
+ stop("the response must be a 2-column matrix")
+ if (any(y < 0 | y > 1))
+ stop("the response must have values between 0 and 1")
+
+ w = round(w)
+ rvector = w * y[,1]
+ if (any(abs(rvector - round(rvector)) > 1.0e-8))
+ warning("number of successes in column one ",
+ "should be integer-valued")
+ svector = rvector * y[,2]
+ if (any(abs(svector - round(svector)) > 1.0e-8))
+ warning("number of successes in",
+ " column two should be integer-valued")
+
+ predictors.names =
+ c(namesof("prob1", .lprob1,earg= .eprob1, tag = FALSE),
+ namesof("prob2", .lprob2,earg= .eprob2, tag = FALSE))
+ prob1.init = if (is.Numeric( .iprob1))
+ rep( .iprob1 , len = n) else
+ rep(weighted.mean(y[,1], w = w), len = n)
+ prob2.init = if (is.Numeric( .iprob2 ))
+ rep( .iprob2 , length = n) else
+ rep(weighted.mean(y[,2], w = w*y[,1]),
+ length = n)
+ if (!length(etastart)) {
+ etastart =
+ cbind(theta2eta(prob1.init, .lprob1, earg = .eprob1),
+ theta2eta(prob2.init, .lprob2, earg = .eprob2))
+ }
+ }), list( .iprob1 = iprob1, .iprob2 = iprob2,
+ .lprob1 = lprob1, .lprob2 = lprob2,
+ .eprob1 = eprob1, .eprob2 = eprob2 ))),
+ linkinv = eval(substitute(function(eta, extra = NULL) {
+ prob1 = eta2theta(eta[,1], .lprob1, earg = .eprob1)
+ prob2 = eta2theta(eta[,2], .lprob2, earg = .eprob2)
+ cbind(prob1, prob2)
+ }, list( .lprob1 = lprob1, .lprob2 = lprob2,
+ .eprob1 = eprob1, .eprob2 = eprob2 ))),
+ last = eval(substitute(expression({
+ misc$link = c("prob1" = .lprob1, "prob2" = .lprob2)
+ misc$earg <- list(prob1 = .eprob1, prob2 = .eprob2)
+ misc$expected = TRUE
+ misc$zero = .zero
+ }), list( .lprob1 = lprob1, .lprob2 = lprob2,
+ .eprob1 = eprob1, .eprob2 = eprob2,
+ .zero = zero ))),
+ loglikelihood = eval(substitute(
+ function(mu,y,w,residuals = FALSE,eta, extra = NULL) {
+ prob1 = eta2theta(eta[,1], .lprob1, earg = .eprob1)
+ prob2 = eta2theta(eta[,2], .lprob2, earg = .eprob2)
+ smallno = 100 * .Machine$double.eps
+ prob1 = pmax(prob1, smallno)
+ prob1 = pmin(prob1, 1-smallno)
+ prob2 = pmax(prob2, smallno)
+ prob2 = pmin(prob2, 1-smallno)
+ mvector = w
+ rvector = w * y[,1]
+ svector = rvector * y[,2]
+ if (residuals)
+ stop("loglikelihood residuals not implemented yet") else {
+ sum(rvector * log(prob1) + (mvector-rvector) * log1p(-prob1) +
+ svector * log(prob2) + (rvector-svector) * log1p(-prob2))
+ }
+ }, list( .lprob1 = lprob1, .lprob2 = lprob2,
+ .eprob1 = eprob1, .eprob2 = eprob2 ))),
+ vfamily = c("seq2binomial"),
+ deriv = eval(substitute(expression({
+ prob1 = eta2theta(eta[,1], .lprob1, earg = .eprob1)
+ prob2 = eta2theta(eta[,2], .lprob2, earg = .eprob2)
+ smallno = 100 * .Machine$double.eps
+ prob1 = pmax(prob1, smallno)
+ prob1 = pmin(prob1, 1-smallno)
+ prob2 = pmax(prob2, smallno)
+ prob2 = pmin(prob2, 1-smallno)
+ dprob1.deta = dtheta.deta(prob1, .lprob1, earg = .eprob1)
+ dprob2.deta = dtheta.deta(prob2, .lprob2, earg = .eprob2)
+
+ mvector = w
+ rvector = w * y[,1]
+ svector = rvector * y[,2]
+
+ dl.dprob1 = rvector / prob1 - (mvector-rvector) / (1-prob1)
+ dl.dprob2 = svector / prob2 - (rvector-svector) / (1-prob2)
+
+ cbind(dl.dprob1 * dprob1.deta, dl.dprob2 * dprob2.deta)
+ }), list( .lprob1 = lprob1, .lprob2 = lprob2,
+ .eprob1 = eprob1, .eprob2 = eprob2 ))),
+ weight = eval(substitute(expression({
+ wz = matrix(0, n, M)
+ wz[,iam(1,1,M)] = (dprob1.deta^2) / (prob1 * (1-prob1))
+ wz[,iam(2,2,M)] = (dprob2.deta^2) * prob1 / (prob2 * (1-prob2))
+ c(w) * wz
+ }), list( .lprob1 = lprob1, .lprob2 = lprob2,
+ .eprob1 = eprob1, .eprob2 = eprob2 ))))
}
-zipebcom = function(lmu12 = "cloglog", lphi12 = "logit", loratio = "loge",
- emu12 = list(), ephi12 = list(), eoratio = list(),
- imu12 = NULL, iphi12 = NULL, ioratio = NULL,
- zero = 2:3, tol = 0.001, addRidge = 0.001)
+ zipebcom = function(lmu12 = "cloglog",
+ lphi12 = "logit", loratio = "loge",
+ emu12 = list(), ephi12 = list(),
+ eoratio = list(),
+ imu12 = NULL, iphi12 = NULL,
+ ioratio = NULL,
+ zero = 2:3, tol = 0.001, addRidge = 0.001)
{
- if (mode(lphi12) != "character" && mode(lphi12) != "name")
- lphi12 = as.character(substitute(lphi12))
- if (mode(loratio) != "character" && mode(loratio) != "name")
- loratio = as.character(substitute(loratio))
+ if (mode(lphi12) != "character" && mode(lphi12) != "name")
+ lphi12 = as.character(substitute(lphi12))
+ if (mode(loratio) != "character" && mode(loratio) != "name")
+ loratio = as.character(substitute(loratio))
- if (!is.Numeric(tol, positive = TRUE, allowable.length = 1) ||
- tol > 0.1)
- stop("bad input for argument 'tol'")
- if (!is.Numeric(addRidge, allowable.length = 1, positive = TRUE) ||
- addRidge > 0.5)
- stop("bad input for argument 'addRidge'")
+ if (!is.Numeric(tol, positive = TRUE, allowable.length = 1) ||
+ tol > 0.1)
+ stop("bad input for argument 'tol'")
+ if (!is.Numeric(addRidge, allowable.length = 1, positive = TRUE) ||
+ addRidge > 0.5)
+ stop("bad input for argument 'addRidge'")
+
+ if (!is.list(emu12)) emu12 = list()
+ if (!is.list(ephi12)) ephi12 = list()
+ if (!is.list(eoratio)) eoratio = list()
- if (!is.list(emu12)) emu12 = list()
- if (!is.list(ephi12)) ephi12 = list()
- if (!is.list(eoratio)) eoratio = list()
+ if (lmu12 != "cloglog")
+ warning("argument 'lmu12' should be 'cloglog'")
- if (lmu12 != "cloglog")
- warning("argument 'lmu12' should be 'cloglog'")
new("vglmff",
blurb = c("Exchangeable bivariate ", lmu12,
@@ -1859,7 +1893,8 @@ zipebcom = function(lmu12 = "cloglog", lphi12 = "logit", loratio = "loge",
dp11star.dp1unstar = 2*(1-phivec)*Vab * Vabc
dp11star.dphi1 = -2 * A1vec * Vab * Vabc
dp11star.doratio = Vab / oratio
- yandmu = (y[,1]/mu[,1] - y[,2]/mu[,2] - y[,3]/mu[,3] + y[,4]/mu[,4])
+ yandmu = (y[,1]/mu[,1] - y[,2]/mu[,2] - y[,3]/mu[,3] +
+ y[,4]/mu[,4])
dp11.doratio = Vab / oratio
check.dl.doratio = yandmu * dp11.doratio
@@ -1867,9 +1902,10 @@ zipebcom = function(lmu12 = "cloglog", lphi12 = "logit", loratio = "loge",
dl.dmu1 = dp11star.dp1unstar * yandmu + (1-phivec) * cyandmu
dl.dphi1 = dp11star.dphi1 * yandmu - A1vec * cyandmu
dl.doratio = check.dl.doratio
- dthetas.detas = cbind(dtheta.deta(A1vec, .lmu12, earg = .emu12),
- dtheta.deta(phivec, .lphi12, earg = .ephi12),
- dtheta.deta(oratio, .loratio, earg = .eoratio))
+ dthetas.detas =
+ cbind(dtheta.deta(A1vec, .lmu12, earg = .emu12),
+ dtheta.deta(phivec, .lphi12, earg = .ephi12),
+ dtheta.deta(oratio, .loratio, earg = .eoratio))
c(w) * cbind(dl.dmu1,
dl.dphi1,
dl.doratio) * dthetas.detas
@@ -1885,8 +1921,9 @@ zipebcom = function(lmu12 = "cloglog", lphi12 = "logit", loratio = "loge",
(dthetas.detas[,2])^2
wz[,iam(2,2,M)] = alternwz22
- alternwz12 = -2*A1vec*(1-phivec)*(2/mu[,1] + 1/mu[,2] - 2*Vab*Vabc^2) *
- dthetas.detas[,1] * dthetas.detas[,2]
+ alternwz12 = -2*A1vec*(1-phivec)*
+ (2/mu[,1] + 1/mu[,2] - 2*Vab*Vabc^2) *
+ dthetas.detas[,1] * dthetas.detas[,2]
wz[,iam(1,2,M)] = alternwz12
alternwz33 = (Vab / oratio^2) * dthetas.detas[,3]^2
@@ -1949,9 +1986,9 @@ if (FALSE)
print( head(nnn1, 3) )
print("head(nnn2, 3)")
print( head(nnn2, 3) )
- init.pee1 = if (length( .iprob1 )) rep( .iprob1, len = n) else
+ init.pee1 = if (length( .iprob1 )) rep( .iprob1 , len = n) else
mu[, 1] / (mu[, 1] + mu[, 2])
- init.pee2 = if (length( .iprob2 )) rep( .iprob2, len = n) else
+ init.pee2 = if (length( .iprob2 )) rep( .iprob2 , len = n) else
mu[, 3] / (mu[, 3] + mu[, 4])
init.rhopos = pmax(1.1, init.pee1 / init.pee2) # Should be > 1
init.rhoneg = pmin(0.4, (1 - init.pee1) / (1 - init.pee2)) # c. 0
@@ -1960,8 +1997,8 @@ if (FALSE)
print("head(init.rhoneg, 3)")
print( head(init.rhoneg, 3) )
- if (length( .irhopos)) init.rhopos = rep( .irhopos, len = n)
- if (length( .irhoneg)) init.rhoneg = rep( .irhoneg, len = n)
+ if (length( .irhopos)) init.rhopos = rep( .irhopos , len = n)
+ if (length( .irhoneg)) init.rhoneg = rep( .irhoneg , len = n)
etastart = cbind(theta2eta(init.rhopos, .lrhopos, earg = .erhopos),
theta2eta(init.rhoneg, .lrhoneg, earg = .erhoneg))
print("etastart[1:3,]")
@@ -2132,9 +2169,11 @@ if (FALSE)
save.weight <- control$save.weight <- FALSE
}
if (is.null(etastart)) {
- mu1.init= if (is.Numeric(.imu1)) rep(.imu1, length = n) else
+ mu1.init= if (is.Numeric(.imu1))
+ rep(.imu1, length = n) else
mu[,3] + mu[,4]
- mu2.init= if (is.Numeric(.imu2)) rep(.imu2, length = n) else
+ mu2.init= if (is.Numeric(.imu2))
+ rep(.imu2, length = n) else
mu[,2] + mu[,4]
etastart = cbind(theta2eta(mu1.init, .lmu12, earg = .emu12),
theta2eta(mu2.init, .lmu12, earg = .emu12))
@@ -2144,7 +2183,7 @@ if (FALSE)
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))
+ rhovec = rep( .rho , len = nrow(eta))
p11 = pnorm2(eta[,1], eta[,2], rhovec)
p01 = pmin(pmargin[,2] - p11, pmargin[,2])
p10 = pmin(pmargin[,1] - p11, pmargin[,1])
@@ -2183,7 +2222,7 @@ if (FALSE)
deriv = eval(substitute(expression({
pmargin = cbind(eta2theta(eta[,1], .lmu12, earg = .emu12),
eta2theta(eta[,2], .lmu12, earg = .emu12))
- rhovec = rep( .rho, len = nrow(eta))
+ rhovec = rep( .rho , len = nrow(eta))
p11 = pnorm2(eta[,1], eta[,2], rhovec)
p01 = pmargin[,2]-p11
p10 = pmargin[,1]-p11
diff --git a/R/family.categorical.R b/R/family.categorical.R
index 5bbd4cd..5476c28 100644
--- a/R/family.categorical.R
+++ b/R/family.categorical.R
@@ -9,70 +9,81 @@
+
+
+
+
+
+
process.categorical.data.vgam = expression({
- if (!all(w == 1))
- extra$orig.w = w
- if (!is.matrix(y)) {
- yf = as.factor(y)
- lev = levels(yf)
- llev = length(lev)
- nn = length(yf)
- y = matrix(0, nn, llev)
- y[cbind(1:nn,as.vector(unclass(yf)))] = 1
- dimnames(y) = list(names(yf), lev)
- if (llev <= 1)
- stop("the response matrix does not have 2 or more columns")
- } else {
- nn = nrow(y)
- }
+ extra$y.integer = TRUE
- nvec = rowSums(y)
-
- if (min(y) < 0 || any(round(y) != y))
- stop("the response must be non-negative counts (integers)")
-
- if (!exists("delete.zero.colns") ||
- (exists("delete.zero.colns") && delete.zero.colns)) {
- sumy2 = colSums(y)
- if (any(index <- sumy2 == 0)) {
- y = y[,!index, drop = FALSE]
- sumy2 = sumy2[!index]
- if (all(index) || ncol(y) <= 1)
- stop("'y' matrix has 0 or 1 columns")
- warning("Deleted ", sum(!index),
- " columns of the response matrix due to zero counts")
- }
- }
+ if (!all(w == 1))
+ extra$orig.w = w
- if (any(miss <- (nvec == 0))) {
- smiss <- sum(miss)
- warning("Deleted ", smiss,
- " rows of the response matrix due to zero counts")
- x = x[!miss,, drop = FALSE]
- y = y[!miss,, drop = FALSE]
- w = cbind(w)
- w = w[!miss,, drop = FALSE]
+ if (!is.matrix(y)) {
+ yf = as.factor(y)
+ lev = levels(yf)
+ llev = length(lev)
+ nn = length(yf)
+ y = matrix(0, nn, llev)
+ y[cbind(1:nn,as.vector(unclass(yf)))] = 1
+ dimnames(y) = list(names(yf), lev)
+
+ if (llev <= 1)
+ stop("the response matrix does not have 2 or more columns")
+ } else {
+ nn = nrow(y)
+ }
- nvec = nvec[!miss]
- nn = nn - smiss
+ nvec = rowSums(y)
+
+ if (min(y) < 0 || any(round(y) != y))
+ stop("the response must be non-negative counts (integers)")
+
+ if (!exists("delete.zero.colns") ||
+ (exists("delete.zero.colns") && delete.zero.colns)) {
+ sumy2 = colSums(y)
+ if (any(index <- sumy2 == 0)) {
+ y = y[,!index, drop = FALSE]
+ sumy2 = sumy2[!index]
+ if (all(index) || ncol(y) <= 1)
+ stop("'y' matrix has 0 or 1 columns")
+ warning("Deleted ", sum(!index),
+ " columns of the response matrix due to zero counts")
}
+ }
- w = w * nvec
- nvec[nvec == 0] = 1
- y = prop.table(y, 1) # Convert to proportions
+ if (any(miss <- (nvec == 0))) {
+ smiss <- sum(miss)
+ warning("Deleted ", smiss,
+ " rows of the response matrix due to zero counts")
+ x = x[!miss,, drop = FALSE]
+ y = y[!miss,, drop = FALSE]
+ w = cbind(w)
+ w = w[!miss,, drop = FALSE]
+ nvec = nvec[!miss]
+ nn = nn - smiss
+ }
- if (length(mustart) + length(etastart) == 0) {
- mustart = y + (1 / ncol(y) - y) / nvec
- }
+ w = w * nvec
+
+ nvec[nvec == 0] = 1
+ y = prop.table(y, 1) # Convert to proportions
+
+
+ if (length(mustart) + length(etastart) == 0) {
+ mustart = y + (1 / ncol(y) - y) / nvec
+ }
})
@@ -122,33 +133,35 @@ Deviance.categorical.data.vgam <-
dmultinomial = function(x, size = NULL, prob, log = FALSE,
dochecking = TRUE, smallno = 1.0e-7) {
- if (!is.logical(log.arg <- log))
- stop("bad input for argument 'log'")
- rm(log)
-
- x = as.matrix(x)
- prob = as.matrix(prob)
- if (((K <- ncol(x)) <= 1) || ncol(prob) != K)
- stop("'x' and 'prob' must be matrices with two or more columns")
- if (dochecking) {
- if (min(prob) < 0)
- stop("'prob' contains some negative values")
- if (any(abs((rsprob <- rowSums(prob)) - 1) > smallno))
- stop("some rows of 'prob' do not add to unity")
- if (any(abs(x - round(x)) > smallno))
- stop("'x' should be integer valued")
- if (length(size)) {
- if (any(abs(size - rowSums(x)) > smallno))
- stop("rowSums(x) does not agree with 'size'")
- } else {
- size = round(rowSums(x))
- }
+ if (!is.logical(log.arg <- log))
+ stop("bad input for argument 'log'")
+ rm(log)
+
+ x = as.matrix(x)
+ prob = as.matrix(prob)
+ if (((K <- ncol(x)) <= 1) ||
+ ncol(prob) != K)
+ stop("arguments 'x' and 'prob' must be matrices with ",
+ "two or more columns")
+ if (dochecking) {
+ if (min(prob) < 0)
+ stop("argument 'prob' contains some negative values")
+ if (any(abs((rsprob <- rowSums(prob)) - 1) > smallno))
+ stop("some rows of 'prob' do not add to unity")
+ if (any(abs(x - round(x)) > smallno))
+ stop("argument 'x' should be integer-valued")
+ if (length(size)) {
+ if (any(abs(size - rowSums(x)) > smallno))
+ stop("rowSums(x) does not agree with argument 'size'")
} else {
- if (!length(size))
- size = round(rowSums(prob))
+ size = round(rowSums(x))
}
- logdensity = lgamma(size + 1) + rowSums(x * log(prob) - lgamma(x + 1))
- if (log.arg) logdensity else exp(logdensity)
+ } else {
+ if (!length(size))
+ size = round(rowSums(prob))
+ }
+ logdensity = lgamma(size + 1) + rowSums(x * log(prob) - lgamma(x + 1))
+ if (log.arg) logdensity else exp(logdensity)
}
@@ -160,276 +173,340 @@ dmultinomial = function(x, size = NULL, prob, log = FALSE,
sratio = function(link = "logit", earg = list(),
- parallel = FALSE, reverse = FALSE, zero = NULL)
+ parallel = FALSE, reverse = FALSE, zero = NULL,
+ whitespace = FALSE)
{
- if (mode(link) != "character" && mode(link) != "name")
- link = as.character(substitute(link))
- if (!is.list(earg)) earg = list()
- if (!is.logical(reverse) || length(reverse) != 1)
- stop("argument 'reverse' must be a single logical")
-
- new("vglmff",
- blurb = c("Stopping Ratio model\n\n",
- "Links: ",
- namesof(if (reverse) "P[Y=j+1|Y<=j+1]" else "P[Y=j|Y>=j]",
- link, earg = earg),
- "\n",
- "Variance: mu[,j]*(1-mu[,j]); -mu[,j]*mu[,k]"),
- 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 = Deviance.categorical.data.vgam,
- initialize = eval(substitute(expression({
- delete.zero.colns = TRUE
- 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 = "")
- predictors.names = namesof(mynames, .link, short = TRUE, earg = .earg)
- 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 ))),
- linkinv = eval(substitute( function(eta, extra = NULL) {
- if (!is.matrix(eta))
- eta = as.matrix(eta)
- fv.matrix =
- if ( .reverse ) {
- M = ncol(eta)
- djr = eta2theta(eta, .link, earg = .earg )
- temp = tapplymat1(1-djr[,M:1], "cumprod")[,M:1]
- cbind(1,djr) * cbind(temp,1)
- } else {
- dj = eta2theta(eta, .link, earg = .earg )
- temp = tapplymat1(1-dj, "cumprod")
- cbind(dj,1) * cbind(1, temp)
- }
- if (length(extra$dimnamesy2))
- dimnames(fv.matrix) = list(dimnames(eta)[[1]], extra$dimnamesy2)
- fv.matrix
- }, list( .earg = earg, .link = link, .reverse = reverse) )),
- last = eval(substitute(expression({
- misc$link = rep( .link, length=M)
- names(misc$link) = mynames
-
- misc$earg = vector("list", M)
- names(misc$earg) = names(misc$link)
- 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 ))),
- linkfun = eval(substitute( function(mu, extra = NULL) {
- cump = tapplymat1(mu, "cumsum")
- if ( .reverse ) {
- djr = mu[,-1] / cump[,-1]
- theta2eta(djr, .link, earg = .earg )
- } else {
- M = ncol(mu) - 1
- dj = if (M == 1) mu[, 1] else
- mu[, 1:M] / (1 - cbind(0, cump[, 1:(M-1)]))
- theta2eta(dj, .link, earg = .earg )
- }
- }, list( .earg = earg, .link = link, .reverse = reverse) )),
- loglikelihood = function(mu, y, w, residuals = FALSE, eta, extra = NULL)
- 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
- nvec = if (is.numeric(extra$orig.w)) round(w / extra$orig.w) else
- round(w)
-
- smallno = 1.0e4 * .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) *
- dmultinomial(x = ycounts, size = nvec, prob = mu,
- log = TRUE, dochecking = FALSE))
- },
- vfamily = c("sratio", "vcategorical"),
- deriv = eval(substitute(expression({
- if (!length(extra$mymat)) {
- extra$mymat = if ( .reverse ) tapplymat1(y, "cumsum") else
- tapplymat1(y[,ncol(y):1], "cumsum")[,ncol(y):1]
- }
- if ( .reverse ) {
- djr = eta2theta(eta, .link, earg = .earg )
- Mp1 = ncol(extra$mymat)
- c(w) * (y[,-1]/djr - extra$mymat[,-Mp1]/(1-djr)) *
- dtheta.deta(djr, .link, earg = .earg )
- } else {
- dj = eta2theta(eta, .link, earg = .earg )
- c(w) * (y[,-ncol(y)]/dj - extra$mymat[,-1]/(1-dj)) *
- dtheta.deta(dj, .link, earg = .earg )
- }
- }), list( .earg = earg, .link = link, .reverse = reverse) )),
- weight = eval(substitute(expression({
- if ( .reverse ) {
- cump = tapplymat1(mu, "cumsum")
- ddjr.deta = dtheta.deta(djr, .link, earg = .earg )
- wz = c(w) * ddjr.deta^2 *
- (mu[,-1] / djr^2 + cump[, 1:M] / (1-djr)^2)
- } else {
- ccump = tapplymat1(mu[,ncol(mu):1], "cumsum")[,ncol(mu):1]
- ddj.deta = dtheta.deta(dj, .link, earg = .earg )
- wz = c(w) * ddj.deta^2 *
- (mu[, 1:M] / dj^2 + ccump[,-1] / (1-dj)^2)
- }
+ if (mode(link) != "character" && mode(link) != "name")
+ link = as.character(substitute(link))
+ if (!is.list(earg)) earg = list()
+ if (!is.logical(reverse) || length(reverse) != 1)
+ stop("argument 'reverse' must be a single logical")
+
+ stopifnot(is.logical(whitespace) &&
+ length(whitespace) == 1)
+ fillerChar <- ifelse(whitespace, " ", "")
+
+
+ new("vglmff",
+ blurb = c("Stopping Ratio model\n\n",
+ "Links: ",
+ namesof(if (reverse)
+ ifelse(whitespace, "P[Y = j+1|Y <= j+1]", "P[Y=j+1|Y<=j+1]") else
+ ifelse(whitespace, "P[Y = j|Y >= j]", "P[Y=j|Y>=j]"),
+ link, earg = earg), "\n",
+ "Variance: ",
+ ifelse(whitespace,
+ "mu[,j] * (1 - mu[,j]); -mu[,j] * mu[,k]",
+ "mu[,j]*(1-mu[,j]); -mu[,j]*mu[,k]")),
+ 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 = Deviance.categorical.data.vgam,
+
+ initialize = eval(substitute(expression({
+ delete.zero.colns = TRUE
+ eval(process.categorical.data.vgam)
+ extra$wy.prod = TRUE
+ M = ncol(y) - 1
+
+ mynames = if ( .reverse)
+ paste("P[Y", .fillerChar, "=", .fillerChar, 2:(M+1), "|Y",
+ .fillerChar, "<=", .fillerChar, 2:(M+1), "]", sep = "") else
+ paste("P[Y", .fillerChar, "=", .fillerChar, 1:M, "|Y",
+ .fillerChar, ">=", .fillerChar, 1:M, "]", sep = "")
+ predictors.names =
+ namesof(mynames, .link , short = TRUE, earg = .earg)
+ 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,
+ .fillerChar = fillerChar,
+ .whitespace = whitespace ))),
+
+ linkinv = eval(substitute( function(eta, extra = NULL) {
+ if (!is.matrix(eta))
+ eta = as.matrix(eta)
+ fv.matrix =
+ if ( .reverse ) {
+ M = ncol(eta)
+ djr = eta2theta(eta, .link , earg = .earg )
+ temp = tapplymat1(1 - djr[, M:1], "cumprod")[, M:1]
+ cbind(1, djr) * cbind(temp, 1)
+ } else {
+ dj = eta2theta(eta, .link , earg = .earg )
+ temp = tapplymat1(1 - dj, "cumprod")
+ cbind(dj, 1) * cbind(1, temp)
+ }
+ if (length(extra$dimnamesy2))
+ dimnames(fv.matrix) = list(dimnames(eta)[[1]],
+ extra$dimnamesy2)
+ fv.matrix
+ }, list( .earg = earg, .link = link, .reverse = reverse) )),
+ last = eval(substitute(expression({
+ misc$link = rep( .link , length = M)
+ names(misc$link) = mynames
+
+ misc$earg = vector("list", M)
+ names(misc$earg) = names(misc$link)
+ for (ii in 1:M) misc$earg[[ii]] = .earg
+
+ misc$parameters = mynames
+ misc$reverse = .reverse
+ misc$fillerChar = .fillerChar
+ misc$whitespace = .whitespace
+
+ extra = list() # kill what was used
+ }), list( .earg = earg, .link = link, .reverse = reverse,
+ .fillerChar = fillerChar,
+ .whitespace = whitespace ))),
+ linkfun = eval(substitute( function(mu, extra = NULL) {
+ cump = tapplymat1(mu, "cumsum")
+ if ( .reverse ) {
+ djr = mu[, -1] / cump[, -1]
+ theta2eta(djr, .link , earg = .earg )
+ } else {
+ M = ncol(mu) - 1
+ dj = if (M == 1) mu[, 1] else
+ mu[, 1:M] / (1 - cbind(0, cump[, 1:(M-1)]))
+ theta2eta(dj, .link , earg = .earg )
+ }
+ }, list( .earg = earg, .link = link, .reverse = reverse) )),
+ loglikelihood =
+ function(mu, y, w, residuals = FALSE, eta, extra = NULL)
+ 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
+ nvec = if (is.numeric(extra$orig.w)) round(w / extra$orig.w) else
+ round(w)
+
+ smallno = 1.0e4 * .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) *
+ dmultinomial(x = ycounts, size = nvec, prob = mu,
+ log = TRUE, dochecking = FALSE))
+ },
+ vfamily = c("sratio", "vcategorical"),
+ deriv = eval(substitute(expression({
+ if (!length(extra$mymat)) {
+ extra$mymat = if ( .reverse ) tapplymat1(y, "cumsum") else
+ tapplymat1(y[,ncol(y):1], "cumsum")[,ncol(y):1]
+ }
+ if ( .reverse ) {
+ djr = eta2theta(eta, .link , earg = .earg )
+ Mp1 = ncol(extra$mymat)
+ c(w) * (y[, -1] / djr - extra$mymat[, -Mp1] / (1 - djr)) *
+ dtheta.deta(djr, .link , earg = .earg )
+ } else {
+ dj = eta2theta(eta, .link , earg = .earg )
+ c(w) * (y[, -ncol(y)] / dj - extra$mymat[, -1] / (1 - dj)) *
+ dtheta.deta(dj, .link , earg = .earg )
+ }
+ }), list( .earg = earg, .link = link, .reverse = reverse) )),
+ weight = eval(substitute(expression({
+ if ( .reverse ) {
+ cump = tapplymat1(mu, "cumsum")
+ ddjr.deta = dtheta.deta(djr, .link , earg = .earg )
+ wz = c(w) * ddjr.deta^2 *
+ (mu[, -1] / djr^2 + cump[, 1:M] / (1 - djr)^2)
+ } else {
+ ccump = tapplymat1(mu[, ncol(mu):1], "cumsum")[, ncol(mu):1]
+ ddj.deta = dtheta.deta(dj, .link , earg = .earg )
+ wz = c(w) * ddj.deta^2 *
+ (mu[, 1:M] / dj^2 + ccump[, -1] / (1 - dj)^2)
+ }
- wz
- }), list( .earg = earg, .link = link, .reverse = reverse ))))
+ wz
+ }), list( .earg = earg, .link = link, .reverse = reverse ))))
}
cratio = function(link = "logit", earg = list(),
- parallel = FALSE, reverse = FALSE, zero = NULL)
+ parallel = FALSE, reverse = FALSE, zero = NULL,
+ whitespace = FALSE)
{
- if (mode(link) != "character" && mode(link) != "name")
- link = as.character(substitute(link))
- if (!is.list(earg)) earg = list()
- if (!is.logical(reverse) || length(reverse) != 1)
- stop("argument 'reverse' must be a single logical")
-
- new("vglmff",
- blurb = c("Continuation Ratio model\n\n",
- "Links: ",
- namesof(if (reverse) "P[Y<j+1|Y<=j+1]" else "P[Y>j|Y>=j]",
- link, earg = earg),
- "\n",
- "Variance: mu[,j]*(1-mu[,j]); -mu[,j]*mu[,k]"),
- 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 = Deviance.categorical.data.vgam,
- initialize = eval(substitute(expression({
- delete.zero.colns = TRUE
- 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 = "")
- predictors.names = namesof(mynames, .link, short = TRUE, earg = .earg)
- 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 ))),
- linkinv = eval(substitute( function(eta, extra = NULL) {
- if (!is.matrix(eta))
- eta = as.matrix(eta)
- fv.matrix =
- if ( .reverse ) {
- M = ncol(eta)
- djrs = eta2theta(eta, .link, earg = .earg )
- temp = tapplymat1(djrs[,M:1], "cumprod")[,M:1]
- cbind(1,1-djrs) * cbind(temp,1)
- } else {
- djs = eta2theta(eta, .link, earg = .earg )
- temp = tapplymat1(djs, "cumprod")
- cbind(1-djs,1) * cbind(1, temp)
- }
- if (length(extra$dimnamesy2))
- dimnames(fv.matrix) = list(dimnames(eta)[[1]], extra$dimnamesy2)
- fv.matrix
- }, list( .earg = earg, .link = link, .reverse = reverse) )),
- last = eval(substitute(expression({
- misc$link = rep( .link, length=M)
- names(misc$link) = mynames
- misc$earg = vector("list", M)
- names(misc$earg) = names(misc$link)
- 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 ))),
- linkfun = eval(substitute( function(mu, extra = NULL) {
- cump = tapplymat1(mu, "cumsum")
- if ( .reverse ) {
- djrs = 1 - mu[,-1] / cump[,-1]
- theta2eta(djrs, .link, earg = .earg )
- } else {
- M = ncol(mu) - 1
- djs = if (M == 1) 1 - mu[, 1] else
- 1 - mu[, 1:M] / (1 - cbind(0, cump[, 1:(M-1)]))
- theta2eta(djs, .link, earg = .earg )
- }
- }, list( .earg = earg, .link = link, .reverse = reverse) )),
- loglikelihood = function(mu, y, w, residuals = FALSE, eta, extra = NULL)
- 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
- nvec = if (is.numeric(extra$orig.w)) round(w / extra$orig.w) else
- round(w)
-
- smallno = 1.0e4 * .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) *
- dmultinomial(x = ycounts, size = nvec, prob = mu,
- log = TRUE, dochecking = FALSE))
- },
- vfamily = c("cratio", "vcategorical"),
- deriv = eval(substitute(expression({
- if (!length(extra$mymat)) {
- extra$mymat = if ( .reverse ) tapplymat1(y, "cumsum") else
- tapplymat1(y[,ncol(y):1], "cumsum")[,ncol(y):1]
- }
- if ( .reverse ) {
- djrs = eta2theta(eta, .link, earg = .earg )
- Mp1 = ncol(extra$mymat)
- -c(w) * (y[,-1]/(1-djrs) - extra$mymat[,-Mp1]/djrs) *
- dtheta.deta(djrs, .link, earg = .earg )
- } else {
- djs = eta2theta(eta, .link, earg = .earg )
- -c(w) * (y[,-ncol(y)]/(1-djs) - extra$mymat[,-1]/djs) *
- dtheta.deta(djs, .link, earg = .earg )
- }
- }), list( .earg = earg, .link = link, .reverse = reverse) )),
- weight = eval(substitute(expression({
- if ( .reverse ) {
- cump = tapplymat1(mu, "cumsum")
- ddjrs.deta = dtheta.deta(djrs, .link, earg = .earg )
- wz = c(w) * ddjrs.deta^2 *
- (mu[, -1] / (1-djrs)^2 + cump[, 1:M] / djrs^2)
- } else {
- ccump = tapplymat1(mu[, ncol(mu):1], "cumsum")[, ncol(mu):1]
- ddjs.deta = dtheta.deta(djs, .link, earg = .earg )
- wz = c(w) * ddjs.deta^2 *
- (mu[, 1:M] / (1 - djs)^2 + ccump[, -1] / djs^2)
- }
+ if (mode(link) != "character" && mode(link) != "name")
+ link = as.character(substitute(link))
+ if (!is.list(earg)) earg = list()
+ if (!is.logical(reverse) || length(reverse) != 1)
+ stop("argument 'reverse' must be a single logical")
+
+ stopifnot(is.logical(whitespace) &&
+ length(whitespace) == 1)
+ fillerChar <- ifelse(whitespace, " ", "")
+
+
+ new("vglmff",
+ blurb = c("Continuation Ratio model\n\n",
+ "Links: ",
+ namesof(if (reverse)
+ ifelse(whitespace, "P[Y < j+1|Y <= j+1]", "P[Y<j+1|Y<=j+1]") else
+ ifelse(whitespace, "P[Y > j|Y >= j]", "P[Y>j|Y>=j]"),
+ link, earg = earg),
+ "\n",
+ "Variance: ",
+ ifelse(whitespace,
+ "mu[,j] * (1 - mu[,j]); -mu[,j] * mu[,k]",
+ "mu[,j]*(1-mu[,j]); -mu[,j]*mu[,k]")),
+
+ 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 = Deviance.categorical.data.vgam,
+
+ initialize = eval(substitute(expression({
+ delete.zero.colns = TRUE
+ eval(process.categorical.data.vgam)
+ M = ncol(y) - 1
+
+ mynames = if ( .reverse )
+ paste("P[Y", .fillerChar, "<", .fillerChar, 2:(M+1), "|Y",
+ .fillerChar, "<=", .fillerChar, 2:(M+1), "]", sep = "") else
+ paste("P[Y", .fillerChar, ">", .fillerChar, 1:M, "|Y",
+ .fillerChar, ">=", .fillerChar, 1:M, "]", sep = "")
+ predictors.names =
+ namesof(mynames, .link , short = TRUE, earg = .earg)
+ 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,
+ .fillerChar = fillerChar,
+ .whitespace = whitespace ))),
+
+ linkinv = eval(substitute( function(eta, extra = NULL) {
+ if (!is.matrix(eta))
+ eta = as.matrix(eta)
+ fv.matrix =
+ if ( .reverse ) {
+ M = ncol(eta)
+ djrs = eta2theta(eta, .link , earg = .earg )
+ temp = tapplymat1(djrs[, M:1], "cumprod")[, M:1]
+ cbind(1, 1 - djrs) * cbind(temp, 1)
+ } else {
+ djs = eta2theta(eta, .link , earg = .earg )
+ temp = tapplymat1(djs, "cumprod")
+ cbind(1 - djs,1) * cbind(1, temp)
+ }
+ if (length(extra$dimnamesy2))
+ dimnames(fv.matrix) = list(dimnames(eta)[[1]],
+ extra$dimnamesy2)
+ fv.matrix
+ }, list( .earg = earg, .link = link, .reverse = reverse) )),
+ last = eval(substitute(expression({
+ misc$link = rep( .link , length = M)
+
+ names(misc$link) = mynames
+ misc$earg = vector("list", M)
+ names(misc$earg) = names(misc$link)
+ for (ii in 1:M) misc$earg[[ii]] = .earg
+
+ misc$parameters = mynames
+ misc$reverse = .reverse
+ misc$fillerChar = .fillerChar
+ misc$whitespace = .whitespace
+
+
+ extra = list() # kill what was used
+ }), list( .earg = earg, .link = link, .reverse = reverse,
+ .fillerChar = fillerChar,
+ .whitespace = whitespace ))),
+ linkfun = eval(substitute( function(mu, extra = NULL) {
+ cump = tapplymat1(mu, "cumsum")
+ if ( .reverse ) {
+ djrs = 1 - mu[, -1] / cump[, -1]
+ theta2eta(djrs, .link , earg = .earg )
+ } else {
+ M = ncol(mu) - 1
+ djs = if (M == 1) 1 - mu[, 1] else
+ 1 - mu[, 1:M] / (1 - cbind(0, cump[, 1:(M-1)]))
+ theta2eta(djs, .link , earg = .earg )
+ }
+ }, list( .earg = earg, .link = link, .reverse = reverse) )),
+ loglikelihood =
+ function(mu, y, w, residuals = FALSE, eta, extra = NULL)
+ 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
+ nvec = if (is.numeric(extra$orig.w)) round(w / extra$orig.w) else
+ round(w)
+
+ smallno = 1.0e4 * .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) *
+ dmultinomial(x = ycounts, size = nvec, prob = mu,
+ log = TRUE, dochecking = FALSE))
+ },
+
+ vfamily = c("cratio", "vcategorical"),
+
+ deriv = eval(substitute(expression({
+ if (!length(extra$mymat)) {
+ extra$mymat = if ( .reverse ) tapplymat1(y, "cumsum") else
+ tapplymat1(y[,ncol(y):1], "cumsum")[,ncol(y):1]
+ }
+ if ( .reverse ) {
+ djrs = eta2theta(eta, .link , earg = .earg )
+ Mp1 = ncol(extra$mymat)
+ -c(w) * (y[, -1]/(1 - djrs) - extra$mymat[, -Mp1]/djrs) *
+ dtheta.deta(djrs, .link , earg = .earg )
+ } else {
+ djs = eta2theta(eta, .link , earg = .earg )
+ -c(w) * (y[, -ncol(y)]/(1 - djs) - extra$mymat[, -1]/djs) *
+ dtheta.deta(djs, .link , earg = .earg )
+ }
+ }), list( .earg = earg, .link = link, .reverse = reverse) )),
+
+ weight = eval(substitute(expression({
+ if ( .reverse ) {
+ cump = tapplymat1(mu, "cumsum")
+ ddjrs.deta = dtheta.deta(djrs, .link , earg = .earg )
+ wz = c(w) * ddjrs.deta^2 *
+ (mu[, -1] / (1 - djrs)^2 + cump[, 1:M] / djrs^2)
+ } else {
+ ccump = tapplymat1(mu[, ncol(mu):1], "cumsum")[, ncol(mu):1]
+ ddjs.deta = dtheta.deta(djs, .link , earg = .earg )
+ wz = c(w) * ddjs.deta^2 *
+ (mu[, 1:M] / (1 - djs)^2 + ccump[, -1] / djs^2)
+ }
- wz
- }), list( .earg = earg, .link = link, .reverse = reverse ))))
+ wz
+ }), list( .earg = earg, .link = link, .reverse = reverse ))))
}
-vglm.multinomial.deviance.control = function(maxit=21, panic = FALSE, ...)
+vglm.multinomial.deviance.control = function(maxit = 21, panic = FALSE, ...)
{
if (maxit < 1) {
warning("bad value of maxit; using 21 instead")
maxit = 21
}
- list(maxit=maxit, panic=as.logical(panic)[1])
+ list(maxit=maxit, panic = as.logical(panic)[1])
}
-vglm.multinomial.control = function(maxit=21, panic = FALSE,
- criterion=c("aic1", "aic2", names( .min.criterion.VGAM )), ...)
+vglm.multinomial.control = function(maxit = 21, panic = FALSE,
+ criterion = c("aic1", "aic2", names( .min.criterion.VGAM )), ...)
{
if (mode(criterion) != "character" && mode(criterion) != "name")
criterion = as.character(substitute(criterion))
@@ -440,293 +517,367 @@ vglm.multinomial.control = function(maxit=21, panic = FALSE,
warning("bad value of maxit; using 21 instead")
maxit = 21
}
- list(maxit=maxit, panic=as.logical(panic)[1],
- criterion=criterion,
- min.criterion=c("aic1" = FALSE, "aic2" = TRUE, .min.criterion.VGAM))
+ list(maxit = maxit, panic = as.logical(panic)[1],
+ criterion = criterion,
+ 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")
maxit = 200
}
- list(maxit=maxit, trace=as.logical(trace)[1], panic=as.logical(panic)[1])
+ list(maxit=maxit, trace=as.logical(trace)[1],
+ panic = as.logical(panic)[1])
}
- multinomial = function(zero = NULL, parallel = FALSE, nointercept = NULL,
- refLevel = "last")
-{
- if (length(refLevel) != 1) stop("the length of 'refLevel' must be one")
- if (is.character(refLevel)) {
- if (refLevel != "last")
- stop('if a character, refLevel must be "last"')
- refLevel = -1
- } else if (is.factor(refLevel)) {
- if (is.ordered(refLevel))
- warning("'refLevel' is from an ordered factor")
- refLevel = as.character(refLevel) == levels(refLevel)
- refLevel = (1:length(refLevel))[refLevel]
- if (!is.Numeric(refLevel, allowable.length = 1, integer.valued = TRUE, positive = TRUE))
- stop("could not coerce 'refLevel' into a single positive integer")
- } else if (!is.Numeric(refLevel, allowable.length = 1, integer.valued = TRUE, positive = TRUE))
- stop("'refLevel' must be a single positive integer")
- new("vglmff",
- blurb = c("Multinomial logit model\n\n",
- if (refLevel < 0)
- "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
- paste("Links: log(mu[,j]/mu[,", refLevel,
- "]), j=c(1:", refLevel-1,
- ",", refLevel+1, ":(M+1)),\n",
- sep = "")
- },
- "Variance: mu[,j]*(1-mu[,j]); -mu[,j]*mu[,k]"),
- constraints = eval(substitute(expression({
+ multinomial = function(zero = NULL, parallel = FALSE, nointercept = NULL,
+ refLevel = "last",
+ whitespace = FALSE)
+{
+ if (length(refLevel) != 1)
+ stop("the length of 'refLevel' must be one")
+ if (is.character(refLevel)) {
+ if (refLevel != "last")
+ stop('if a character, refLevel must be "last"')
+ refLevel = -1
+ } else
+ if (is.factor(refLevel)) {
+ if (is.ordered(refLevel))
+ warning("'refLevel' is from an ordered factor")
+ refLevel = as.character(refLevel) == levels(refLevel)
+ refLevel = (1:length(refLevel))[refLevel]
+ if (!is.Numeric(refLevel, allowable.length = 1,
+ integer.valued = TRUE, positive = TRUE))
+ stop("could not coerce 'refLevel' into a single positive integer")
+ } else
+ if (!is.Numeric(refLevel, allowable.length = 1,
+ integer.valued = TRUE, positive = TRUE))
+ stop("'refLevel' must be a single positive integer")
+
+
+ stopifnot(is.logical(whitespace) &&
+ length(whitespace) == 1)
+ fillerChar <- ifelse(whitespace, " ", "")
+
+
+ new("vglmff",
+ blurb = c("Multinomial logit model\n\n",
+ "Links: ",
+ if (refLevel < 0)
+ ifelse(whitespace,
+ "log(mu[,j] / mu[,M+1]), j = 1:M,\n",
+ "log(mu[,j]/mu[,M+1]), j=1:M,\n") else {
+ if (refLevel == 1) {
+ paste("log(mu[,", "j]", fillerChar, "/", fillerChar,
+ "mu[,", refLevel, "]), j",
+ fillerChar, "=", fillerChar, "2:(M+1),\n",
+ sep = "")
+ } else {
+ paste("log(mu[,", "j]", fillerChar, "/",
+ "mu[,", refLevel, "]), j",
+ fillerChar, "=", fillerChar, "c(1:", refLevel-1,
+ ",", fillerChar, refLevel+1, ":(M+1)),\n",
+ sep = "")
+ }
+ },
+ "Variance: ",
+ ifelse(whitespace,
+ "mu[,j] * (1 - mu[,j]); -mu[,j] * mu[,k]",
+ "mu[,j]*(1-mu[,j]); -mu[,j]*mu[,k]")),
+
+ constraints = eval(substitute(expression({
+
+
+
+
+
+ constraints = cm.vgam(matrix(1, M, 1), x, .parallel, constraints,
+ intercept.apply = FALSE)
+ constraints = cm.zero.vgam(constraints, x, .zero, M)
+ constraints = cm.nointercept.vgam(constraints, x, .nointercept, M)
+ }), list( .parallel = parallel, .zero = zero,
+ .nointercept = nointercept,
+ .refLevel = refLevel ))),
+ deviance = Deviance.categorical.data.vgam,
+
+ initialize = eval(substitute(expression({
+ delete.zero.colns = TRUE
+ eval(process.categorical.data.vgam)
+
+ M = ncol(y)-1
+ use.refLevel = if ( .refLevel < 0) M+1 else .refLevel
+ if (use.refLevel > (M+1))
+ stop("argument 'refLevel' has a value that is too high")
+
+ allbut.refLevel = (1:(M+1))[-use.refLevel]
+ predictors.names =
+ paste("log(mu[,", allbut.refLevel,
+ "]", .fillerChar, "/", .fillerChar, "mu[,",
+ use.refLevel, "])", sep = "")
+ y.names = paste("mu", 1:(M+1), sep = "")
+ }), list( .refLevel = refLevel,
+ .fillerChar = fillerChar,
+ .whitespace = whitespace ))),
+
+ 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))
+ if ( (.refLevel < 0) || (.refLevel == M+1)) {
+ phat = cbind(exp(eta), 1)
+ } else if ( .refLevel == 1) {
+ phat = cbind(1, exp(eta))
+ } else {
+ use.refLevel = if ( .refLevel < 0) M+1 else .refLevel
+ etamat = cbind(eta[, 1:( .refLevel - 1)], 0,
+ eta[, ( .refLevel ):M])
+ phat = exp(etamat)
+ }
+ ans = phat / as.vector(phat %*% rep(1, ncol(phat)))
+ if (any(is.na(ans)))
+ warning("there are NAs here in slot inverse")
+ ans
+ }), list( .refLevel = refLevel )),
- constraints = cm.vgam(matrix(1,M,1), x, .parallel, constraints,
- intercept.apply = FALSE)
- constraints = cm.zero.vgam(constraints, x, .zero, M)
- constraints = cm.nointercept.vgam(constraints, x, .nointercept, M)
- }), list( .parallel = parallel, .zero = zero, .nointercept=nointercept,
- .refLevel = refLevel ))),
- deviance = Deviance.categorical.data.vgam,
- initialize = eval(substitute(expression({
- delete.zero.colns = TRUE
- eval(process.categorical.data.vgam)
- M = ncol(y)-1
- use.refLevel = if ( .refLevel < 0) M+1 else .refLevel
- if (use.refLevel > (M+1))
- 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 = "")
- }), list( .refLevel = refLevel ))),
- 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))
- if ( (.refLevel < 0) || (.refLevel == M+1)) {
- phat = cbind(exp(eta), 1)
- } else if ( .refLevel == 1) {
- phat = cbind(1, exp(eta))
- } else {
- use.refLevel = if ( .refLevel < 0) M+1 else .refLevel
- etamat = cbind(eta[, 1:( .refLevel - 1)], 0,
- eta[,( .refLevel ):M])
- phat = exp(etamat)
- }
- ans = phat / as.vector(phat %*% rep(1, ncol(phat)))
- if (any(is.na(ans)))
- warning("there are NAs here in slot inverse")
- ans
- }), list( .refLevel = refLevel )),
- last = eval(substitute(expression({
- misc$refLevel = if ( .refLevel < 0) M+1 else .refLevel
- misc$link = "mlogit"
- misc$earg = list(mlogit = list()) # vector("list", M)
+ last = eval(substitute(expression({
+ misc$refLevel = if ( .refLevel < 0) M+1 else .refLevel
+ misc$link = "mlogit"
+ misc$earg = list(mlogit = list()) # vector("list", M)
- dy = dimnames(y)
- if (!is.null(dy[[2]]))
- dimnames(fit$fitted.values) = dy
+ dy = dimnames(y)
+ if (!is.null(dy[[2]]))
+ dimnames(fit$fitted.values) = dy
- 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 {
- use.refLevel = if ( .refLevel < 0) ncol(mu) else .refLevel
- log(mu[,-( use.refLevel )] / mu[, use.refLevel ])
- }
- }), list( .refLevel = refLevel )),
- loglikelihood = function(mu, y, w, residuals = FALSE, eta, extra = NULL)
- 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
- nvec = if (is.numeric(extra$orig.w)) round(w / extra$orig.w) else
- round(w)
+ misc$nointercept = .nointercept
+ }), list( .refLevel = refLevel,
+ .nointercept = nointercept ))),
- smallno = 1.0e4 * .Machine$double.eps
- if (max(abs(ycounts - round(ycounts))) > smallno)
- warning("converting 'ycounts' to integer in @loglikelihood")
- ycounts = round(ycounts)
+ linkfun = eval(substitute( function(mu, extra = NULL) {
+ if ( .refLevel < 0) {
+ log(mu[, -ncol(mu)] / mu[,ncol(mu)])
+ } else {
+ use.refLevel = if ( .refLevel < 0) ncol(mu) else .refLevel
+ log(mu[, -( use.refLevel )] / mu[, use.refLevel ])
+ }
+ }), list( .refLevel = refLevel )),
- sum((if (is.numeric(extra$orig.w)) extra$orig.w else 1) *
- dmultinomial(x = ycounts, size = nvec, prob = mu,
- log = TRUE, dochecking = FALSE))
- },
- vfamily = c("multinomial", "vcategorical"),
- deriv = eval(substitute(expression({
- if ( .refLevel < 0) {
- c(w) * (y[,-ncol(y)] - mu[,-ncol(y)])
- } else {
- use.refLevel = if ( .refLevel < 0) M+1 else .refLevel
- c(w) * (y[,-use.refLevel] - mu[,-use.refLevel])
- }
- }), list( .refLevel = refLevel ))),
- weight = eval(substitute(expression({
- mytiny = (mu < sqrt(.Machine$double.eps)) |
- (mu > 1.0 - sqrt(.Machine$double.eps))
+ loglikelihood =
+ function(mu, y, w, residuals = FALSE, eta, extra = NULL)
+ 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
+ nvec = if (is.numeric(extra$orig.w)) round(w / extra$orig.w) else
+ round(w)
+
+ smallno = 1.0e4 * .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) *
+ dmultinomial(x = ycounts, size = nvec, prob = mu,
+ log = TRUE, dochecking = FALSE))
+ },
+ vfamily = c("multinomial", "vcategorical"),
+ deriv = eval(substitute(expression({
+ if ( .refLevel < 0) {
+ c(w) * (y[, -ncol(y)] - mu[, -ncol(y)])
+ } else {
+ use.refLevel = if ( .refLevel < 0) M+1 else .refLevel
+ c(w) * (y[, -use.refLevel] - mu[, -use.refLevel])
+ }
+ }), list( .refLevel = refLevel ))),
+ weight = eval(substitute(expression({
+ mytiny = (mu < sqrt(.Machine$double.eps)) |
+ (mu > 1.0 - sqrt(.Machine$double.eps))
- use.refLevel = if ( .refLevel < 0) M+1 else .refLevel
+ use.refLevel = if ( .refLevel < 0) M+1 else .refLevel
- if (M == 1) {
- wz = mu[, 3-use.refLevel] * (1-mu[, 3-use.refLevel])
- } else {
- 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)
- index$col.index[myinc] = index$col.index[myinc] + 1
-
- wz = -mu[,index$row] * mu[,index$col]
- wz[, 1:M] = wz[, 1:M] + mu[, -use.refLevel ]
- }
+ if (M == 1) {
+ wz = mu[, 3-use.refLevel] * (1-mu[, 3-use.refLevel])
+ } else {
+ 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)
+ index$col.index[myinc] = index$col.index[myinc] + 1
+
+ wz = -mu[,index$row] * mu[,index$col]
+ wz[, 1:M] = wz[, 1:M] + mu[, -use.refLevel ]
+ }
- atiny = (mytiny %*% rep(1, ncol(mu))) > 0 # apply(mytiny, 1, any)
- if (any(atiny)) {
- if (M == 1) wz[atiny] = wz[atiny] *
- (1 + .Machine$double.eps^0.5) +
- .Machine$double.eps else
- wz[atiny,1:M] = wz[atiny,1:M] * (1 + .Machine$double.eps^0.5) +
- .Machine$double.eps
- }
- c(w) * wz
- }), list( .refLevel = refLevel ))))
+ atiny = (mytiny %*% rep(1, ncol(mu))) > 0 # apply(mytiny, 1, any)
+ if (any(atiny)) {
+ if (M == 1) wz[atiny] = wz[atiny] *
+ (1 + .Machine$double.eps^0.5) +
+ .Machine$double.eps else
+ wz[atiny, 1:M] = wz[atiny, 1:M] * (1 + .Machine$double.eps^0.5) +
+ .Machine$double.eps
+ }
+ c(w) * wz
+ }), list( .refLevel = refLevel ))))
}
+
+
cumulative = function(link = "logit", earg = list(),
parallel = FALSE, reverse = FALSE,
mv = FALSE,
- intercept.apply = FALSE)
+ intercept.apply = FALSE,
+ whitespace = FALSE)
{
- if (mode(link) != "character" && mode(link) != "name")
- link = as.character(substitute(link))
- if (!is.logical(mv) || length(mv) != 1)
- stop("argument 'mv' must be a single logical")
- if (!is.list(earg)) earg = list()
- if (!is.logical(reverse) || length(reverse) != 1)
- stop("argument 'reverse' must be a single logical")
-
- new("vglmff",
- blurb=if ( mv ) c(paste("Multivariate cumulative", link, "model\n\n"),
- "Links: ",
- namesof(if (reverse) "P[Y1>=j+1]" else "P[Y1<=j]",
- link, earg = earg),
- ", ...") else
- c(paste("Cumulative", link, "model\n\n"),
- "Links: ",
- namesof(if (reverse) "P[Y>=j+1]" else "P[Y<=j]",
- link, earg = earg)),
- constraints = eval(substitute(expression({
- if ( .mv ) {
- if ( !length(constraints) ) {
- Llevels = extra$Llevels
- NOS = extra$NOS
- Hk.matrix = kronecker(diag(NOS), matrix(1,Llevels-1,1))
- constraints = cm.vgam(Hk.matrix, x, .parallel, constraints,
- intercept.apply = .intercept.apply)
- }
- } else {
- constraints = cm.vgam(matrix(1,M,1), x, .parallel, constraints,
- intercept.apply = .intercept.apply)
+ if (mode(link) != "character" && mode(link) != "name")
+ link = as.character(substitute(link))
+
+ stopifnot(is.logical(whitespace) &&
+ length(whitespace) == 1)
+ fillerChar <- ifelse(whitespace, " ", "")
+
+
+ if (!is.logical(mv) || length(mv) != 1)
+ stop("argument 'mv' must be a single logical")
+ if (!is.list(earg))
+ earg = list()
+ if (!is.logical(reverse) || length(reverse) != 1)
+ stop("argument 'reverse' must be a single logical")
+
+
+ new("vglmff",
+ blurb = if ( mv ) c(paste("Multivariate cumulative", link, "model\n\n"),
+ "Links: ",
+ namesof(if (reverse)
+ ifelse(whitespace, "P[Y1 >= j+1]", "P[Y1>=j+1]") else
+ ifelse(whitespace, "P[Y1 <= j]", "P[Y1<=j]"),
+ link, earg = earg),
+ ", ...") else
+ c(paste("Cumulative", link, "model\n\n"),
+ "Links: ",
+ namesof(if (reverse)
+ ifelse(whitespace, "P[Y >= j+1]", "P[Y>=j+1]") else
+ ifelse(whitespace, "P[Y <= j]", "P[Y<=j]"),
+ link, earg = earg)),
+ constraints = eval(substitute(expression({
+ if ( .mv ) {
+ if ( !length(constraints) ) {
+ Llevels = extra$Llevels
+ NOS = extra$NOS
+ Hk.matrix = kronecker(diag(NOS), matrix(1,Llevels-1,1))
+ constraints = cm.vgam(Hk.matrix, x, .parallel, constraints,
+ intercept.apply = .intercept.apply)
}
- }), list( .parallel = parallel, .mv = mv, .intercept.apply=intercept.apply ))),
- deviance=eval(substitute(
- function(mu, y, w, residuals = FALSE, eta, extra = NULL) {
+ } else {
+ constraints = cm.vgam(matrix(1, M, 1), x, .parallel, constraints,
+ intercept.apply = .intercept.apply)
+ }
+ }), list( .parallel = parallel, .mv = mv,
+ .intercept.apply = intercept.apply ))),
+ deviance = eval(substitute(
+ function(mu, y, w, residuals = FALSE, eta, extra = NULL) {
+
+ answer =
+ if ( .mv ) {
+ totdev = 0
+ NOS = extra$NOS
+ Llevels = extra$Llevels
+ 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(
+ mu = mu[, aindex, drop = FALSE],
+ y = y[, aindex, drop = FALSE], w = w,
+ residuals = residuals,
+ eta = eta[, cindex, drop = FALSE],
+ extra = extra)
+ }
+ totdev
+ } else {
+ Deviance.categorical.data.vgam(mu = mu, y = y, w = w,
+ residuals = residuals,
+ eta = eta, extra = extra)
+ }
+ answer
+ }, list( .earg = earg, .link = link, .mv = mv ) )),
- answer =
- if ( .mv ) {
- totdev = 0
- NOS = extra$NOS
- Llevels = extra$Llevels
- 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(
- mu=mu[,aindex, drop = FALSE],
- y=y[,aindex, drop = FALSE], w=w, residuals=residuals,
- eta=eta[,cindex, drop = FALSE], extra=extra)
- }
- totdev
- } else {
- Deviance.categorical.data.vgam(mu=mu, y=y, w=w, residuals=residuals,
- eta=eta, extra=extra)
- }
- answer
- }, list( .earg = earg, .link = link, .mv = mv ) )),
- initialize = eval(substitute(expression({
+ initialize = eval(substitute(expression({
if (colnames(x)[1] != "(Intercept)")
stop("there is no intercept term!")
extra$mv = .mv
if ( .mv ) {
- checkCut(y) # Check the input; stops if there is an error.
- if (any(w != 1) || ncol(cbind(w)) != 1)
- stop("the 'weights' argument must be a vector of all ones")
- Llevels = max(y)
- delete.zero.colns = FALSE
- 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) {
- y = as.factor(orig.y[,iii])
- eval(process.categorical.data.vgam)
- use.y = cbind(use.y, y)
- use.mustart = cbind(use.mustart, mustart)
- }
- mustart = use.mustart
- 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 = "")
- 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 = ""))
- }
- 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
- eval(process.categorical.data.vgam)
- M = ncol(y)-1
- mynames = if ( .reverse )
- paste("P[Y> = ", 2:(1+M), "]", sep = "") else
- paste("P[Y< = ", 1:M, "]", sep = "")
- predictors.names =
- namesof(mynames, .link, short = TRUE, earg = .earg)
- 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))
- mustart[,iii] = weighted.mean(y[,iii], w)
- }
+ checkCut(y) # Check the input; stops if there is an error.
+ if (any(w != 1) || ncol(cbind(w)) != 1)
+ stop("the 'weights' argument must be a vector of all ones")
+ Llevels = max(y)
+ delete.zero.colns = FALSE
+ 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) {
+ y = as.factor(orig.y[,iii])
+ eval(process.categorical.data.vgam)
+ use.y = cbind(use.y, y)
+ use.mustart = cbind(use.mustart, mustart)
+ }
+ mustart = use.mustart
+ 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 = "")
+ 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 = ""))
+ }
+ predictors.names =
+ namesof(mynames, .link , short = TRUE, earg = .earg)
+ extra$NOS = NOS
+ extra$Llevels = Llevels
+ } else {
+
+ delete.zero.colns = TRUE
+
+ eval(process.categorical.data.vgam)
+ M = ncol(y)-1
+ mynames = if ( .reverse )
+ paste("P[Y", .fillerChar , ">=", .fillerChar,
+ 2:(1+M), "]", sep = "") else
+ paste("P[Y", .fillerChar , "<=", .fillerChar,
+ 1:M, "]", sep = "")
+ predictors.names =
+ namesof(mynames, .link , short = TRUE, earg = .earg)
+ 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))
+ mustart[,iii] = weighted.mean(y[,iii], w)
+ }
+
+ if (length(dimnames(y)))
+ extra$dimnamesy2 = dimnames(y)[[2]]
+ }
+ }), list( .link = link, .reverse = reverse, .mv = mv, .earg = earg,
+ .fillerChar = fillerChar,
+ .whitespace = whitespace ))),
+
- if (length(dimnames(y)))
- extra$dimnamesy2 = dimnames(y)[[2]]
- }
- }), list( .link = link, .reverse = reverse, .mv = mv, .earg = earg ))),
linkinv = eval(substitute( function(eta, extra = NULL) {
answer =
if ( .mv ) {
@@ -737,13 +888,17 @@ vglm.vcategorical.control = function(maxit=30, trace = FALSE, panic = TRUE, ...)
cindex = (iii-1)*(Llevels-1) + 1:(Llevels-1)
aindex = (iii-1)*(Llevels) + 1:(Llevels)
if ( .reverse ) {
- ccump = cbind(1,eta2theta(eta[,cindex, drop = FALSE], .link,
- earg= .earg))
- fv.matrix[,aindex] =
- cbind(-tapplymat1(ccump, "diff"), ccump[,ncol(ccump)])
+ ccump = cbind(1,
+ eta2theta(eta[, cindex, drop = FALSE],
+ .link , earg = .earg ))
+ fv.matrix[,aindex] =
+ cbind(-tapplymat1(ccump, "diff"),
+ ccump[,ncol(ccump)])
} else {
- cump = cbind(eta2theta(eta[,cindex, drop = FALSE], .link,
- earg= .earg), 1)
+ cump = cbind(eta2theta(eta[, cindex, drop = FALSE],
+ .link ,
+ earg = .earg),
+ 1)
fv.matrix[,aindex] =
cbind(cump[, 1], tapplymat1(cump, "diff"))
}
@@ -752,36 +907,45 @@ vglm.vcategorical.control = function(maxit=30, trace = FALSE, panic = TRUE, ...)
} else {
fv.matrix =
if ( .reverse ) {
- ccump = cbind(1, eta2theta(eta, .link, earg = .earg))
+ ccump = cbind(1, eta2theta(eta, .link , earg = .earg))
cbind(-tapplymat1(ccump, "diff"), ccump[,ncol(ccump)])
} else {
- cump = cbind(eta2theta(eta, .link, earg = .earg), 1)
+ cump = cbind(eta2theta(eta, .link , earg = .earg), 1)
cbind(cump[, 1], tapplymat1(cump, "diff"))
}
if (length(extra$dimnamesy2))
- dimnames(fv.matrix) = list(dimnames(eta)[[1]], extra$dimnamesy2)
+ dimnames(fv.matrix) = list(dimnames(eta)[[1]],
+ extra$dimnamesy2)
fv.matrix
}
answer
- }, list( .link = link, .reverse = reverse, .earg = earg, .mv = mv ))),
- last = eval(substitute(expression({
- if ( .mv ) {
- misc$link = .link
- misc$earg = list( .earg )
- } else {
- misc$link = rep( .link, length=M)
- names(misc$link) = mynames
- misc$earg = vector("list", M)
- names(misc$earg) = names(misc$link)
- for (ii in 1:M) misc$earg[[ii]] = .earg
- }
+ }, list( .link = link, .reverse = reverse,
+ .earg = earg, .mv = mv ))),
+
+ last = eval(substitute(expression({
+ if ( .mv ) {
+ misc$link = .link
+ misc$earg = list( .earg )
+ } else {
+ misc$link = rep( .link , length = M)
+ names(misc$link) = mynames
+ misc$earg = vector("list", M)
+ names(misc$earg) = names(misc$link)
+ for (ii in 1:M) misc$earg[[ii]] = .earg
+ }
+
+ misc$fillerChar = .fillerChar
+ misc$whitespace = .whitespace
+
+ misc$parameters = mynames
+ misc$reverse = .reverse
+ misc$parallel = .parallel
+ misc$mv = .mv
+ }), list( .link = link, .reverse = reverse, .parallel = parallel,
+ .mv = mv, .earg = earg,
+ .fillerChar = fillerChar,
+ .whitespace = whitespace ))),
- misc$parameters = mynames
- misc$reverse = .reverse
- misc$parallel = .parallel
- misc$mv = .mv
- }), list( .link = link, .reverse = reverse, .parallel = parallel,
- .mv = mv, .earg = earg ))),
linkfun = eval(substitute( function(mu, extra = NULL) {
answer =
if ( .mv ) {
@@ -794,18 +958,20 @@ vglm.vcategorical.control = function(maxit=30, trace = FALSE, panic = TRUE, ...)
cump = tapplymat1(as.matrix(mu[,aindex]), "cumsum")
eta.matrix[,cindex] =
theta2eta(if ( .reverse) 1-cump[, 1:(Llevels-1)] else
- cump[, 1:(Llevels-1)], .link, earg = .earg)
+ cump[, 1:(Llevels-1)], .link , earg = .earg)
}
eta.matrix
} else {
cump = tapplymat1(as.matrix(mu), "cumsum")
M = ncol(as.matrix(mu)) - 1
- theta2eta(if ( .reverse ) 1-cump[, 1:M] else cump[, 1:M], .link,
- earg= .earg)
+ theta2eta(if ( .reverse ) 1-cump[, 1:M] else cump[, 1:M],
+ .link ,
+ earg = .earg)
}
answer
}, list( .link = link, .reverse = reverse, .earg = earg, .mv = mv ))),
- loglikelihood = function(mu, y, w, residuals = FALSE, eta, extra = NULL)
+ loglikelihood =
+ function(mu, y, w, residuals = FALSE, eta, extra = NULL)
if (residuals) stop("loglikelihood residuals ",
"not implemented yet") else {
ycounts = if (is.numeric(extra$orig.w)) y * w / extra$orig.w else
@@ -822,207 +988,240 @@ vglm.vcategorical.control = function(maxit=30, trace = FALSE, panic = TRUE, ...)
dmultinomial(x = ycounts, size = nvec, prob = mu,
log = TRUE, dochecking = FALSE))
},
- vfamily = c("cumulative", "vcategorical"),
- deriv = eval(substitute(expression({
- mu.use = pmax(mu, .Machine$double.eps * 1.0e-0)
- deriv.answer =
- if ( .mv ) {
- NOS = extra$NOS
- Llevels = extra$Llevels
- dcump.deta = resmat = matrix(0, n, NOS * (Llevels-1))
- 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)
- dcump.deta[,cindex] = dtheta.deta(cump, .link, earg = .earg)
- resmat[,cindex] =
- (y[,aindex, drop = FALSE]/mu.use[,aindex, drop = FALSE] -
- y[, 1+aindex, drop = FALSE]/mu.use[, 1+aindex, drop = FALSE])
- }
- (if ( .reverse) -c(w) else c(w)) * dcump.deta * resmat
- } else {
- cump = eta2theta(eta, .link, earg = .earg)
- dcump.deta = dtheta.deta(cump, .link, earg = .earg)
- c(if ( .reverse) -c(w) else c(w)) * dcump.deta *
- (y[,-(M+1)]/mu.use[,-(M+1)] - y[,-1]/mu.use[,-1])
+ vfamily = c("cumulative", "vcategorical"),
+ deriv = eval(substitute(expression({
+ mu.use = pmax(mu, .Machine$double.eps * 1.0e-0)
+ deriv.answer =
+ if ( .mv ) {
+ NOS = extra$NOS
+ Llevels = extra$Llevels
+ dcump.deta = resmat = matrix(0, n, NOS * (Llevels-1))
+ 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)
+ dcump.deta[,cindex] = dtheta.deta(cump, .link , earg = .earg)
+ resmat[,cindex] =
+ (y[,aindex, drop = FALSE] / mu.use[,aindex, drop = FALSE] -
+ y[, 1+aindex, drop = FALSE]/mu.use[, 1+aindex, drop = FALSE])
+ }
+ (if ( .reverse) -c(w) else c(w)) * dcump.deta * resmat
+ } else {
+ cump = eta2theta(eta, .link , earg = .earg)
+ dcump.deta = dtheta.deta(cump, .link , earg = .earg)
+ c(if ( .reverse) -c(w) else c(w)) * dcump.deta *
+ (y[, -(M+1)]/mu.use[, -(M+1)] - y[, -1] / mu.use[, -1])
+ }
+ deriv.answer
+ }), list( .link = link, .reverse = reverse,
+ .earg = earg, .mv = mv ))),
+ weight = eval(substitute(expression({
+ if ( .mv ) {
+ NOS = extra$NOS
+ Llevels = extra$Llevels
+ wz = matrix(0, n, NOS*(Llevels-1)) # Diagonal elts only for a start
+ 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 *
+ (1 / mu.use[, aindex, drop = FALSE] +
+ 1 / mu.use[, 1+aindex, drop = FALSE])
+ }
+ if (Llevels-1 > 1) {
+ iii = 1
+ oindex = (iii-1) * (Llevels-1) + 1:(Llevels-2)
+ wz = cbind(wz, -c(w) *
+ dcump.deta[, oindex] * dcump.deta[, 1+oindex])
+
+
+ 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) {
+ oindex = (iii-1)*(Llevels-1) + 1:(Llevels-2)
+ wz[,cptrwz + 1 + (1:(Llevels-2))] =
+ -c(w) * dcump.deta[,oindex] *
+ dcump.deta[, 1+oindex]
+ cptrwz = cptrwz + Llevels - 1 # Move it along a bit
+ }
}
- deriv.answer
- }), list( .link = link, .reverse = reverse, .earg = earg, .mv = mv ))),
- weight = eval(substitute(expression({
- if ( .mv ) {
- NOS = extra$NOS
- Llevels = extra$Llevels
- wz = matrix(0, n, NOS*(Llevels-1)) # Diagonal elts only for a start
- 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 *
- (1 / mu.use[, aindex, drop = FALSE] +
- 1 / mu.use[, 1+aindex, drop = FALSE])
- }
- if (Llevels-1 > 1) {
- iii = 1
- oindex = (iii-1) * (Llevels-1) + 1:(Llevels-2)
- wz = cbind(wz, -c(w) *
- dcump.deta[, oindex] * dcump.deta[, 1+oindex])
-
-
- 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) {
- oindex = (iii-1)*(Llevels-1) + 1:(Llevels-2)
- wz[,cptrwz + 1 + (1:(Llevels-2))] =
- -c(w) * dcump.deta[,oindex] *
- dcump.deta[, 1+oindex]
- cptrwz = cptrwz + Llevels - 1 # Move it along a bit
- }
- }
- }
- } else {
- wz = c(w) * dcump.deta^2 * (1/mu.use[, 1:M] + 1/mu.use[,-1])
- if (M > 1)
- wz = cbind(wz, -c(w) * dcump.deta[,-M] *
- dcump.deta[, 2:M] / mu.use[, 2:M])
}
- wz
- }), list( .earg = earg, .link = link, .mv = mv ))))
+ } else {
+ wz = c(w) * dcump.deta^2 * (1/mu.use[, 1:M] + 1/mu.use[, -1])
+ if (M > 1)
+ wz = cbind(wz, -c(w) * dcump.deta[, -M] *
+ dcump.deta[, 2:M] / mu.use[, 2:M])
+ }
+ wz
+ }), list( .earg = earg, .link = link, .mv = mv ))))
}
- propodds = function(reverse = TRUE) {
- if (!is.logical(reverse) || length(reverse) != 1)
- stop("argument 'reverse' must be a single logical")
+ propodds = function(reverse = TRUE, whitespace = FALSE) {
+ if (!is.logical(reverse) || length(reverse) != 1)
+ stop("argument 'reverse' must be a single logical")
- cumulative(parallel = TRUE, reverse = reverse)
+ cumulative(parallel = TRUE, reverse = reverse,
+ whitespace = whitespace)
}
acat = function(link = "loge", earg = list(),
- parallel = FALSE, reverse = FALSE, zero = NULL)
+ parallel = FALSE, reverse = FALSE, zero = NULL,
+ whitespace = FALSE)
{
- if (mode(link) != "character" && mode(link) != "name")
- link = as.character(substitute(link))
- if (!is.list(earg)) earg = list()
- if (!is.logical(reverse) || length(reverse) != 1)
- stop("argument 'reverse' must be a single logical")
-
- new("vglmff",
- blurb = c("Adjacent-categories model\n\n",
- "Links: ",
- namesof(if (reverse) "P[Y=j]/P[Y=j+1]" else "P[Y=j+1]/P[Y=j]",
- link, earg = earg),
- "\n",
- "Variance: mu[,j]*(1-mu[,j]); -mu[,j]*mu[,k]"),
- 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 = Deviance.categorical.data.vgam,
- initialize = eval(substitute(expression({
- delete.zero.colns = 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 = "")
-
- predictors.names = namesof(mynames, .link, short = TRUE, earg = .earg)
- y.names = paste("mu", 1:(M+1), sep = "")
- if (length(dimnames(y)))
- extra$dimnamesy2 = dimnames(y)[[2]]
- }), list( .earg = earg, .link = link, .reverse = reverse ))),
- linkinv = eval(substitute( function(eta, extra = NULL) {
- if (!is.matrix(eta))
- eta = as.matrix(eta)
- M = ncol(eta)
- fv.matrix = if ( .reverse ) {
- zetar = eta2theta(eta, .link, earg = .earg )
- temp = tapplymat1(zetar[,M:1], "cumprod")[,M:1, drop = FALSE]
- cbind(temp,1) / drop(1 + temp %*% rep(1,ncol(temp)))
- } else {
- zeta = eta2theta(eta, .link, earg = .earg )
- temp = tapplymat1(zeta, "cumprod")
- cbind(1,temp) / drop(1 + temp %*% rep(1,ncol(temp)))
- }
- if (length(extra$dimnamesy2))
- dimnames(fv.matrix) = list(dimnames(eta)[[1]], extra$dimnamesy2)
- fv.matrix
- }, list( .earg = earg, .link = link, .reverse = reverse) )),
- last = eval(substitute(expression({
- misc$link = rep( .link, length = M)
- names(misc$link) = mynames
-
- misc$earg = vector("list", M)
- names(misc$earg) = names(misc$link)
- for (ii in 1:M) misc$earg[[ii]] = .earg
-
- misc$parameters = mynames
- misc$reverse = .reverse
- }), list( .earg = earg, .link = link, .reverse = reverse ))),
- 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 )
- }, list( .earg = earg, .link = link, .reverse = reverse) )),
- loglikelihood = function(mu, y, w, residuals = FALSE, eta, extra = NULL)
- 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
- nvec = if (is.numeric(extra$orig.w)) round(w / extra$orig.w) else
- round(w)
-
- smallno = 1.0e4 * .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) *
- dmultinomial(x = ycounts, size = nvec, prob = mu,
- log = TRUE, dochecking = FALSE))
- },
- vfamily = c("acat", "vcategorical"),
- deriv = eval(substitute(expression({
- zeta = eta2theta(eta, .link, earg = .earg ) # May be zetar
- d1 = acat.deriv(zeta, M=M, n=n, reverse=.reverse)
- score = attr(d1, "gradient") / d1
- dzeta.deta = dtheta.deta(zeta, .link, earg = .earg )
- if ( .reverse ) {
- cumy = tapplymat1(y, "cumsum")
- c(w) * dzeta.deta * (cumy[, 1:M] / zeta - score)
- } else {
- ccumy = tapplymat1(y[,ncol(y):1], "cumsum")[,ncol(y):1]
- c(w) * dzeta.deta * (ccumy[,-1] / zeta - score)
- }
- }), list( .earg = earg, .link = link, .reverse = reverse) )),
- weight = eval(substitute(expression({
- wz = matrix(as.numeric(NA), n, dimm(M))
-
- hess = attr(d1, "hessian") / d1
-
- if (M > 1)
- 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 ) {
- cump = tapplymat1(mu, "cumsum")
- wz[, 1:M] = (cump[, 1:M] / zeta^2 - score^2) * dzeta.deta^2
- } else {
- ccump = tapplymat1(mu[,ncol(mu):1], "cumsum")[, ncol(mu):1]
- wz[, 1:M] = (ccump[,-1] / zeta^2 - score^2) * dzeta.deta^2
- }
- c(w) * wz
- }), list( .earg = earg, .link = link, .reverse = reverse ))))
+ if (mode(link) != "character" && mode(link) != "name")
+ link = as.character(substitute(link))
+ if (!is.list(earg))
+ earg = list()
+ if (!is.logical(reverse) || length(reverse) != 1)
+ stop("argument 'reverse' must be a single logical")
+
+ stopifnot(is.logical(whitespace) &&
+ length(whitespace) == 1)
+ fillerChar <- ifelse(whitespace, " ", "")
+
+
+ new("vglmff",
+ blurb = c("Adjacent-categories model\n\n",
+ "Links: ",
+ namesof(if (reverse)
+ ifelse(whitespace, "P[Y = j] / P[Y = j + 1]", "P[Y=j]/P[Y=j+1]") else
+ ifelse(whitespace, "P[Y = j + 1] / P[Y = j]", "P[Y=j+1]/P[Y=j]"),
+ link, earg = earg),
+ "\n",
+ "Variance: ",
+ ifelse(whitespace,
+ "mu[,j] * (1 - mu[,j]); -mu[,j] * mu[,k]",
+ "mu[,j]*(1-mu[,j]); -mu[,j]*mu[,k]")),
+ 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 = Deviance.categorical.data.vgam,
+
+ initialize = eval(substitute(expression({
+ delete.zero.colns = TRUE
+ eval(process.categorical.data.vgam)
+ M = ncol(y) - 1
+ mynames = if ( .reverse )
+ paste("P[Y", .fillerChar , "=",
+ 1:M, "]", .fillerChar , "/", .fillerChar ,
+ "P[Y", .fillerChar , "=", .fillerChar , 2:(M+1), "]",
+ sep = "") else
+ paste("P[Y", .fillerChar , "=", .fillerChar , 2:(M+1), "]",
+ .fillerChar , "/", .fillerChar , "P[Y", .fillerChar ,
+ "=", .fillerChar , 1:M, "]", sep = "")
+
+ predictors.names =
+ namesof(mynames, .link , short = TRUE, earg = .earg)
+ y.names = paste("mu", 1:(M+1), sep = "")
+
+ if (length(dimnames(y)))
+ extra$dimnamesy2 = dimnames(y)[[2]]
+ }), list( .earg = earg, .link = link, .reverse = reverse,
+ .fillerChar = fillerChar,
+ .whitespace = whitespace ))),
+
+ linkinv = eval(substitute( function(eta, extra = NULL) {
+ if (!is.matrix(eta))
+ eta = as.matrix(eta)
+ M = ncol(eta)
+ fv.matrix = if ( .reverse ) {
+ zetar = eta2theta(eta, .link , earg = .earg )
+ temp = tapplymat1(zetar[, M:1], "cumprod")[, M:1, drop = FALSE]
+ cbind(temp, 1) / drop(1 + temp %*% rep(1, ncol(temp)))
+ } else {
+ zeta = eta2theta(eta, .link , earg = .earg )
+ temp = tapplymat1(zeta, "cumprod")
+ cbind(1, temp) / drop(1 + temp %*% rep(1, ncol(temp)))
+ }
+ if (length(extra$dimnamesy2))
+ dimnames(fv.matrix) = list(dimnames(eta)[[1]],
+ extra$dimnamesy2)
+ fv.matrix
+ }, list( .earg = earg, .link = link, .reverse = reverse) )),
+
+ last = eval(substitute(expression({
+ misc$link = rep( .link , length = M)
+ names(misc$link) = mynames
+
+ misc$earg = vector("list", M)
+ names(misc$earg) = names(misc$link)
+ for (ii in 1:M) misc$earg[[ii]] = .earg
+
+ misc$parameters = mynames
+ misc$reverse = .reverse
+ misc$fillerChar = .fillerChar
+ misc$whitespace = .whitespace
+ }), list( .earg = earg, .link = link, .reverse = reverse,
+ .fillerChar = fillerChar,
+ .whitespace = whitespace ))),
+ 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 )
+ }, list( .earg = earg, .link = link, .reverse = reverse) )),
+ loglikelihood =
+ function(mu, y, w, residuals = FALSE, eta, extra = NULL)
+ 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
+ nvec = if (is.numeric(extra$orig.w)) round(w / extra$orig.w) else
+ round(w)
+
+ smallno = 1.0e4 * .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) *
+ dmultinomial(x = ycounts, size = nvec, prob = mu,
+ log = TRUE, dochecking = FALSE))
+ },
+ vfamily = c("acat", "vcategorical"),
+ deriv = eval(substitute(expression({
+ zeta = eta2theta(eta, .link , earg = .earg ) # May be zetar
+ d1 = acat.deriv(zeta, M = M, n = n, reverse=.reverse)
+ score = attr(d1, "gradient") / d1
+ dzeta.deta = dtheta.deta(zeta, .link , earg = .earg )
+ if ( .reverse ) {
+ cumy = tapplymat1(y, "cumsum")
+ c(w) * dzeta.deta * (cumy[, 1:M] / zeta - score)
+ } else {
+ ccumy = tapplymat1(y[,ncol(y):1], "cumsum")[,ncol(y):1]
+ c(w) * dzeta.deta * (ccumy[, -1] / zeta - score)
+ }
+ }), list( .earg = earg, .link = link, .reverse = reverse) )),
+ weight = eval(substitute(expression({
+ wz = matrix(as.numeric(NA), n, dimm(M))
+
+ hess = attr(d1, "hessian") / d1
+
+ if (M > 1)
+ 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 ) {
+ cump = tapplymat1(mu, "cumsum")
+ wz[, 1:M] = (cump[, 1:M] / zeta^2 - score^2) * dzeta.deta^2
+ } else {
+ ccump = tapplymat1(mu[,ncol(mu):1], "cumsum")[, ncol(mu):1]
+ wz[, 1:M] = (ccump[, -1] / zeta^2 - score^2) * dzeta.deta^2
+ }
+ c(w) * wz
+ }), list( .earg = earg, .link = link, .reverse = reverse ))))
}
@@ -1041,11 +1240,11 @@ acat.deriv = function(zeta, reverse, M, n)
txt = as.formula(alltxt)
allvars = paste("zeta", 1:M, sep = "")
- d1 = deriv3(txt, allvars, hessian = TRUE) # deriv3() computes the Hessian
+ d1 = deriv3(txt, allvars, hessian = TRUE)
zeta = as.matrix(zeta)
for (ii in 1:M)
- assign(paste("zeta", ii, sep = ""), zeta[,ii])
+ assign(paste("zeta", ii, sep = ""), zeta[, ii])
ans = eval(d1)
ans
@@ -1058,284 +1257,303 @@ acat.deriv = function(zeta, reverse, M, n)
refvalue = 1,
init.alpha = 1)
{
- if (!is.Numeric(init.alpha, positive = TRUE))
- stop("'init.alpha' must contain positive values only")
- if (!is.Numeric(refvalue, allowable.length = 1, positive = TRUE))
- stop("'refvalue' must be a single positive value")
- if (!is.character(refgp) &&
- !is.Numeric(refgp, allowable.length = 1, integer.valued = TRUE, positive = TRUE))
- stop("'refgp' must be a single positive integer")
+ if (!is.Numeric(init.alpha, positive = TRUE))
+ stop("'init.alpha' must contain positive values only")
+ if (!is.Numeric(refvalue, allowable.length = 1, positive = TRUE))
+ stop("'refvalue' must be a single positive value")
+ if (!is.character(refgp) &&
+ !is.Numeric(refgp, allowable.length = 1,
+ integer.valued = TRUE, positive = TRUE))
+ stop("'refgp' must be a single positive integer")
- new("vglmff",
- blurb = c(paste("Bradley-Terry model (without ties)\n\n"),
- "Links: ",
- namesof("alpha's", "loge")),
- initialize = eval(substitute(expression({
- are.ties = attr(y, "are.ties") # If Brat() was used
- if (is.logical(are.ties) && are.ties)
- stop("use bratt(), not brat(), when there are ties")
-
- 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)
- 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)
- }), list( .refgp = refgp, .init.alpha=init.alpha ))),
- linkinv = eval(substitute( function(eta, extra = NULL) {
- probs = NULL
- eta = as.matrix(eta) # in case M=1
- for (ii in 1:nrow(eta)) {
- alpha = .brat.alpha(eta2theta(eta[ii,], "loge", earg = list()),
- .refvalue, .refgp)
- alpha1 = alpha[extra$ybrat.indices[,"rindex"]]
- alpha2 = alpha[extra$ybrat.indices[,"cindex"]]
- probs = rbind(probs, alpha1/(alpha1+alpha2))
- }
- dimnames(probs) = dimnames(eta)
- probs
- }, list( .refgp = refgp, .refvalue = refvalue) )),
- last = eval(substitute(expression({
- misc$link = rep( "loge", length=M)
- names(misc$link) = paste("alpha",uindex,sep = "")
- misc$refgp = .refgp
- misc$refvalue = .refvalue
- }), list( .refgp = refgp, .refvalue = refvalue ))),
- loglikelihood = function(mu, y, w, residuals = FALSE, eta, extra = NULL)
- 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
- nvec = if (is.numeric(extra$orig.w)) round(w / extra$orig.w) else
- round(w)
- smallno = 1.0e4 * .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) *
- dmultinomial(x = ycounts, size = nvec, prob = mu,
- log = TRUE, dochecking = FALSE))
- },
- vfamily = c("brat"),
- deriv = eval(substitute(expression({
- 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)) {
- 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)) {
- answer = answer + (1-(aa==uindex)) *
- (ymat[uindex,aa] * alpha[aa] - ymat[aa,uindex] *
- alpha[uindex]) / (alpha[aa] + alpha[uindex])
- }
- ans = rbind(ans, w[ii] * answer)
- }
- dimnames(ans) = dimnames(eta)
- ans
- }), list( .refvalue = refvalue, .refgp = refgp) )),
- weight = eval(substitute(expression({
- wz = matrix(0, n, dimm(M))
- 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)) {
- 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)
- wz[ii,(M+1):ncol(wz)] =
- -(ymat[cbind(uindex[ind5$row],uindex[ind5$col])] +
- ymat[cbind(uindex[ind5$col],uindex[ind5$row])]) *
- alpha[uindex[ind5$col]] * alpha[uindex[ind5$row]] /
- (alpha[uindex[ind5$row]] + alpha[uindex[ind5$col]])^2
- }
- }
- wz = c(w) * wz
- wz
- }), list( .refvalue = refvalue, .refgp = refgp ))))
+ new("vglmff",
+ blurb = c(paste("Bradley-Terry model (without ties)\n\n"),
+ "Links: ",
+ namesof("alpha's", "loge")),
+ initialize = eval(substitute(expression({
+ are.ties = attr(y, "are.ties") # If Brat() was used
+ if (is.logical(are.ties) && are.ties)
+ stop("use bratt(), not brat(), when there are ties")
+
+ 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 , length.out = 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)
+ }), list( .refgp = refgp, .init.alpha=init.alpha ))),
+
+ linkinv = eval(substitute( function(eta, extra = NULL) {
+ probs = NULL
+ eta = as.matrix(eta) # in case M=1
+ for (ii in 1:nrow(eta)) {
+ alpha = .brat.alpha(eta2theta(eta[ii,], "loge", earg = list()),
+ .refvalue , .refgp )
+ alpha1 = alpha[extra$ybrat.indices[, "rindex"]]
+ alpha2 = alpha[extra$ybrat.indices[, "cindex"]]
+ probs = rbind(probs, alpha1 / (alpha1 + alpha2))
+ }
+ dimnames(probs) = dimnames(eta)
+ probs
+ }, list( .refgp = refgp, .refvalue = refvalue) )),
+
+ last = eval(substitute(expression({
+ misc$link = rep( "loge", length = M)
+ names(misc$link) = paste("alpha", uindex, sep = "")
+ misc$refgp = .refgp
+ misc$refvalue = .refvalue
+ }), list( .refgp = refgp, .refvalue = refvalue ))),
+
+ loglikelihood =
+ function(mu, y, w, residuals = FALSE, eta, extra = NULL)
+ 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
+ nvec = if (is.numeric(extra$orig.w)) round(w / extra$orig.w) else
+ round(w)
+
+ smallno = 1.0e4 * .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) *
+ dmultinomial(x = ycounts, size = nvec, prob = mu,
+ log = TRUE, dochecking = FALSE))
+ },
+ vfamily = c("brat"),
+ deriv = eval(substitute(expression({
+ 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)) {
+ 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)) {
+ answer = answer + (1 - (aa == uindex)) *
+ (ymat[uindex,aa] * alpha[aa] - ymat[aa,uindex] *
+ alpha[uindex]) / (alpha[aa] + alpha[uindex])
+ }
+ ans = rbind(ans, w[ii] * answer)
+ }
+ dimnames(ans) = dimnames(eta)
+ ans
+ }), list( .refvalue = refvalue, .refgp = refgp) )),
+ weight = eval(substitute(expression({
+ wz = matrix(0, n, dimm(M))
+ 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)) {
+ 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)
+ wz[ii,(M+1):ncol(wz)] =
+ -(ymat[cbind(uindex[ind5$row],uindex[ind5$col])] +
+ ymat[cbind(uindex[ind5$col],uindex[ind5$row])]) *
+ alpha[uindex[ind5$col]] * alpha[uindex[ind5$row]] /
+ (alpha[uindex[ind5$row]] + alpha[uindex[ind5$col]])^2
+ }
+ }
+ wz = c(w) * wz
+ wz
+ }), list( .refvalue = refvalue, .refgp = refgp ))))
}
-bratt = function(refgp = "last",
+ bratt = function(refgp = "last",
refvalue = 1,
init.alpha = 1,
i0 = 0.01)
{
- if (!is.Numeric(i0, allowable.length = 1, positive = TRUE))
- stop("'i0' must be a single positive value")
- if (!is.Numeric(init.alpha, positive = TRUE))
- stop("'init.alpha' must contain positive values only")
- if (!is.Numeric(refvalue, allowable.length = 1, positive = TRUE))
- stop("'refvalue' must be a single positive value")
- if (!is.character(refgp) &&
- !is.Numeric(refgp, allowable.length = 1,
- integer.valued = TRUE, positive = TRUE))
+ if (!is.Numeric(i0, allowable.length = 1, positive = TRUE))
+ stop("'i0' must be a single positive value")
+ if (!is.Numeric(init.alpha, positive = TRUE))
+ stop("'init.alpha' must contain positive values only")
+ if (!is.Numeric(refvalue, allowable.length = 1, positive = TRUE))
+ stop("'refvalue' must be a single positive value")
+ if (!is.character(refgp) &&
+ !is.Numeric(refgp, allowable.length = 1,
+ integer.valued = TRUE, positive = TRUE))
stop("'refgp' must be a single positive integer")
- new("vglmff",
- blurb = c(paste("Bradley-Terry model (with ties)\n\n"),
- "Links: ",
- namesof("alpha's", "loge"), ", log(alpha0)"),
- initialize = eval(substitute(expression({
- try.index = 1:400
- M = (1:length(try.index))[(try.index*(try.index-1)) == ncol(y)]
- if (!is.Numeric(M, allowable.length = 1, integer.valued = TRUE))
- stop("cannot determine 'M'")
- NCo = M # number of contestants
-
- are.ties = attr(y, "are.ties") # If Brat() was used
- if (is.logical(are.ties)) {
- if (!are.ties)
- stop("use brat(), not bratt(), when there are no ties")
- ties = attr(y, "ties")
- } else {
- are.ties = FALSE
- ties = 0 * y
- }
+ new("vglmff",
+ blurb = c(paste("Bradley-Terry model (with ties)\n\n"),
+ "Links: ",
+ namesof("alpha's", "loge"), ", log(alpha0)"),
+ initialize = eval(substitute(expression({
+ try.index = 1:400
+ M = (1:length(try.index))[(try.index*(try.index-1)) == ncol(y)]
+ if (!is.Numeric(M, allowable.length = 1, integer.valued = TRUE))
+ stop("cannot determine 'M'")
+ NCo = M # number of contestants
+
+ are.ties = attr(y, "are.ties") # If Brat() was used
+ if (is.logical(are.ties)) {
+ if (!are.ties)
+ stop("use brat(), not bratt(), when there are no ties")
+ ties = attr(y, "ties")
+ } else {
+ are.ties = FALSE
+ ties = 0 * y
+ }
- init.alpha = rep( .init.alpha, len=NCo-1)
- ialpha0 = .i0
- etastart = cbind(matrix(theta2eta(init.alpha, "loge"),
- 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$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("alpha0", "loge", short = TRUE))
- }), list( .refgp = refgp,
- .i0 = i0,
- .init.alpha=init.alpha ))),
- linkinv = eval(substitute( function(eta, extra = NULL) {
- probs = qprobs = NULL
- M = ncol(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"]]
- alpha2 = alpha[extra$ybrat.indices[,"cindex"]]
- probs = rbind(probs, alpha1/(alpha1+alpha2+alpha0)) #
- qprobs = rbind(qprobs, alpha0/(alpha1+alpha2+alpha0)) #
- }
- if (length(extra$dnties))
- dimnames(qprobs) = extra$dnties
- attr(probs, "probtie") = qprobs
- probs
- }, list( .refgp = refgp, .refvalue = refvalue) )),
- last = eval(substitute(expression({
- misc$link = rep( "loge", length=M)
- names(misc$link) = c(paste("alpha",uindex,sep = ""), "alpha0")
- misc$refgp = .refgp
- misc$refvalue = .refvalue
- misc$alpha = alpha
- misc$alpha0 = alpha0
- }), list( .refgp = refgp, .refvalue = refvalue ))),
- loglikelihood = function(mu, y, w, residuals = FALSE, eta, extra = NULL)
- if (residuals) stop("loglikelihood residuals not ",
- "implemented yet") else {
- sum(c(w) * (y * log(mu) +
- 0.5 * extra$ties * log(attr(mu, "probtie"))))
- },
- vfamily = c("bratt"),
- deriv = eval(substitute(expression({
- ans = NULL
- ties = extra$ties
- NCo = M
- uindex = if ( .refgp == "last") 1:(M-1) else (1:(M))[-( .refgp )]
- eta = as.matrix(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) {
- Daj = alpha[aa] + alpha[uindex] + alpha0
- pja = alpha[uindex] / Daj
- answer = answer + alpha[uindex] *
- (-ymat[aa,uindex] + ymat[uindex,aa]*(1-pja)/pja -
- tmat[uindex,aa]) / Daj
- }
- deriv0 = 0 # deriv wrt eta[M]
- for (aa in 1:(NCo-1))
- for (bb in (aa+1):NCo) {
- Dab = alpha[aa] + alpha[bb] + alpha0
- qab = alpha0 / Dab
- deriv0 = deriv0 + alpha0 *
- (-ymat[aa,bb] - ymat[bb,aa] +
- tmat[aa,bb]*(1-qab)/qab) / Dab
- }
- ans = rbind(ans, w[ii] * c(answer, deriv0))
- }
- dimnames(ans) = dimnames(eta)
- ans
- }), list( .refvalue = refvalue, .refgp = refgp) )),
- weight = eval(substitute(expression({
- wz = matrix(0, n, dimm(M)) # includes diagonal
- 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)) {
- 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)) {
- nab = ymat[aa,bb] + ymat[bb,aa] + tmat[bb,aa]
- Dab = alpha[aa] + alpha[bb] + alpha0
- qab = alpha0 / Dab
- wz[ii,NCo] = wz[ii,NCo] + alpha0^2 * nab *
- (1-qab) / (qab * Dab^2)
- }
- }
- if (NCo > 2) {
- 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]] +
- tmat[mat4]) * alphajunk[uindex[ind5$col]] *
- alphajunk[uindex[ind5$row]] / (alpha0 +
- alphajunk[uindex[ind5$row]] + alphajunk[uindex[ind5$col]])^2
- }
- 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)] =
- -alpha[jay] * alpha0 * sum(naj / Daj^2)
- }
- }
- wz = c(w) * wz
- wz
- }), list( .refvalue = refvalue, .refgp = refgp ))))
+ init.alpha = rep( .init.alpha, len = NCo-1)
+ ialpha0 = .i0
+ etastart =
+ cbind(matrix(theta2eta(init.alpha, "loge"),
+ n, NCo-1, byrow = TRUE),
+ theta2eta( rep(ialpha0, length.out = 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$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("alpha0", "loge", short = TRUE))
+ }), list( .refgp = refgp,
+ .i0 = i0,
+ .init.alpha=init.alpha ))),
+
+ linkinv = eval(substitute( function(eta, extra = NULL) {
+ probs = qprobs = NULL
+ M = ncol(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"]]
+ alpha2 = alpha[extra$ybrat.indices[, "cindex"]]
+ probs = rbind(probs, alpha1 / (alpha1+alpha2+alpha0)) #
+ qprobs = rbind(qprobs, alpha0 / (alpha1+alpha2+alpha0)) #
+ }
+ if (length(extra$dnties))
+ dimnames(qprobs) = extra$dnties
+ attr(probs, "probtie") = qprobs
+ probs
+ }, list( .refgp = refgp, .refvalue = refvalue) )),
+ last = eval(substitute(expression({
+ misc$link = rep( "loge", length = M)
+ names(misc$link) = c(paste("alpha",uindex, sep = ""), "alpha0")
+ misc$refgp = .refgp
+ misc$refvalue = .refvalue
+ misc$alpha = alpha
+ misc$alpha0 = alpha0
+ }), list( .refgp = refgp, .refvalue = refvalue ))),
+ loglikelihood =
+ function(mu, y, w, residuals = FALSE, eta, extra = NULL)
+ if (residuals) stop("loglikelihood residuals not ",
+ "implemented yet") else {
+ sum(c(w) * (y * log(mu) +
+ 0.5 * extra$ties * log(attr(mu, "probtie"))))
+ },
+ vfamily = c("bratt"),
+ deriv = eval(substitute(expression({
+ ans = NULL
+ ties = extra$ties
+ NCo = M
+ uindex = if ( .refgp == "last") 1:(M-1) else (1:(M))[-( .refgp )]
+ eta = as.matrix(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) {
+ Daj = alpha[aa] + alpha[uindex] + alpha0
+ pja = alpha[uindex] / Daj
+ answer = answer + alpha[uindex] *
+ (-ymat[aa,uindex] + ymat[uindex,aa]*(1-pja)/pja -
+ tmat[uindex,aa]) / Daj
+ }
+ deriv0 = 0 # deriv wrt eta[M]
+ for (aa in 1:(NCo-1))
+ for (bb in (aa+1):NCo) {
+ Dab = alpha[aa] + alpha[bb] + alpha0
+ qab = alpha0 / Dab
+ deriv0 = deriv0 + alpha0 *
+ (-ymat[aa,bb] - ymat[bb,aa] +
+ tmat[aa,bb]*(1-qab)/qab) / Dab
+ }
+ ans = rbind(ans, w[ii] * c(answer, deriv0))
+ }
+ dimnames(ans) = dimnames(eta)
+ ans
+ }), list( .refvalue = refvalue, .refgp = refgp) )),
+ weight = eval(substitute(expression({
+ wz = matrix(0, n, dimm(M)) # includes diagonal
+ 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)) {
+ 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)) {
+ nab = ymat[aa,bb] + ymat[bb,aa] + tmat[bb,aa]
+ Dab = alpha[aa] + alpha[bb] + alpha0
+ qab = alpha0 / Dab
+ wz[ii, NCo] = wz[ii,NCo] + alpha0^2 * nab *
+ (1-qab) / (qab * Dab^2)
+ }
+ }
+
+ if (NCo > 2) {
+ 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]] +
+ tmat[mat4]) * alphajunk[uindex[ind5$col]] *
+ alphajunk[uindex[ind5$row]] / (alpha0 +
+ alphajunk[uindex[ind5$row]] + alphajunk[uindex[ind5$col]])^2
+ }
+ 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)] =
+ -alpha[jay] * alpha0 * sum(naj / Daj^2)
+ }
+ }
+ wz = c(w) * wz
+ wz
+ }), list( .refvalue = refvalue, .refgp = refgp ))))
}
@@ -1349,89 +1567,118 @@ bratt = function(refgp = "last",
.brat.indices = function(NCo, are.ties = FALSE) {
- if (!is.Numeric(NCo, allowable.length = 1, integer.valued = TRUE) || NCo < 2)
+ if (!is.Numeric(NCo, allowable.length = 1,
+ integer.valued = TRUE) ||
+ NCo < 2)
stop("bad input for 'NCo'")
m = diag(NCo)
if (are.ties) {
- cbind(rindex=row(m)[col(m) < row(m)], cindex=col(m)[col(m) < row(m)])
+ cbind(rindex = row(m)[col(m) < row(m)],
+ cindex = col(m)[col(m) < row(m)])
} else
- cbind(rindex=row(m)[col(m) != row(m)], cindex=col(m)[col(m) != row(m)])
+ cbind(rindex = row(m)[col(m) != row(m)],
+ cindex = col(m)[col(m) != row(m)])
}
-Brat = function(mat, ties=0*mat, string=c(" > "," == ")) {
- allargs = list(mat) # ,...
- callit = if (length(names(allargs))) names(allargs) else
- as.character(1:length(allargs))
- ans = ans.ties = NULL
- 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")
-
- diag(ties) = 0
- if (!all(ties == t(ties)))
- stop("ties must be a symmetric matrix")
- are.ties = any(ties > 0)
- diag(ties) = NA
-
- diag(m) = 0 # Could have been NAs
- if (any(is.na(m)))
- stop("missing values not allowed (except on the diagonal)")
- diag(m) = NA
-
- dm = as.data.frame.table(m)
- 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 = "")
- ans = rbind(ans, matrix(dm$Freq, nrow=1))
- ans.ties = rbind(ans.ties, matrix(dt$Freq, nrow=1))
- }
- dimnames(ans) = list(callit, usethis1)
- dimnames(ans.ties) = list(callit, usethis2)
- attr(ans, "ties") = ans.ties
- attr(ans, "are.ties") = are.ties
- ans
+ Brat = function(mat, ties = 0 * mat, string = c(">", "=="),
+ whitespace = FALSE) {
+
+
+ stopifnot(is.logical(whitespace) &&
+ length(whitespace) == 1)
+ fillerChar <- ifelse(whitespace, " ", "")
+ string <- paste(fillerChar, string, fillerChar, sep = "")
+
+
+ allargs = list(mat) # ,...
+ callit = if (length(names(allargs))) names(allargs) else
+ as.character(1:length(allargs))
+ ans = ans.ties = NULL
+ 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")
+
+ diag(ties) = 0
+ if (!all(ties == t(ties)))
+ stop("ties must be a symmetric matrix")
+ are.ties = any(ties > 0)
+ diag(ties) = NA
+
+ diag(m) = 0 # Could have been NAs
+ if (any(is.na(m)))
+ stop("missing values not allowed (except on the diagonal)")
+ diag(m) = NA
+
+ dm = as.data.frame.table(m)
+ 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 = "")
+ ans = rbind(ans, matrix(dm$Freq, nrow = 1))
+ ans.ties = rbind(ans.ties, matrix(dt$Freq, nrow = 1))
+ }
+ dimnames(ans) = list(callit, usethis1)
+ dimnames(ans.ties) = list(callit, usethis2)
+ attr(ans, "ties") = ans.ties
+ attr(ans, "are.ties") = are.ties
+ ans
}
+
+
InverseBrat = function(yvec, NCo =
- (1:900)[(1:900)*((1:900)-1) == ncol(rbind(yvec))],
- multiplicity = if (is.matrix(yvec)) nrow(yvec) else 1,
- diag = NA, string = c(" > "," == ")) {
- ans = array(diag, c(NCo, NCo, multiplicity))
- yvec.orig = yvec
- yvec = c(yvec)
- ptr = 1
- 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
- }
- ans = if (multiplicity>1) ans else matrix(ans, NCo, NCo)
-
- if (is.array(yvec.orig) || is.matrix(yvec.orig)) {
- names.yvec = dimnames(yvec.orig)[[2]]
- ii = strsplit(names.yvec, string[1])
- cal = NULL
- 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]])
- } else
- dimnames(ans) = list(cal, cal)
- }
- ans
+ (1:900)[(1:900)*((1:900)-1) == ncol(rbind(yvec))],
+ multiplicity = if (is.matrix(yvec)) nrow(yvec) else 1,
+ diag = NA, string = c(">","=="),
+ whitespace = FALSE) {
+
+
+
+ stopifnot(is.logical(whitespace) &&
+ length(whitespace) == 1)
+ fillerChar <- ifelse(whitespace, " ", "")
+ string <- paste(fillerChar, string, fillerChar, sep = "")
+
+
+
+
+ ans = array(diag, c(NCo, NCo, multiplicity))
+ yvec.orig = yvec
+ yvec = c(yvec)
+ ptr = 1
+ 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
+ }
+ ans = if (multiplicity > 1) ans else matrix(ans, NCo, NCo)
+
+ if (is.array(yvec.orig) || is.matrix(yvec.orig)) {
+ names.yvec = dimnames(yvec.orig)[[2]]
+ ii = strsplit(names.yvec, string[1])
+ cal = NULL
+ 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]])
+ } else {
+ dimnames(ans) = list(cal, cal)
+ }
+ }
+ ans
}
-tapplymat1 = function(mat, function.arg = c("cumsum", "diff", "cumprod"))
+tapplymat1 = function(mat,
+ function.arg = c("cumsum", "diff", "cumprod"))
{
@@ -1452,9 +1699,9 @@ tapplymat1 = function(mat, function.arg = c("cumsum", "diff", "cumprod"))
dim(fred$mat) = c(NR, NC)
dimnames(fred$mat) = dimnames(mat)
switch(function.arg,
- cumsum =fred$mat,
- diff =fred$mat[,-1, drop = FALSE],
- cumprod=fred$mat)
+ cumsum = fred$mat,
+ diff = fred$mat[, -1, drop = FALSE],
+ cumprod= fred$mat)
}
@@ -1468,8 +1715,10 @@ tapplymat1 = function(mat, function.arg = c("cumsum", "diff", "cumprod"))
link = as.character(substitute(link))
if (!is.list(earg)) earg = list()
fcutpoints = cutpoints[is.finite(cutpoints)]
- if (!is.Numeric(fcutpoints, integer.valued = TRUE) || any(fcutpoints < 0))
- stop("'cutpoints' must have non-negative integer or Inf values only")
+ if (!is.Numeric(fcutpoints, integer.valued = 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)
@@ -1478,8 +1727,10 @@ tapplymat1 = function(mat, function.arg = c("cumsum", "diff", "cumprod"))
if (countdata) {
if (!is.Numeric(NOS, integer.valued = TRUE, positive = TRUE))
stop("'NOS' must have integer values only")
- if (!is.Numeric(Levels, integer.valued = TRUE, positive = TRUE) || any(Levels < 2))
- stop("'Levels' must have integer values (>= 2) only")
+ if (!is.Numeric(Levels, integer.valued = TRUE,
+ positive = TRUE) ||
+ any(Levels < 2))
+ stop("'Levels' must have integer values (>= 2) only")
Levels = rep(Levels, length=NOS)
}
@@ -1487,7 +1738,7 @@ tapplymat1 = function(mat, function.arg = c("cumsum", "diff", "cumprod"))
blurb = c(paste("Ordinal Poisson model\n\n"),
"Link: ", namesof("mu", link, earg = earg)),
constraints = eval(substitute(expression({
- constraints = cm.vgam(matrix(1,M,1), x, .parallel, constraints,
+ constraints = cm.vgam(matrix(1, M, 1), x, .parallel, constraints,
intercept.apply = TRUE)
constraints = cm.zero.vgam(constraints, x, .zero, M)
}), list( .parallel = parallel, .zero = zero ))),
@@ -1499,19 +1750,21 @@ tapplymat1 = function(mat, function.arg = c("cumsum", "diff", "cumprod"))
y.names = dimnames(y)[[2]] # Hopefully the user inputted them
} else {
if (any(w != 1) || ncol(cbind(w)) != 1)
- stop("the 'weights' argument must be a vector of all ones")
+ stop("the 'weights' argument must be a vector of all ones")
extra$NOS = M = NOS = if (is.Numeric( .NOS )) .NOS else
ncol(orig.y)
- Levels = rep( if (is.Numeric( .Levels )) .Levels else 0, len=NOS)
+ Levels = rep( if (is.Numeric( .Levels )) .Levels else 0,
+ len = NOS)
if (!is.Numeric( .Levels ))
- for (iii in 1:NOS) {
- Levels[iii] = length(unique(sort(orig.y[,iii])))
- }
+ for (iii in 1:NOS) {
+ Levels[iii] = length(unique(sort(orig.y[,iii])))
+ }
extra$Levels = Levels
}
- initmu = if (is.Numeric( .init.mu )) rep( .init.mu, len=NOS) else NULL
+ initmu = if (is.Numeric( .init.mu ))
+ rep( .init.mu, len = NOS) else NULL
cutpoints = rep( .cutpoints, len=sum(Levels))
delete.zero.colns = FALSE
use.y = if ( .countdata ) y else matrix(0, n, sum(Levels))
@@ -1523,12 +1776,13 @@ tapplymat1 = function(mat, function.arg = c("cumsum", "diff", "cumprod"))
eval(process.categorical.data.vgam) # Creates mustart and y
use.y[,cptr:(cptr+Levels[iii]-1)] = y
}
- use.etastart[,iii] = if (is.Numeric(initmu)) initmu[iii] else
+ use.etastart[,iii] = if (is.Numeric(initmu))
+ initmu[iii] else
median(cutpoints[cptr:(cptr+Levels[iii]-1-1)])
cptr = cptr + Levels[iii]
}
mustart = NULL # Overwrite it
- etastart = theta2eta(use.etastart, .link, earg = .earg)
+ etastart = theta2eta(use.etastart, .link , earg = .earg)
y = use.y # n x sum(Levels)
M = NOS
for (iii in 1:NOS) {
@@ -1540,14 +1794,15 @@ 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"
- predictors.names = namesof(mynames, .link, short = TRUE, earg = .earg)
+ 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
))),
linkinv = eval(substitute( function(eta, extra = NULL) {
- mu = eta2theta(eta, link= .link, earg = .earg) # Poisson means
+ mu = eta2theta(eta, link= .link , earg = .earg) # Poisson means
mu = cbind(mu)
mu
}, list( .link = link, .earg = earg, .countdata = countdata ))),
@@ -1556,7 +1811,7 @@ tapplymat1 = function(mat, function.arg = c("cumsum", "diff", "cumprod"))
misc$link = .link
misc$earg = list( .earg )
} else {
- misc$link = rep( .link, length=M)
+ misc$link = rep( .link , length = M)
names(misc$link) = mynames
misc$earg = vector("list", M)
names(misc$earg) = names(misc$link)
@@ -1566,7 +1821,8 @@ tapplymat1 = function(mat, function.arg = c("cumsum", "diff", "cumprod"))
misc$countdata = .countdata
misc$true.mu = FALSE # $fitted is not a true mu
}), list( .link = link, .countdata = countdata, .earg = earg ))),
- loglikelihood = function(mu, y, w, residuals = FALSE, eta, extra = NULL) {
+ loglikelihood =
+ function(mu, y, w, residuals = FALSE, eta, extra = NULL) {
if (residuals) stop("loglikelihood residuals not ",
"implemented yet") else {
probs = ordpoissonProbs(extra, mu)
@@ -1587,14 +1843,15 @@ tapplymat1 = function(mat, function.arg = c("cumsum", "diff", "cumprod"))
Levels = extra$Levels
resmat = matrix(0, n, M)
dl.dprob = y / probs.use
- dmu.deta = dtheta.deta(mu, .link, earg=.earg)
+ 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]) {
- resmat[,iii] = resmat[,iii] + dl.dprob[,cptr] * dprob.dmu[,cptr]
- cptr = cptr + 1
- }
+ for (kkk in 1:Levels[iii]) {
+ resmat[,iii] = resmat[,iii] +
+ dl.dprob[,cptr] * dprob.dmu[,cptr]
+ cptr = cptr + 1
+ }
}
resmat = c(w) * resmat * dmu.deta
resmat
@@ -1705,11 +1962,12 @@ ordpoissonProbs = function(extra, mu, deriv = 0) {
constraints[[ii]] =
(constraints[[ii]])[interleave.VGAM(M, M=2),, drop = FALSE]
}), list( .parallel = parallel, .sparallel=sparallel ))),
- deviance=eval(substitute(
+ deviance = eval(substitute(
function(mu, y, w, residuals = FALSE, eta, extra = NULL) {
answer =
- Deviance.categorical.data.vgam(mu=mu, y=y, w=w, residuals=residuals,
- eta=eta, extra=extra)
+ Deviance.categorical.data.vgam(mu = mu,
+ y = y, w = w, residuals = residuals,
+ eta = eta, extra = extra)
answer
}, list( .earg = earg, .link = link ) )),
initialize = eval(substitute(expression({
@@ -1720,10 +1978,11 @@ 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(mynames, .link , short = TRUE, earg = .earg),
namesof(paste("scale_", 1:J, sep = ""),
.lscale, short = TRUE, earg = .escale))
y.names = paste("mu", 1:(J+1), sep = "")
@@ -1731,7 +1990,7 @@ ordpoissonProbs = function(extra, mu, deriv = 0) {
if (length(dimnames(y)))
extra$dimnamesy2 = dimnames(y)[[2]]
- predictors.names = predictors.names[interleave.VGAM(M, M=2)]
+ predictors.names = predictors.names[interleave.VGAM(M, M = 2)]
}), list( .link = link, .lscale = lscale, .reverse = reverse,
.earg = earg, .escale = escale ))),
@@ -1743,65 +2002,74 @@ ordpoissonProbs = function(extra, mu, deriv = 0) {
scalemat = eta2theta(etamat2, .lscale, earg = .escale)
fv.matrix =
if ( .reverse ) {
- ccump = cbind(1, eta2theta(etamat1/scalemat, .link, earg=.earg))
+ ccump = cbind(1,
+ eta2theta(etamat1 / scalemat,
+ .link , earg = .earg))
cbind(-tapplymat1(ccump, "diff"), ccump[,ncol(ccump)])
} else {
- cump = cbind(eta2theta(etamat1/scalemat, .link, earg = .earg), 1)
+ cump = cbind(eta2theta(etamat1 / scalemat,
+ .link , earg = .earg),
+ 1)
cbind(cump[, 1], tapplymat1(cump, "diff"))
}
if (length(extra$dimnamesy2))
- dimnames(fv.matrix) = list(dimnames(eta)[[1]], extra$dimnamesy2)
+ dimnames(fv.matrix) = list(dimnames(eta)[[1]],
+ extra$dimnamesy2)
fv.matrix
- }, list( .link = link, .lscale = lscale, .reverse = reverse,
- .earg = earg, .escale = escale ))),
- last = eval(substitute(expression({
- J = extra$J
- misc$link = c(rep( .link, length=J),
- rep( .lscale, length=J))[interleave.VGAM(M, M=2)]
- 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
- misc$parameters = mynames
- misc$reverse = .reverse
- misc$parallel = .parallel
- misc$sparallel = .sparallel
- }), list( .link = link, .lscale = lscale,
- .reverse = reverse, .parallel = parallel, .sparallel=sparallel,
- .earg = earg, .escale = escale ))),
- linkfun = eval(substitute( function(mu, extra = NULL) {
- cump = tapplymat1(as.matrix(mu), "cumsum")
- J = ncol(as.matrix(mu)) - 1
- M = 2 * J
- answer = cbind(
- 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))
- answer = answer[,interleave.VGAM(M, M=2)]
- answer
- }, list( .link = link, .lscale = lscale, .reverse = reverse,
- .iscale=iscale, .earg = earg, .escale = escale ))),
- loglikelihood = function(mu, y, w, residuals = FALSE, eta, extra = NULL)
- 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
- nvec = if (is.numeric(extra$orig.w)) round(w / extra$orig.w) else
- round(w)
-
- smallno = 1.0e4 * .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) *
- dmultinomial(x = ycounts, size = nvec, prob = mu,
- log = TRUE, dochecking = FALSE))
- },
- vfamily = c("scumulative", "vcategorical"),
- deriv = eval(substitute(expression({
+ }, list( .link = link, .lscale = lscale, .reverse = reverse,
+ .earg = earg, .escale = escale ))),
+ last = eval(substitute(expression({
+ J = extra$J
+ misc$link =
+ c(rep( .link , length = J),
+ rep( .lscale, length = J))[interleave.VGAM(M, M = 2)]
+ 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
+ misc$parameters = mynames
+ misc$reverse = .reverse
+ misc$parallel = .parallel
+ misc$sparallel = .sparallel
+ }), list( .link = link, .lscale = lscale,
+ .reverse = reverse, .parallel = parallel,
+ .sparallel = sparallel,
+ .earg = earg, .escale = escale ))),
+ linkfun = eval(substitute( function(mu, extra = NULL) {
+ cump = tapplymat1(as.matrix(mu), "cumsum")
+ J = ncol(as.matrix(mu)) - 1
+ M = 2 * J
+ answer = cbind(
+ 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))
+ answer = answer[,interleave.VGAM(M, M=2)]
+ answer
+ }, list( .link = link, .lscale = lscale, .reverse = reverse,
+ .iscale = iscale, .earg = earg, .escale = escale ))),
+ loglikelihood =
+ function(mu, y, w, residuals = FALSE, eta, extra = NULL)
+ 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
+ nvec = if (is.numeric(extra$orig.w)) round(w / extra$orig.w) else
+ round(w)
+
+ smallno = 1.0e4 * .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) *
+ dmultinomial(x = ycounts, size = nvec, prob = mu,
+ log = TRUE, dochecking = FALSE))
+ },
+ vfamily = c("scumulative", "vcategorical"),
+ deriv = eval(substitute(expression({
ooz = iter %% 2
J = extra$J
@@ -1811,11 +2079,11 @@ ordpoissonProbs = function(extra, mu, deriv = 0) {
etamat2 = eta[, 2*(1:J), drop = FALSE]
scalemat = eta2theta(etamat2, .lscale, earg = .escale)
- cump = eta2theta(etamat1 / scalemat, .link, earg = .earg)
- dcump.deta = dtheta.deta(cump, .link, earg = .earg)
+ cump = eta2theta(etamat1 / scalemat, .link , earg = .earg)
+ dcump.deta = dtheta.deta(cump, .link , earg = .earg)
dscale.deta = dtheta.deta(scalemat, .lscale, earg = .escale)
dl.dcump = (if ( .reverse) -w else w) *
- (y[, 1:J]/mu.use[, 1:J] - y[,-1]/mu.use[,-1])
+ (y[, 1:J]/mu.use[, 1:J] - y[, -1]/mu.use[, -1])
dcump.dscale = -dcump.deta * etamat1 / scalemat^2
ans = cbind(dl.dcump * dcump.deta / scalemat,
dl.dcump * dcump.dscale * dscale.deta)
@@ -1829,40 +2097,45 @@ ordpoissonProbs = function(extra, mu, deriv = 0) {
wz = matrix(0, n, 2*(2*M-3))
wz[, 2*(1:J)-1] = if (ooz) c(w) * (dcump.deta / scalemat)^2 *
- (1/mu.use[, 1:J] + 1/mu.use[,-1]) else 1
- wz[, 2*(1:J)] = if (ooz) 1 else c(w) * (dcump.dscale * dscale.deta)^2 *
- (1/mu.use[, 1:J] + 1/mu.use[,-1])
+ (1/mu.use[, 1:J] + 1/mu.use[, -1]) else 1
+ wz[, 2*(1:J)] = if (ooz) 1 else
+ c(w) * (dcump.dscale * dscale.deta)^2 *
+ (1/mu.use[, 1:J] + 1/mu.use[, -1])
wz0 = c(w) * (dcump.deta / scalemat) *
(dcump.dscale * dscale.deta) *
- (1/mu.use[, 1:J] + 1/mu.use[,-1])
+ (1/mu.use[, 1:J] + 1/mu.use[, -1])
wz0 = as.matrix(wz0)
for (ii in 1:J)
- wz[,iam(2*ii-1,2*ii,M=M)] = if (ooz) wz0[,ii] else 0
+ 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 = -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))
- 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]
+ 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))
- wz[,iam(2*ii,2*ii+2,M=M)] = if (ooz) wz0[,ii] else 0
+ wz[,iam(2*ii,2*ii+2,M = M)] = if (ooz) wz0[, ii] else 0
- wz0 = -c(w) * (dcump.deta[,-J] / scalemat[,-J]) *
- (dcump.dscale[,-1] * dscale.deta[,-1]) / mu.use[, 2:J]
+ 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))
- 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]
+ 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))
- wz[,iam(2*ii,2*ii+1,M=M)] = if (ooz) wz0[,ii] else 0
+ wz[,iam(2*ii,2*ii+1,M = M)] = if (ooz) wz0[, ii] else 0
}
wz
}), list( .link = link, .lscale = lscale, .earg = earg,
@@ -1958,8 +2231,9 @@ margeff = function(object, subset = NULL) {
}
} else {
- if (is.logical(is.multivariateY <- object at misc$mv) && is.multivariateY)
- stop("cannot handle cumulative(mv = TRUE)")
+ if (is.logical(is.multivariateY <- object at misc$mv) &&
+ is.multivariateY)
+ stop("cannot handle cumulative(mv = TRUE)")
reverse = object at misc$reverse
linkfunctions = object at misc$link
all.eargs = object at misc$earg
@@ -1999,9 +2273,9 @@ margeff = function(object, subset = NULL) {
return(temp1)
} else
if (is.numeric(ii) && (length(ii) == 1)) {
- return(temp1[,,ii])
+ return(temp1[,, ii])
} else {
- return(temp1[,,ii])
+ return(temp1[,, ii])
}
}
}
@@ -2014,7 +2288,7 @@ margeff = function(object, subset = NULL) {
prplot = function(object,
- control=prplot.control(...), ...) {
+ control = prplot.control(...), ...) {
if (!any(slotNames(object) == "family") ||
@@ -2037,24 +2311,31 @@ 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)
+ 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]])
+ use.y[, ii] = eta2theta(use.y[, ii],
+ link = object at misc$link[[ii]],
+ earg = object at misc$earg[[ii]])
}
if (ncol(use.y) != MM) use.y = use.y[, 1:MM, drop = FALSE]
use.x = (object at preplot[[1]])$x
- myxlab = if (length(control$xlab)) control$xlab else (object at preplot[[1]])$xlab
- mymain = if (MM <= 3) paste(object at misc$parameters, collapse = ", ") else
+ myxlab = if (length(control$xlab))
+ control$xlab else (object at preplot[[1]])$xlab
+ mymain = if (MM <= 3)
+ paste(object at misc$parameters, collapse = ", ") else
paste(object at misc$parameters[c(1, MM)], collapse = ",...,")
if (length(control$main)) mymain = control$main
if (length(control$ylab)) myylab = control$ylab
- matplot(use.x, use.y, type = "l", xlab=myxlab, ylab=myylab,
- lty=control$lty, col=control$col, las=control$las,
- xlim=if (is.Numeric(control$xlim)) control$xlim else range(use.x),
- ylim=if (is.Numeric(control$ylim)) control$ylim else range(use.y),
+ matplot(use.x, use.y, type = "l",
+ xlab = myxlab, ylab = myylab,
+ lty = control$lty, col = control$col, las = control$las,
+ xlim = if (is.Numeric(control$xlim))
+ control$xlim else range(use.x),
+ ylim = if (is.Numeric(control$ylim))
+ control$ylim else range(use.y),
main=mymain)
if (control$rug.arg)
rug(use.x, col=control$rcol, lwd=control$rlwd)
@@ -2065,22 +2346,23 @@ prplot = function(object,
- prplot.control = function(xlab = NULL, ylab = "Probability", main = NULL,
+ prplot.control = function(xlab = NULL, ylab = "Probability",
+ main = NULL,
xlim = NULL, ylim = NULL,
- lty=par()$lty,
- col=par()$col,
- rcol=par()$col,
- lwd=par()$lwd,
- rlwd=par()$lwd,
- las=par()$las,
+ lty = par()$lty,
+ col = par()$col,
+ rcol = par()$col,
+ lwd = par()$lwd,
+ rlwd = par()$lwd,
+ las = par()$las,
rug.arg = FALSE,
...) {
- list(xlab=xlab, ylab=ylab,
- xlim=xlim, ylim=ylim,
- lty=lty, col=col, rcol=rcol,
- lwd=lwd, rlwd=rlwd, rug.arg=rug.arg,
- las=las, main=main)
+ list(xlab = xlab, ylab = ylab,
+ xlim = xlim, ylim = ylim,
+ lty = lty, col = col, rcol = rcol,
+ lwd = lwd, rlwd = rlwd, rug.arg = rug.arg,
+ las = las, main = main)
}
diff --git a/R/family.exp.R b/R/family.exp.R
index 25980dc..2ad0e35 100644
--- a/R/family.exp.R
+++ b/R/family.exp.R
@@ -18,10 +18,12 @@ qeunif <- function(p, min = 0, max = 1, Maxit_nr = 10, Tol_nr = 1.0e-6) {
vsmallno = sqrt(.Machine$double.eps)
smallno = 0.10
if (any(min >= max))
- stop("argument 'min' has values greater or equal to argument 'max'")
+ stop("argument 'min' has values greater or equal ",
+ "to argument 'max'")
if (!is.Numeric( Tol_nr, allowable.length = 1, positive = TRUE) ||
Tol_nr > 0.10)
- stop("argument 'Tol_nr' is not a single positive value, or is too large")
+ stop("argument 'Tol_nr' is not a single positive value, ",
+ "or is too large")
nrok = ppp >= vsmallno & ppp <= 1.0 - vsmallno & is.finite(ppp)
eee = qbeta(ppp, shape1 = 3, shape2 = 3)
@@ -50,7 +52,8 @@ qeunif <- function(p, min = 0, max = 1, Maxit_nr = 10, Tol_nr = 1.0e-6) {
peunif <- function(q, min = 0, max = 1, log = FALSE) {
- if (!is.logical(log.arg <- log)) stop("bad input for argument 'log'")
+ if (!is.logical(log.arg <- log))
+ stop("bad input for argument 'log'")
rm(log)
if (any(min >= max))
stop("argument 'min' has values greater or equal to argument 'max'")
@@ -72,7 +75,8 @@ peunif <- function(q, min = 0, max = 1, log = FALSE) {
deunif <- function(x, min = 0, max = 1, log = FALSE) {
- if (!is.logical(log.arg <- log)) stop("bad input for argument 'log'")
+ if (!is.logical(log.arg <- log))
+ stop("bad input for argument 'log'")
rm(log)
if (any(min >= max))
stop("argument 'min' has values greater or equal to argument 'max'")
@@ -96,17 +100,20 @@ deunif <- function(x, min = 0, max = 1, log = FALSE) {
reunif <- function(n, min = 0, max = 1) {
- use.n = if ((length.n <- length(n)) > 1) length.n else
- if (!is.Numeric(n, integer.valued = TRUE, allowable.length = 1, positive = TRUE))
- stop("bad input for argument 'n'") else n
- qeunif(runif(use.n), min = min, max = max)
+ use.n = if ((length.n <- length(n)) > 1) length.n else
+ if (!is.Numeric(n, integer.valued = TRUE,
+ allowable.length = 1, positive = TRUE))
+ stop("bad input for argument 'n'") else n
+
+ qeunif(runif(use.n), min = min, max = max)
}
-qenorm <- function(p, mean = 0, sd = 1, Maxit_nr = 10, Tol_nr = 1.0e-6) {
+qenorm <- function(p, mean = 0, sd = 1, Maxit_nr = 10,
+ Tol_nr = 1.0e-6) {
ppp = p
if (!is.Numeric( Tol_nr, allowable.length = 1, positive = TRUE) ||
Tol_nr > 0.10)
@@ -138,7 +145,8 @@ qenorm <- function(p, mean = 0, sd = 1, Maxit_nr = 10, Tol_nr = 1.0e-6) {
penorm <- function(q, mean = 0, sd = 1, log = FALSE) {
- if (!is.logical(log.arg <- log)) stop("bad input for argument 'log'")
+ if (!is.logical(log.arg <- log))
+ stop("bad input for argument 'log'")
rm(log)
eee = (q - mean) / sd
@@ -158,7 +166,8 @@ penorm <- function(q, mean = 0, sd = 1, log = FALSE) {
denorm <- function(x, mean = 0, sd = 1, log = FALSE) {
- if (!is.logical(log.arg <- log)) stop("bad input for argument 'log'")
+ if (!is.logical(log.arg <- log))
+ stop("bad input for argument 'log'")
rm(log)
eee = (x - mean) / sd
@@ -177,10 +186,12 @@ denorm <- function(x, mean = 0, sd = 1, log = FALSE) {
renorm <- function(n, mean = 0, sd = 1) {
- use.n = if ((length.n <- length(n)) > 1) length.n else
- if (!is.Numeric(n, integer.valued = TRUE, allowable.length = 1, positive = TRUE))
- stop("bad input for argument 'n'") else n
- qenorm(runif(use.n), mean = mean, sd = sd)
+ use.n = if ((length.n <- length(n)) > 1) length.n else
+ if (!is.Numeric(n, integer.valued = TRUE,
+ allowable.length = 1, positive = TRUE))
+ stop("bad input for argument 'n'") else n
+
+ qenorm(runif(use.n), mean = mean, sd = sd)
}
@@ -227,7 +238,8 @@ qeexp <- function(p, rate = 1, Maxit_nr = 10, Tol_nr = 1.0e-6) {
peexp <- function(q, rate = 1, log = FALSE) {
- if (!is.logical(log.arg <- log)) stop("bad input for argument 'log'")
+ if (!is.logical(log.arg <- log))
+ stop("bad input for argument 'log'")
rm(log)
eee = q * rate
@@ -249,7 +261,8 @@ peexp <- function(q, rate = 1, log = FALSE) {
deexp <- function(x, rate = 1, log = FALSE) {
- if (!is.logical(log.arg <- log)) stop("bad input for argument 'log'")
+ if (!is.logical(log.arg <- log))
+ stop("bad input for argument 'log'")
rm(log)
if (any(rate <= 0))
stop("argument 'rate' must have positive values")
@@ -296,6 +309,7 @@ dkoenker <- function(x, location = 0, scale = 1, log = FALSE) {
}
+
pkoenker <- function(q, location = 0, scale = 1, log = FALSE) {
if (!is.logical(log.arg <- log))
stop("bad input for argument 'log'")
@@ -329,6 +343,7 @@ qkoenker <- function(p, location = 0, scale = 1) {
+
rkoenker <- function(n, location = 0, scale = 1) {
answer <- qkoenker(runif(n)) * scale + location
answer[scale <= 0] <- NaN
@@ -338,6 +353,7 @@ rkoenker <- function(n, location = 0, scale = 1) {
+
koenker <- function(percentile = 50,
llocation = "identity", lscale = "loge",
elocation = list(), escale = list(),
@@ -349,7 +365,6 @@ rkoenker <- function(n, location = 0, scale = 1) {
-
llocat = llocation
elocat = elocation
ilocat = ilocation
@@ -400,7 +415,7 @@ rkoenker <- function(n, location = 0, scale = 1) {
median(y)
}
Scale.init <- if (length( .iscale )) .iscale else
- diff(quantile(y, prob = c(0.25, 0.75))) / (2 * 1.155) + 1.0e-5
+ diff(quantile(y, prob = c(0.25, 0.75))) / (2 * 1.155) + 1.0e-5
locat.init <- rep(locat.init, length = length(y))
Scale.init <- rep(Scale.init, length = length(y))
etastart <- cbind(theta2eta(locat.init, .llocat, earg = .elocat),
@@ -441,13 +456,14 @@ rkoenker <- function(n, location = 0, scale = 1) {
.elocat = elocat, .escale = escale,
.imethod = imethod, .percentile = percentile ))),
loglikelihood = eval(substitute(
- function(mu, y, w, residuals = FALSE, eta, extra = NULL) {
+ function(mu, y, w, residuals = FALSE, eta, extra = NULL) {
locat <- eta2theta(eta[, 1], link = .llocat, earg = .elocat)
Scale <- eta2theta(eta[, 2], link = .lscale, earg = .escale)
if (residuals) {
stop("loglikelihood residuals not implemented yet")
} else {
- sum(w * dkoenker(x = y, location = locat, scale = Scale, log = TRUE))
+ sum(w * dkoenker(x = y, location = locat, scale = Scale,
+ log = TRUE))
}
}, list( .llocat = llocat, .lscale = lscale,
.elocat = elocat, .escale = escale ))),
@@ -455,6 +471,7 @@ rkoenker <- function(n, location = 0, scale = 1) {
deriv = eval(substitute(expression({
locat <- eta2theta(eta[, 1], link = .llocat, earg = .elocat)
Scale <- eta2theta(eta[, 2], link = .lscale, earg = .escale)
+
dlocat.deta <- dtheta.deta(locat, link = .llocat, earg = .elocat)
dscale.deta <- dtheta.deta(Scale, link = .lscale, earg = .escale)
diff --git a/R/family.extremes.R b/R/family.extremes.R
index 6b397ff..edf7203 100644
--- a/R/family.extremes.R
+++ b/R/family.extremes.R
@@ -177,19 +177,24 @@ qgev <- function(p, location = 0, scale = 1, shape = 0) {
lshape = as.character(substitute(lshape))
if (!mean && length(percentiles) &&
- (!is.Numeric(percentiles, positive = TRUE) || max(percentiles) >= 100))
- stop("bad input for argument 'percentiles'")
- if (!is.Numeric(imethod, allowable.length = 1, positive = TRUE, integer.valued = TRUE) ||
+ (!is.Numeric(percentiles, positive = TRUE) ||
+ max(percentiles) >= 100))
+ stop("bad input for argument 'percentiles'")
+ if (!is.Numeric(imethod, allowable.length = 1,
+ positive = TRUE, integer.valued = TRUE) ||
imethod > 2.5)
- stop("argument 'imethod' must be 1 or 2")
+ stop("argument 'imethod' must be 1 or 2")
if (length(ishape) && !is.Numeric(ishape))
stop("bad input for argument 'ishape'")
- if (!is.Numeric(tolshape0, allowable.length = 1, positive = TRUE) || tolshape0 > 0.1)
- stop("bad input for argument 'tolshape0'")
- if (!is.Numeric(gshape, allowable.length = 2) || gshape[1] >= gshape[2])
- stop("bad input for argument 'gshape'")
- if (length(zero) && !is.Numeric(zero, integer.valued = TRUE, positive = TRUE))
- stop("bad input for argument 'zero'")
+ if (!is.Numeric(tolshape0, allowable.length = 1, positive = TRUE) ||
+ tolshape0 > 0.1)
+ stop("bad input for argument 'tolshape0'")
+ if (!is.Numeric(gshape, allowable.length = 2) ||
+ gshape[1] >= gshape[2])
+ stop("bad input for argument 'gshape'")
+ if (length(zero) &&
+ !is.Numeric(zero, integer.valued = TRUE, positive = TRUE))
+ stop("bad input for argument 'zero'")
if (!is.list(elocation)) elocation = list()
if (!is.list(escale)) escale = list()
@@ -245,14 +250,16 @@ qgev <- function(p, location = 0, scale = 1, shape = 0) {
(nvector^xi.try - 1) / xi.try
fit0 = lsfit(x = xvec, y=ynvector, intercept = TRUE)
sigmaTry = if (est.sigma)
- rep(fit0$coef["X"], length.out = nrow(y)) else init.sig
+ rep(fit0$coef["X"], length.out = nrow(y)) else
+ init.sig
muTry = rep(fit0$coef["Intercept"], length.out = nrow(y))
llTry = egev(giveWarning=
FALSE)@loglikelihood(mu = NULL, y=y[, 1], w=w,
residuals = FALSE,
- eta = cbind(theta2eta(muTry, .llocation,earg = .elocation),
- theta2eta(sigmaTry, .lscale,earg = .escale),
- theta2eta(xi.try, link= .lshape, earg = .eshape)))
+ eta =
+ cbind(theta2eta(muTry, .llocation,earg = .elocation),
+ theta2eta(sigmaTry, .lscale,earg = .escale),
+ theta2eta(xi.try, link= .lshape, earg = .eshape)))
if (llTry >= objecFunction) {
if (est.sigma)
init.sig = sigmaTry
@@ -266,9 +273,11 @@ qgev <- function(p, location = 0, scale = 1, shape = 0) {
} else {
init.xi = rep(0.05, length.out = nrow(y))
if (!length(init.sig))
- init.sig = rep(sqrt(6 * var(y[, 1]))/pi, length.out = nrow(y))
+ init.sig = rep(sqrt(6 * var(y[, 1]))/pi,
+ length.out = nrow(y))
EulerM = -digamma(1)
- init.mu = rep(median(y[, 1]) - EulerM*init.sig, length.out = nrow(y))
+ init.mu = rep(median(y[, 1]) - EulerM*init.sig,
+ length.out = nrow(y))
}
bad = ((1 + init.xi*(y-init.mu)/init.sig) <= 0)
@@ -526,71 +535,79 @@ dgammadx <- function(x, deriv.arg = 1) {
llocation <- as.character(substitute(llocation))
if (mode(lshape) != "character" && mode(lshape) != "name")
lshape <- as.character(substitute(lshape))
- if (!is.Numeric(gshape, allowable.length = 2) || gshape[1] >= gshape[2])
+ if (!is.Numeric(gshape, allowable.length = 2) ||
+ gshape[1] >= gshape[2])
stop("bad input for argument 'gshape'")
if (length(percentiles) &&
- (!is.Numeric(percentiles, positive = TRUE) || max(percentiles) >= 100))
- stop("bad input for argument 'percentiles'")
- if (!is.Numeric(imethod, allowable.length = 1, positive = TRUE, integer.valued = TRUE) ||
+ (!is.Numeric(percentiles, positive = TRUE) ||
+ max(percentiles) >= 100))
+ stop("bad input for argument 'percentiles'")
+ if (!is.Numeric(imethod, allowable.length = 1,
+ positive = TRUE, integer.valued = TRUE) ||
imethod > 2.5)
- stop("argument 'imethod' must be 1 or 2")
+ stop("argument 'imethod' must be 1 or 2")
if (length(ishape) && !is.Numeric(ishape))
- stop("bad input for argument 'ishape'")
- if (!is.Numeric(tolshape0, allowable.length = 1, positive = TRUE) || tolshape0 > 0.1)
- stop("bad input for argument 'tolshape0'")
- if (length(zero) && !is.Numeric(zero, integer.valued = TRUE, positive = TRUE))
- stop("bad input for argument 'zero'")
+ stop("bad input for argument 'ishape'")
+ if (!is.Numeric(tolshape0, allowable.length = 1, positive = TRUE) ||
+ tolshape0 > 0.1)
+ stop("bad input for argument 'tolshape0'")
+ if (length(zero) &&
+ !is.Numeric(zero, integer.valued = TRUE, positive = TRUE))
+ stop("bad input for argument 'zero'")
+
if (!is.list(elocation)) elocation = list()
if (!is.list(escale)) escale = list()
if (!is.list(eshape)) eshape = list()
- new("vglmff",
- blurb = c("Generalized extreme value distribution\n",
- "Links: ",
- namesof("location", link = llocation, earg = elocation), ", ",
- namesof("scale", link = lscale, earg = escale), ", ",
- namesof("shape", link = lshape, earg = eshape)),
- constraints=eval(substitute(expression({
- constraints <- cm.zero.vgam(constraints, x, .zero, M)
- }), list( .zero = zero ))),
- initialize = eval(substitute(expression({
- predictors.names =
- c(namesof("location", .llocation, earg = .elocation, short = TRUE),
- namesof("scale", .lscale, earg = .escale, short = TRUE),
- namesof("shape", .lshape, earg = .eshape, short = TRUE))
- if (ncol(as.matrix(y)) != 1)
- stop("response must be a vector or one-column matrix")
- if (!length(etastart)) {
- init.sig= if (length( .iscale)) rep( .iscale, length.out = length(y)) else NULL
- init.xi = if (length( .ishape)) rep( .ishape, length.out = length(y)) else NULL
- eshape = .eshape
- if ( .lshape == "elogit" && length(init.xi) &&
- (any(init.xi <= eshape$min | init.xi >= eshape$max)))
- stop("bad input for argument 'eshape'")
- if ( .imethod == 1) {
- nvector = 4:10 # Arbitrary; could be made an argument
- ynvector = quantile(y, probs = 1-1/nvector)
- objecFunction = -Inf # Actually the log-likelihood
- est.sigma = !length(init.sig)
- gshape = .gshape
- temp234 = if (length(init.xi)) init.xi[1] else
- seq(gshape[1], gshape[2], length.out = 12)
- for(xi.try in temp234) {
- xvec = if (abs(xi.try) < .tolshape0) log(nvector) else
- (nvector^xi.try - 1) / xi.try
- fit0 = lsfit(x = xvec, y=ynvector, intercept = TRUE)
- if (est.sigma) {
- sigmaTry = rep(fit0$coef["X"], length.out = length(y))
- } else {
- sigmaTry = init.sig
- }
- muTry = rep(fit0$coef["Intercept"], length.out = length(y))
+ new("vglmff",
+ blurb = c("Generalized extreme value distribution\n",
+ "Links: ",
+ namesof("location", link = llocation, earg = elocation), ", ",
+ namesof("scale", link = lscale, earg = escale), ", ",
+ namesof("shape", link = lshape, earg = eshape)),
+ constraints=eval(substitute(expression({
+ constraints <- cm.zero.vgam(constraints, x, .zero, M)
+ }), list( .zero = zero ))),
+ initialize = eval(substitute(expression({
+ predictors.names =
+ c(namesof("location", .llocation , earg = .elocation , short = TRUE),
+ namesof("scale", .lscale, earg = .escale, short = TRUE),
+ namesof("shape", .lshape, earg = .eshape, short = TRUE))
+ if (ncol(as.matrix(y)) != 1)
+ stop("response must be a vector or one-column matrix")
+ if (!length(etastart)) {
+ init.sig = if (length( .iscale))
+ rep( .iscale, length.out = length(y)) else NULL
+ init.xi = if (length( .ishape))
+ rep( .ishape, length.out = length(y)) else NULL
+ eshape = .eshape
+ if ( .lshape == "elogit" && length(init.xi) &&
+ (any(init.xi <= eshape$min | init.xi >= eshape$max)))
+ stop("bad input for argument 'eshape'")
+ if ( .imethod == 1) {
+ nvector = 4:10 # Arbitrary; could be made an argument
+ ynvector = quantile(y, probs = 1-1/nvector)
+ objecFunction = -Inf # Actually the log-likelihood
+ est.sigma = !length(init.sig)
+ gshape = .gshape
+ temp234 = if (length(init.xi)) init.xi[1] else
+ seq(gshape[1], gshape[2], length.out = 12)
+ for(xi.try in temp234) {
+ xvec = if (abs(xi.try) < .tolshape0) log(nvector) else
+ (nvector^xi.try - 1) / xi.try
+ fit0 = lsfit(x = xvec, y=ynvector, intercept = TRUE)
+ if (est.sigma) {
+ sigmaTry = rep(fit0$coef["X"], length.out = length(y))
+ } else {
+ sigmaTry = init.sig
+ }
+ muTry = rep(fit0$coef["Intercept"], length.out = length(y))
llTry = egev(giveWarning=
- FALSE)@loglikelihood(mu = NULL, y=y, w=w,
- residuals = FALSE,
- eta = cbind(theta2eta(muTry, .llocation, earg = .elocation),
- theta2eta(sigmaTry, .lscale, earg = .escale),
- theta2eta(xi.try, .lshape, earg = .eshape)))
+ FALSE)@loglikelihood(mu = NULL, y = y, w = w,
+ residuals = FALSE,
+ eta = cbind(theta2eta(muTry, .llocation, earg = .elocation),
+ theta2eta(sigmaTry, .lscale, earg = .escale),
+ theta2eta(xi.try, .lshape, earg = .eshape)))
if (llTry >= objecFunction) {
if (est.sigma)
init.sig = sigmaTry
@@ -606,15 +623,17 @@ dgammadx <- function(x, deriv.arg = 1) {
init.xi = rep(if (length(init.xi)) init.xi else 0.05,
length.out = length(y))
if (!length(init.sig))
- init.sig = rep(sqrt(6*var(y))/pi, length.out = length(y))
+ init.sig = rep(sqrt(6*var(y))/pi,
+ length.out = length(y))
EulerM = -digamma(1)
- init.mu = rep(median(y) - EulerM * init.sig, length.out = length(y))
+ init.mu = rep(median(y) - EulerM * init.sig,
+ length.out = length(y))
}
bad <- (1 + init.xi*(y-init.mu)/init.sig <= 0)
if (fred <- sum(bad, na.rm = TRUE)) {
- warning(paste(fred, "observations violating boundary",
- "constraints while initializing. Taking corrective action."))
- init.xi[bad] = ifelse(y[bad] > init.mu[bad], 0.01, -0.01)
+ warning(paste(fred, "observations violating boundary",
+ "constraints while initializing. Taking corrective action."))
+ init.xi[bad] = ifelse(y[bad] > init.mu[bad], 0.01, -0.01)
}
extra$percentiles = .percentiles
@@ -659,10 +678,14 @@ dgammadx <- function(x, deriv.arg = 1) {
.elocation = elocation, .escale = escale, .eshape = eshape,
.tolshape0 = tolshape0 ))),
last = eval(substitute(expression({
- misc$links <- c(location = .llocation, scale = .lscale, shape = .lshape)
+ misc$links <- c(location = .llocation,
+ scale = .lscale,
+ shape = .lshape)
misc$true.mu = !length( .percentiles) # @fitted is not a true mu
misc$percentiles <- .percentiles
- misc$earg = list(location= .elocation, scale= .escale, shape= .eshape)
+ misc$earg = list(location = .elocation,
+ scale = .escale,
+ shape = .eshape)
misc$tolshape0 = .tolshape0
misc$expected = TRUE
if (any(xi < -0.5))
@@ -707,10 +730,12 @@ dgammadx <- function(x, deriv.arg = 1) {
dl.dxi = log(A)/xi^2 - pow * dA.dxi / A -
(log(A)/xi^2 - dA.dxi /(xi*A)) * A^(-1/xi)
if (any(is.zero)) {
- ezedd = exp(-zedd[is.zero])
- dl.dmu[is.zero] = (1-ezedd) / sigma[is.zero]
- dl.dsi[is.zero] = (zedd[is.zero] * (1-ezedd) - 1) / sigma[is.zero]
- dl.dxi[is.zero] = zedd[is.zero] * ((1 - ezedd) * zedd[is.zero] / 2 -1)
+ ezedd = exp(-zedd[is.zero])
+ dl.dmu[is.zero] = (1 - ezedd) / sigma[is.zero]
+ dl.dsi[is.zero] = (zedd[is.zero] *
+ (1 - ezedd) - 1) / sigma[is.zero]
+ dl.dxi[is.zero] = zedd[is.zero] *
+ ((1 - ezedd) * zedd[is.zero] / 2 - 1)
}
dmu.deta = dtheta.deta(mmu, .llocation, earg = .elocation)
dsi.deta = dtheta.deta(sigma, .lscale, earg = .escale )
@@ -767,7 +792,8 @@ dgammadx <- function(x, deriv.arg = 1) {
rgumbel <- function(n, location = 0, scale = 1) {
use.n = if ((length.n <- length(n)) > 1) length.n else
- if (!is.Numeric(n, integer.valued = TRUE, allowable.length = 1, positive = TRUE))
+ if (!is.Numeric(n, integer.valued = TRUE,
+ allowable.length = 1, positive = TRUE))
stop("bad input for argument 'n'") else n
answer = location - scale * log(-log(runif(use.n)))
@@ -775,6 +801,7 @@ rgumbel <- function(n, location = 0, scale = 1) {
answer
}
+
dgumbel <- function(x, location = 0, scale = 1, log = FALSE) {
if (!is.logical(log.arg <- log))
stop("bad input for argument 'log'")
@@ -785,6 +812,7 @@ dgumbel <- function(x, location = 0, scale = 1, log = FALSE) {
if (log.arg) logdensity else exp(logdensity)
}
+
qgumbel <- function(p, location = 0, scale = 1) {
answer = location - scale * log(-log(p))
answer[scale <= 0] = NaN
@@ -795,6 +823,7 @@ qgumbel <- function(p, location = 0, scale = 1) {
answer
}
+
pgumbel <- function(q, location = 0, scale = 1) {
answer = exp(-exp(-(q-location) / scale))
answer[scale <= 0] = NaN
@@ -810,183 +839,193 @@ pgumbel <- function(q, location = 0, scale = 1) {
R=NA, percentiles = c(95,99),
mpv = FALSE, 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.logical(mpv) || length(mpv) != 1)
- stop("bad input for argument 'mpv'")
- if (length(percentiles) &&
- (!is.Numeric(percentiles, positive = TRUE) || max(percentiles) >= 100))
- stop("bad input for argument 'percentiles'")
- if (length(zero) && !is.Numeric(zero, integer.valued = TRUE, positive = TRUE))
- stop("bad input for argument 'zero'")
- if (length(iscale) && !is.Numeric(iscale, positive = TRUE))
- stop("bad input for argument 'iscale'")
- if (!is.list(elocation)) elocation = list()
- if (!is.list(escale)) escale = list()
+ 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.logical(mpv) || length(mpv) != 1)
+ stop("bad input for argument 'mpv'")
+ if (length(percentiles) &&
+ (!is.Numeric(percentiles, positive = TRUE) ||
+ max(percentiles) >= 100))
+ stop("bad input for argument 'percentiles'")
+ if (length(zero) &&
+ !is.Numeric(zero, integer.valued = TRUE, positive = TRUE))
+ stop("bad input for argument 'zero'")
+ if (length(iscale) && !is.Numeric(iscale, positive = TRUE))
+ stop("bad input for argument 'iscale'")
- new("vglmff",
- blurb = c("Gumbel distribution for extreme value regression\n",
- "Links: ",
- namesof("location", link = llocation, earg = elocation), ", ",
- namesof("scale", link = lscale, earg = escale )),
- constraints=eval(substitute(expression({
- constraints = cm.zero.vgam(constraints, x, .zero, M)
- }), list( .zero = zero ))),
- initialize = eval(substitute(expression({
- predictors.names =
- c(namesof("location", .llocation, earg = .elocation, short = TRUE),
- namesof("scale", .lscale, earg = .escale , short = TRUE))
- y = as.matrix(y)
- if (ncol(y) > 1)
- y = -t(apply(-y, 1, sort, na.last = TRUE))
- r.vec = rowSums(cbind(!is.na(y)))
- if (any(r.vec == 0))
- stop("There is at least one row of the response containing all NAs")
- if (ncol(y) > 1) {
- yiri = y[cbind(1:nrow(y), r.vec)]
- sc.init = if (is.Numeric( .iscale, positive = TRUE))
- .iscale else {3 * (rowMeans(y, na.rm = TRUE) - yiri)}
- sc.init = rep(sc.init, length=nrow(y))
- sc.init[sc.init <= 0.0001] = 1 # Used to be .iscale
- loc.init = yiri + sc.init * log(r.vec)
- } else {
- sc.init = if (is.Numeric( .iscale, positive = TRUE))
- .iscale else 1.1 * (0.01+sqrt(var(y)*6)) / pi
- sc.init = rep(sc.init, length.out = n)
- EulerM = -digamma(1)
- loc.init = (y - sc.init * EulerM)
- loc.init[loc.init <= 0] = min(y)
- }
+ if (!is.list(elocation)) elocation = list()
+ if (!is.list(escale)) escale = list()
- extra$R = .R
- extra$mpv = .mpv
- extra$percentiles = .percentiles
+ new("vglmff",
+ blurb = c("Gumbel distribution for extreme value regression\n",
+ "Links: ",
+ namesof("location", link = llocation, earg = elocation), ", ",
+ namesof("scale", link = lscale, earg = escale )),
+ constraints=eval(substitute(expression({
+ constraints = cm.zero.vgam(constraints, x, .zero, M)
+ }), list( .zero = zero ))),
+ initialize = eval(substitute(expression({
+ predictors.names =
+ c(namesof("location", .llocation, earg = .elocation, short = TRUE),
+ namesof("scale", .lscale, earg = .escale , short = TRUE))
+ y = as.matrix(y)
+ if (ncol(y) > 1)
+ y = -t(apply(-y, 1, sort, na.last = TRUE))
+ r.vec = rowSums(cbind(!is.na(y)))
+ if (any(r.vec == 0))
+ stop("There is at least one row of the response containing all NAs")
+ if (ncol(y) > 1) {
+ yiri = y[cbind(1:nrow(y), r.vec)]
+ sc.init = if (is.Numeric( .iscale, positive = TRUE))
+ .iscale else {3 * (rowMeans(y, na.rm = TRUE) - yiri)}
+ sc.init = rep(sc.init, length=nrow(y))
+ sc.init[sc.init <= 0.0001] = 1 # Used to be .iscale
+ loc.init = yiri + sc.init * log(r.vec)
+ } else {
+ sc.init = if (is.Numeric( .iscale, positive = TRUE))
+ .iscale else 1.1 * (0.01+sqrt(var(y)*6)) / pi
+ sc.init = rep(sc.init, length.out = n)
+ EulerM = -digamma(1)
+ loc.init = (y - sc.init * EulerM)
+ loc.init[loc.init <= 0] = min(y)
+ }
- if (!length(etastart))
- etastart = cbind(theta2eta(loc.init, .llocation, earg = .elocation),
- theta2eta(sc.init, .lscale, earg = .escale ))
- }), list( .llocation = llocation, .lscale = lscale, .iscale = iscale,
- .elocation = elocation, .escale = escale,
- .R=R, .mpv=mpv, .percentiles = percentiles ))),
- 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
- LP = length(Percentiles) # may be 0
- if (LP > 0) {
- mpv = extra$mpv
- mu = matrix(as.numeric(NA), nrow(eta), LP + mpv) # LP may be 0
- Rvec = extra$R
- for(ii in 1:LP) {
- ci = if (is.Numeric(Rvec))
- Rvec * (1 - Percentiles[ii] / 100) else
- -log(Percentiles[ii] / 100)
- mu[,ii] = loc - sigma * log(ci)
- }
- if (mpv)
- mu[,ncol(mu)] = loc - sigma * log(log(2))
- dmn2 = paste(as.character(Percentiles), "%", sep = "")
- if (mpv)
- dmn2 = c(dmn2, "MPV")
- dimnames(mu) = list(dimnames(eta)[[1]], dmn2)
- } else {
- EulerM = -digamma(1)
- mu = loc + sigma * EulerM
- }
- mu
- }, list( .llocation = llocation, .lscale = lscale,
- .elocation = elocation, .escale = escale ))),
- last = eval(substitute(expression({
- misc$R = .R
- misc$links = c(location = .llocation, scale = .lscale)
- misc$earg = list(location= .elocation, scale= .escale )
- misc$mpv = .mpv
- misc$true.mu = !length( .percentiles) # @fitted is not a true mu
- misc$percentiles = .percentiles
- }), list( .llocation = llocation, .lscale = lscale, .percentiles = percentiles,
- .elocation = elocation, .escale = escale,
- .mpv=mpv, .R=R ))),
- vfamily = c("gumbel", "vextremes"),
- loglikelihood = eval(substitute(
- function(mu, y, w, residuals = FALSE, eta, extra = NULL) {
- loc = eta2theta(eta[, 1], .llocation, earg = .elocation)
- sigma = eta2theta(eta[, 2], .lscale, earg = .escale )
- r.vec = rowSums(cbind(!is.na(y)))
- yiri = y[cbind(1:nrow(y),r.vec)]
- ans = -r.vec * log(sigma) - exp( -(yiri-loc)/sigma )
- max.r.vec = max(r.vec)
- for(jay in 1:max.r.vec) {
- index = (jay <= r.vec)
- ans[index] = ans[index] - (y[index,jay]-loc[index]) / sigma[index]
- }
- if (residuals) stop("loglikelihood residuals not ",
- "implemented yet") else {
+ extra$R = .R
+ extra$mpv = .mpv
+ extra$percentiles = .percentiles
+ if (!length(etastart))
+ etastart =
+ cbind(theta2eta(loc.init, .llocation, earg = .elocation),
+ theta2eta(sc.init, .lscale, earg = .escale ))
+}), list( .llocation = llocation, .lscale = lscale, .iscale = iscale,
+ .elocation = elocation, .escale = escale,
+ .R = R, .mpv = mpv, .percentiles = percentiles ))),
- sum(w * ans)
- }
- }, list( .llocation = llocation, .lscale = lscale,
- .elocation = elocation, .escale = escale ))),
- deriv = eval(substitute(expression({
- loc = eta2theta(eta[, 1], .llocation, earg = .elocation)
- sigma = eta2theta(eta[, 2], .lscale, earg = .escale )
- r.vec = rowSums(cbind(!is.na(y)))
- yiri = y[cbind(1:nrow(y),r.vec)]
- yi.bar = rowMeans(y, na.rm = TRUE)
- temp2 = (yiri - loc) / sigma
- term2 = exp(-temp2)
- dloc.deta = dtheta.deta(loc, .llocation, earg = .elocation)
- dsigma.deta = dtheta.deta(sigma, .lscale, earg = .escale )
- dl.dloc = (r.vec - term2) / sigma
- dl.dsigma = (rowSums((y - loc) / sigma, na.rm = TRUE) - r.vec -
- temp2 * term2) / sigma
- c(w) * cbind(dl.dloc * dloc.deta,
- dl.dsigma * dsigma.deta)
- }), list( .llocation = llocation, .lscale = lscale,
- .elocation = elocation, .escale = escale ))),
- weight = eval(substitute(expression({
- temp6 = digamma(r.vec) # , integer=T
- temp5 = digamma(1:max(r.vec)) # , integer=T
- temp5 = matrix(temp5, n, max(r.vec), byrow = TRUE)
- temp5[col(temp5) > r.vec] = 0
- temp5 = temp5 %*% rep(1, ncol(temp5))
- wz = matrix(as.numeric(NA), n, dimm(M = 2)) # 3=dimm(M = 2)
- wz[, iam(1, 1, M)] = r.vec / sigma^2
- wz[, iam(2, 1, M)] = -(1 + r.vec * temp6) / sigma^2
- wz[, iam(2, 2, M)] = (2*(r.vec+1)*temp6 + r.vec*(trigamma(r.vec) +
- temp6^2) + 2 - r.vec - 2*temp5) / sigma^2
- wz[, iam(1, 1, M)] = wz[, iam(1, 1, M)] * dloc.deta^2
- wz[, iam(2, 1, M)] = wz[, iam(2, 1, M)] * dsigma.deta * dloc.deta
- wz[, iam(2, 2, M)] = wz[, iam(2, 2, M)] * dsigma.deta^2
- c(w) * wz
- }), list( .lscale = lscale ))))
+ 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
+ LP = length(Percentiles) # may be 0
+ if (LP > 0) {
+ mpv = extra$mpv
+ mu = matrix(as.numeric(NA), nrow(eta), LP + mpv) # LP may be 0
+ Rvec = extra$R
+ for(ii in 1:LP) {
+ ci = if (is.Numeric(Rvec))
+ Rvec * (1 - Percentiles[ii] / 100) else
+ -log(Percentiles[ii] / 100)
+ mu[,ii] = loc - sigma * log(ci)
+ }
+ if (mpv)
+ mu[,ncol(mu)] = loc - sigma * log(log(2))
+ dmn2 = paste(as.character(Percentiles), "%", sep = "")
+ if (mpv)
+ dmn2 = c(dmn2, "MPV")
+ dimnames(mu) = list(dimnames(eta)[[1]], dmn2)
+ } else {
+ EulerM = -digamma(1)
+ mu = loc + sigma * EulerM
+ }
+ mu
+ }, list( .llocation = llocation, .lscale = lscale,
+ .elocation = elocation, .escale = escale ))),
+ last = eval(substitute(expression({
+ misc$R = .R
+ misc$links = c(location = .llocation, scale = .lscale)
+ misc$earg = list(location= .elocation, scale= .escale )
+ misc$mpv = .mpv
+ misc$true.mu = !length( .percentiles) # @fitted is not a true mu
+ misc$percentiles = .percentiles
+ }), list( .llocation = llocation, .lscale = lscale,
+ .elocation = elocation, .escale = escale,
+ .percentiles = percentiles,
+ .mpv = mpv, .R = R ))),
+ vfamily = c("gumbel", "vextremes"),
+ loglikelihood = eval(substitute(
+ function(mu, y, w, residuals = FALSE, eta, extra = NULL) {
+ loc = eta2theta(eta[, 1], .llocation, earg = .elocation)
+ sigma = eta2theta(eta[, 2], .lscale, earg = .escale )
+ r.vec = rowSums(cbind(!is.na(y)))
+ yiri = y[cbind(1:nrow(y),r.vec)]
+ ans = -r.vec * log(sigma) - exp( -(yiri-loc)/sigma )
+ max.r.vec = max(r.vec)
+ for(jay in 1:max.r.vec) {
+ index = (jay <= r.vec)
+ ans[index] = ans[index] - (y[index,jay]-loc[index]) / sigma[index]
+ }
+ if (residuals) stop("loglikelihood residuals not ",
+ "implemented yet") else {
+
+
+ sum(w * ans)
+ }
+ }, list( .llocation = llocation, .lscale = lscale,
+ .elocation = elocation, .escale = escale ))),
+ deriv = eval(substitute(expression({
+ loc = eta2theta(eta[, 1], .llocation, earg = .elocation)
+ sigma = eta2theta(eta[, 2], .lscale, earg = .escale )
+ r.vec = rowSums(cbind(!is.na(y)))
+ yiri = y[cbind(1:nrow(y),r.vec)]
+ yi.bar = rowMeans(y, na.rm = TRUE)
+ temp2 = (yiri - loc) / sigma
+ term2 = exp(-temp2)
+ dloc.deta = dtheta.deta(loc, .llocation, earg = .elocation)
+ dsigma.deta = dtheta.deta(sigma, .lscale, earg = .escale )
+ dl.dloc = (r.vec - term2) / sigma
+ dl.dsigma = (rowSums((y - loc) / sigma, na.rm = TRUE) - r.vec -
+ temp2 * term2) / sigma
+ c(w) * cbind(dl.dloc * dloc.deta,
+ dl.dsigma * dsigma.deta)
+ }), list( .llocation = llocation, .lscale = lscale,
+ .elocation = elocation, .escale = escale ))),
+ weight = eval(substitute(expression({
+ temp6 = digamma(r.vec) # , integer=T
+ temp5 = digamma(1:max(r.vec)) # , integer=T
+ temp5 = matrix(temp5, n, max(r.vec), byrow = TRUE)
+ temp5[col(temp5) > r.vec] = 0
+ temp5 = temp5 %*% rep(1, ncol(temp5))
+ wz = matrix(as.numeric(NA), n, dimm(M = 2)) # 3=dimm(M = 2)
+ wz[, iam(1, 1, M)] = r.vec / sigma^2
+ wz[, iam(2, 1, M)] = -(1 + r.vec * temp6) / sigma^2
+ wz[, iam(2, 2, M)] = (2*(r.vec+1)*temp6 + r.vec*(trigamma(r.vec) +
+ temp6^2) + 2 - r.vec - 2*temp5) / sigma^2
+ wz[, iam(1, 1, M)] = wz[, iam(1, 1, M)] * dloc.deta^2
+ wz[, iam(2, 1, M)] = wz[, iam(2, 1, M)] * dsigma.deta * dloc.deta
+ wz[, iam(2, 2, M)] = wz[, iam(2, 2, M)] * dsigma.deta^2
+ c(w) * wz
+ }), list( .lscale = lscale ))))
}
rgpd <- function(n, location = 0, scale = 1, shape = 0) {
- use.n = if ((length.n <- length(n)) > 1) length.n else
- if (!is.Numeric(n, integer.valued = TRUE, allowable.length = 1, positive = TRUE))
- stop("bad input for argument 'n'") else n
+ use.n = if ((length.n <- length(n)) > 1) length.n else
+ if (!is.Numeric(n, integer.valued = TRUE,
+ allowable.length = 1, positive = TRUE))
+ stop("bad input for argument 'n'") else n
- if (!is.Numeric(location))
- stop("bad input for argument 'location'")
- if (!is.Numeric(shape))
- stop("bad input for argument 'shape'")
- ans = numeric(use.n)
- shape = rep(shape, length.out = use.n); location = rep(location, length.out = use.n);
- scale = rep(scale, length.out = use.n)
- scase = abs(shape) < sqrt(.Machine$double.eps)
- nscase = sum(scase)
- if (use.n - nscase)
- ans[!scase] = location[!scase] + scale[!scase] *
- ((runif(use.n - nscase))^(-shape[!scase])-1) / shape[!scase]
- if (nscase)
- ans[scase] = location[scase] - scale[scase] * log(runif(nscase))
- ans[scale <= 0] = NaN
- ans
+ if (!is.Numeric(location))
+ stop("bad input for argument 'location'")
+ if (!is.Numeric(shape))
+ stop("bad input for argument 'shape'")
+ ans = numeric(use.n)
+ shape = rep(shape, length.out = use.n);
+ location = rep(location, length.out = use.n);
+ scale = rep(scale, length.out = use.n)
+
+ scase = abs(shape) < sqrt(.Machine$double.eps)
+ nscase = sum(scase)
+ if (use.n - nscase)
+ ans[!scase] = location[!scase] +
+ scale[!scase] *
+ ((runif(use.n - nscase))^(-shape[!scase])-1) / shape[!scase]
+ if (nscase)
+ ans[scase] = location[scase] - scale[scase] * log(runif(nscase))
+ ans[scale <= 0] = NaN
+ ans
}
@@ -1003,7 +1042,8 @@ dgpd <- function(x, location = 0, scale = 1, shape = 0, log = FALSE,
if (!is.Numeric(tolshape0, allowable.length = 1, positive = TRUE))
stop("bad input for argument 'tolshape0'")
L = max(length(x), length(location), length(scale), length(shape))
- shape = rep(shape, length.out = L); location = rep(location, length.out = L);
+ shape = rep(shape, length.out = L);
+ location = rep(location, length.out = L);
scale = rep(scale, length.out = L);
x = rep(x, length.out = L)
@@ -1080,8 +1120,11 @@ qgpd <- function(p, location = 0, scale = 1, shape = 0) {
use.n = max(length(p), length(location), length(scale), length(shape))
ans = numeric(use.n)
- shape = rep(shape, length.out = use.n); location = rep(location, length.out = use.n);
- scale = rep(scale, length.out = use.n); p = rep(p, length.out = use.n)
+ shape = rep(shape, length.out = use.n);
+ location = rep(location, length.out = use.n);
+ scale = rep(scale, length.out = use.n);
+ p = rep(p, length.out = use.n)
+
scase = abs(shape) < sqrt(.Machine$double.eps)
nscase = sum(scase)
if (use.n - nscase) {
@@ -1108,38 +1151,41 @@ qgpd <- function(p, location = 0, scale = 1, shape = 0) {
gpd <- function(threshold = 0,
- lscale = "loge",
- lshape = "logoff",
- escale = list(),
- eshape = if (lshape == "logoff") list(offset = 0.5) else
- if (lshape == "elogit") list(min = -0.5, max = 0.5) else NULL,
- percentiles = c(90,95),
- iscale = NULL,
- ishape = NULL,
- tolshape0 = 0.001, giveWarning = TRUE,
- imethod = 1,
- zero = 2) {
+ lscale = "loge",
+ lshape = "logoff",
+ escale = list(),
+ eshape = if (lshape == "logoff") list(offset = 0.5) else
+ if (lshape == "elogit") list(min = -0.5, max = 0.5) else NULL,
+ percentiles = c(90,95),
+ iscale = NULL,
+ ishape = NULL,
+ tolshape0 = 0.001, giveWarning = TRUE,
+ imethod = 1,
+ zero = 2) {
if (!is.logical(giveWarning) || length(giveWarning) != 1)
stop("bad input for argument 'giveWarning'")
if (!is.Numeric(threshold))
stop("bad input for argument 'threshold'")
- if (!is.Numeric(imethod, allowable.length = 1, positive = TRUE, integer.valued = TRUE) ||
+ if (!is.Numeric(imethod, allowable.length = 1,
+ positive = TRUE, integer.valued = TRUE) ||
imethod > 2.5)
- stop("argument 'imethod' must be 1 or 2")
+ stop("argument 'imethod' must be 1 or 2")
if (mode(lscale) != "character" && mode(lscale) != "name")
- lscale = as.character(substitute(lscale))
+ lscale = as.character(substitute(lscale))
if (mode(lshape) != "character" && mode(lshape) != "name")
- lshape = as.character(substitute(lshape))
+ lshape = as.character(substitute(lshape))
if (length(percentiles) &&
(!is.Numeric(percentiles, positive = TRUE) ||
max(percentiles) >= 100))
- stop("bad input for argument 'percentiles'")
- if (!is.Numeric(tolshape0, allowable.length = 1, positive = TRUE) || tolshape0 > 0.1)
- stop("bad input for argument 'tolshape0'")
- if (length(zero) && !is.Numeric(zero, integer.valued = TRUE, positive = TRUE))
- stop("bad input for argument 'zero'")
+ stop("bad input for argument 'percentiles'")
+ if (!is.Numeric(tolshape0, allowable.length = 1, positive = TRUE) ||
+ tolshape0 > 0.1)
+ stop("bad input for argument 'tolshape0'")
+ if (length(zero) &&
+ !is.Numeric(zero, integer.valued = TRUE, positive = TRUE))
+ stop("bad input for argument 'zero'")
if (!is.list(escale)) escale = list()
if (!is.list(eshape)) eshape = list()
@@ -1405,129 +1451,134 @@ setMethod("guplot", "vlm",
R=NA, percentiles = c(95,99),
mpv = FALSE, 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.logical(mpv) || length(mpv) != 1)
- stop("bad input for argument 'mpv'")
- if (length(percentiles) &&
- (!is.Numeric(percentiles, positive = TRUE) || max(percentiles) >= 100))
- stop("bad input for argument 'percentiles'")
- if (length(zero) && !is.Numeric(zero, integer.valued = TRUE, positive = TRUE))
- stop("bad input for argument 'zero'")
- if (length(iscale) && !is.Numeric(iscale, positive = TRUE))
- stop("bad input for argument 'iscale'")
- if (!is.list(elocation)) elocation = list()
- if (!is.list(escale)) escale = list()
+ 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.logical(mpv) || length(mpv) != 1)
+ stop("bad input for argument 'mpv'")
+ if (length(percentiles) &&
+ (!is.Numeric(percentiles, positive = TRUE) ||
+ max(percentiles) >= 100))
+ stop("bad input for argument 'percentiles'")
+ if (length(zero) &&
+ !is.Numeric(zero, integer.valued = TRUE, positive = TRUE))
+ stop("bad input for argument 'zero'")
+ if (length(iscale) && !is.Numeric(iscale, positive = TRUE))
+ stop("bad input for argument 'iscale'")
- new("vglmff",
- blurb = c("Gumbel distribution (univariate response)\n\n",
- "Links: ",
- namesof("location", llocation, earg = elocation, tag = TRUE), ", ",
- namesof("scale", lscale, earg = escale , tag = TRUE), "\n",
- "Mean: location + scale*0.5772..\n",
- "Variance: pi^2 * scale^2 / 6"),
- constraints=eval(substitute(expression({
- constraints = cm.zero.vgam(constraints, x, .zero, M)
- }), list( .zero = zero ))),
- initialize = eval(substitute(expression({
- y = cbind(y)
- if (ncol(y) > 1)
- stop("Use gumbel() to handle multivariate responses")
- if (min(y) <= 0)
- stop("all response values must be positive")
- predictors.names =
- c(namesof("location", .llocation, earg = .elocation, tag = FALSE),
- namesof("scale", .lscale, earg = .escale , tag = FALSE))
+ if (!is.list(elocation)) elocation = list()
+ if (!is.list(escale)) escale = list()
- extra$R = .R
- extra$mpv = .mpv
- extra$percentiles = .percentiles
+ new("vglmff",
+ blurb = c("Gumbel distribution (univariate response)\n\n",
+ "Links: ",
+ namesof("location", llocation,
+ earg = elocation, tag = TRUE), ", ",
+ namesof("scale", lscale, earg = escale , tag = TRUE), "\n",
+ "Mean: location + scale*0.5772..\n",
+ "Variance: pi^2 * scale^2 / 6"),
+ constraints=eval(substitute(expression({
+ constraints = cm.zero.vgam(constraints, x, .zero, M)
+ }), list( .zero = zero ))),
+ initialize = eval(substitute(expression({
+ y = cbind(y)
+ if (ncol(y) > 1)
+ stop("Use gumbel() to handle multivariate responses")
+ if (min(y) <= 0)
+ stop("all response values must be positive")
+ predictors.names =
+ c(namesof("location", .llocation, earg = .elocation, tag = FALSE),
+ namesof("scale", .lscale, earg = .escale , tag = FALSE))
- if (!length(etastart)) {
- sc.init = if (is.Numeric( .iscale, positive = TRUE))
- .iscale else 1.5 * (0.01+sqrt(var(y)*6)) / pi
- sc.init = rep(sc.init, length.out = n)
- EulerM = -digamma(1)
- loc.init = (y - sc.init * EulerM)
- etastart = cbind(theta2eta(loc.init, .llocation, earg = .elocation),
- theta2eta(sc.init, .lscale, earg = .escale ))
- }
- }), list( .llocation = llocation, .lscale = lscale, .iscale = iscale,
- .elocation=elocation, .escale = escale,
- .R=R, .mpv=mpv, .percentiles = percentiles ))),
- linkinv = eval(substitute( function(eta, extra = NULL) {
- loc = eta2theta(eta[, 1], .llocation, earg = .elocation)
- sigma = eta2theta(eta[, 2], .lscale, earg = .escale )
+ extra$R = .R
+ extra$mpv = .mpv
+ extra$percentiles = .percentiles
+
+ if (!length(etastart)) {
+ sc.init = if (is.Numeric( .iscale, positive = TRUE))
+ .iscale else 1.5 * (0.01+sqrt(var(y)*6)) / pi
+ sc.init = rep(sc.init, length.out = n)
EulerM = -digamma(1)
- Percentiles = extra$percentiles
- mpv = extra$mpv
- LP = length(Percentiles) # may be 0
- if (!LP) return(loc + sigma * EulerM)
- mu = matrix(as.numeric(NA), nrow(eta), LP + mpv)
- Rvec = extra$R
- if (1 <= LP)
- for(ii in 1:LP) {
- ci = if (is.Numeric(Rvec)) Rvec * (1 - Percentiles[ii] / 100) else
- -log( Percentiles[ii] / 100)
- mu[,ii] = loc - sigma * log(ci)
- }
- if (mpv)
- mu[,ncol(mu)] = loc - sigma * log(log(2))
- dmn2 = if (LP >= 1) paste(as.character(Percentiles), "%",
- sep = "") else NULL
- if (mpv)
- dmn2 = c(dmn2, "MPV")
- dimnames(mu) = list(dimnames(eta)[[1]], dmn2)
- mu
- }, list( .llocation = llocation, .lscale = lscale,
- .elocation=elocation, .escale = escale ))),
- last = eval(substitute(expression({
- misc$link = c(location= .llocation, scale = .lscale)
- misc$earg = list(location= .elocation, scale= .escale)
- misc$true.mu = !length( .percentiles) # @fitted is not a true mu
- misc$R = .R
- misc$mpv = .mpv
- misc$percentiles = .percentiles
- }), list( .llocation = llocation, .lscale = lscale, .mpv=mpv,
- .elocation=elocation, .escale = escale,
- .R=R, .percentiles = percentiles ))),
- loglikelihood = eval(substitute(
- function(mu,y,w,residuals= FALSE,eta,extra = NULL) {
- loc = eta2theta(eta[, 1], .llocation, earg = .elocation)
- sc = eta2theta(eta[, 2], .lscale, earg = .escale )
- if (residuals) stop("loglikelihood residuals not ",
- "implemented yet") else {
- sum(w * dgumbel(x=y, location = loc, scale=sc, log = TRUE))
- }
- }, list( .llocation = llocation, .lscale = lscale,
- .elocation=elocation, .escale = escale ))),
- vfamily = "egumbel",
- deriv = eval(substitute(expression({
- loc = eta2theta(eta[, 1], .llocation, earg = .elocation)
- sc = eta2theta(eta[, 2], .lscale, earg = .escale )
- zedd = (y-loc) / sc
- temp2 = -expm1(-zedd)
- dl.dloc = temp2 / sc
- dl.dsc = -1/sc + temp2 * zedd / sc
- dloc.deta = dtheta.deta(loc, .llocation, earg = .elocation)
- dsc.deta = dtheta.deta(sc, .lscale, earg = .escale )
- c(w) * cbind(dl.dloc * dloc.deta,
- dl.dsc * dsc.deta)
- }), list( .llocation = llocation, .lscale = lscale,
- .elocation=elocation, .escale = escale ))),
- weight=expression({
- digamma1 = digamma(1)
- ed2l.dsc2 = ((2+digamma1)*digamma1 + trigamma(1) + 1) / sc^2
- ed2l.dloc2 = 1 / sc^2
- ed2l.dscloc = -(1 + digamma1) / sc^2
- wz = matrix(as.numeric(NA), n, dimm(M = 2))
- wz[, iam(1, 1, M)] = ed2l.dloc2 * dloc.deta^2
- wz[, iam(2, 2, M)] = ed2l.dsc2 * dsc.deta^2
- wz[, iam(1, 2, M)] = ed2l.dscloc * dloc.deta * dsc.deta
- c(w) * wz
- }))
+ loc.init = (y - sc.init * EulerM)
+ etastart = cbind(theta2eta(loc.init, .llocation, earg = .elocation),
+ theta2eta(sc.init, .lscale, earg = .escale ))
+ }
+ }), list( .llocation = llocation, .lscale = lscale,
+ .elocation = elocation, .escale = escale,
+ .iscale = iscale,
+ .R = R, .mpv = mpv, .percentiles = percentiles ))),
+ linkinv = eval(substitute( function(eta, extra = NULL) {
+ loc = eta2theta(eta[, 1], .llocation, earg = .elocation)
+ sigma = eta2theta(eta[, 2], .lscale, earg = .escale )
+ EulerM = -digamma(1)
+ Percentiles = extra$percentiles
+ mpv = extra$mpv
+ LP = length(Percentiles) # may be 0
+ if (!LP) return(loc + sigma * EulerM)
+ mu = matrix(as.numeric(NA), nrow(eta), LP + mpv)
+ Rvec = extra$R
+ if (1 <= LP)
+ for(ii in 1:LP) {
+ ci = if (is.Numeric(Rvec)) Rvec * (1 - Percentiles[ii] / 100) else
+ -log(Percentiles[ii] / 100)
+ mu[,ii] = loc - sigma * log(ci)
+ }
+ if (mpv)
+ mu[, ncol(mu)] = loc - sigma * log(log(2))
+ dmn2 = if (LP >= 1) paste(as.character(Percentiles), "%",
+ sep = "") else NULL
+ if (mpv)
+ dmn2 = c(dmn2, "MPV")
+ dimnames(mu) = list(dimnames(eta)[[1]], dmn2)
+ mu
+ }, list( .llocation = llocation, .lscale = lscale,
+ .elocation = elocation, .escale = escale ))),
+ last = eval(substitute(expression({
+ misc$link = c(location= .llocation, scale = .lscale)
+ misc$earg = list(location= .elocation, scale= .escale)
+ misc$true.mu = !length( .percentiles) # @fitted is not a true mu
+ misc$R = .R
+ misc$mpv = .mpv
+ misc$percentiles = .percentiles
+ }), list( .llocation = llocation, .lscale = lscale, .mpv = mpv,
+ .elocation = elocation, .escale = escale,
+ .R = R, .percentiles = percentiles ))),
+ loglikelihood = eval(substitute(
+ function(mu,y,w,residuals= FALSE,eta,extra = NULL) {
+ loc = eta2theta(eta[, 1], .llocation, earg = .elocation)
+ sc = eta2theta(eta[, 2], .lscale, earg = .escale )
+ if (residuals) stop("loglikelihood residuals not ",
+ "implemented yet") else {
+ sum(w * dgumbel(x=y, location = loc, scale=sc, log = TRUE))
+ }
+ }, list( .llocation = llocation, .lscale = lscale,
+ .elocation = elocation, .escale = escale ))),
+ vfamily = "egumbel",
+ deriv = eval(substitute(expression({
+ loc = eta2theta(eta[, 1], .llocation, earg = .elocation)
+ sc = eta2theta(eta[, 2], .lscale, earg = .escale )
+ zedd = (y-loc) / sc
+ temp2 = -expm1(-zedd)
+ dl.dloc = temp2 / sc
+ dl.dsc = -1/sc + temp2 * zedd / sc
+ dloc.deta = dtheta.deta(loc, .llocation, earg = .elocation)
+ dsc.deta = dtheta.deta(sc, .lscale, earg = .escale )
+ c(w) * cbind(dl.dloc * dloc.deta,
+ dl.dsc * dsc.deta)
+ }), list( .llocation = llocation, .lscale = lscale,
+ .elocation = elocation, .escale = escale ))),
+ weight=expression({
+ digamma1 = digamma(1)
+ ed2l.dsc2 = ((2+digamma1)*digamma1 + trigamma(1) + 1) / sc^2
+ ed2l.dloc2 = 1 / sc^2
+ ed2l.dscloc = -(1 + digamma1) / sc^2
+ wz = matrix(as.numeric(NA), n, dimm(M = 2))
+ wz[, iam(1, 1, M)] = ed2l.dloc2 * dloc.deta^2
+ wz[, iam(2, 2, M)] = ed2l.dsc2 * dsc.deta^2
+ wz[, iam(1, 2, M)] = ed2l.dscloc * dloc.deta * dsc.deta
+ c(w) * wz
+ }))
}
@@ -1539,48 +1590,50 @@ setMethod("guplot", "vlm",
escale = list(), iscale = NULL,
mean = TRUE, percentiles = NULL, zero = 2)
{
- 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.logical(mean) || length(mean) != 1)
- stop("mean must be a single logical value")
- if (!mean && (!is.Numeric(percentiles, positive = TRUE) ||
- any(percentiles>=100)))
- stop("valid percentiles values must be given when mean = FALSE")
- if (length(zero) && !is.Numeric(zero, integer.valued = TRUE, positive = TRUE))
- stop("bad input for argument 'zero'")
- if (!is.list(elocation)) elocation = list()
- if (!is.list(escale)) escale = list()
-
- new("vglmff",
- blurb = c("Censored Gumbel distribution\n\n",
- "Links: ",
- namesof("location", llocation, earg = elocation, tag = TRUE), ", ",
- namesof("scale", lscale, earg = escale, tag = TRUE),
- "\n",
- "Mean: location + scale*0.5772..\n",
- "Variance: pi^2 * scale^2 / 6"),
- constraints=eval(substitute(expression({
- constraints = cm.zero.vgam(constraints, x, .zero, M)
- }), list( .zero = zero ))),
- initialize = eval(substitute(expression({
- y = cbind(y)
- if (ncol(y) > 1)
- stop("Use gumbel.block() to handle multivariate responses")
- if (any(y) <= 0)
- stop("all response values must be positive")
+ 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.logical(mean) || length(mean) != 1)
+ stop("mean must be a single logical value")
+ if (!mean && (!is.Numeric(percentiles, positive = TRUE) ||
+ any(percentiles >= 100)))
+ stop("valid percentiles values must be given when mean = FALSE")
+ if (length(zero) &&
+ !is.Numeric(zero, integer.valued = TRUE, positive = TRUE))
+ stop("bad input for argument 'zero'")
+ if (!is.list(elocation)) elocation = list()
+ if (!is.list(escale)) escale = list()
- if (!length(extra$leftcensored))
- extra$leftcensored = rep(FALSE, length.out = n)
- if (!length(extra$rightcensored))
- extra$rightcensored = rep(FALSE, length.out = n)
- if (any(extra$rightcensored & extra$leftcensored))
- stop("some observations are both right and left censored!")
+ new("vglmff",
+ blurb = c("Censored Gumbel distribution\n\n",
+ "Links: ",
+ namesof("location", llocation, earg = elocation, tag = TRUE),
+ ", ",
+ namesof("scale", lscale, earg = escale, tag = TRUE),
+ "\n",
+ "Mean: location + scale*0.5772..\n",
+ "Variance: pi^2 * scale^2 / 6"),
+ constraints=eval(substitute(expression({
+ constraints = cm.zero.vgam(constraints, x, .zero, M)
+ }), list( .zero = zero ))),
+ initialize = eval(substitute(expression({
+ y = cbind(y)
+ if (ncol(y) > 1)
+ stop("Use gumbel.block() to handle multivariate responses")
+ if (any(y) <= 0)
+ stop("all response values must be positive")
+
+ if (!length(extra$leftcensored))
+ extra$leftcensored = rep(FALSE, length.out = n)
+ if (!length(extra$rightcensored))
+ extra$rightcensored = rep(FALSE, length.out = n)
+ if (any(extra$rightcensored & extra$leftcensored))
+ stop("some observations are both right and left censored!")
- predictors.names =
- c(namesof("location", .llocation, earg = .elocation, tag = FALSE),
- namesof("scale", .lscale, earg = .escale , tag = FALSE))
+ predictors.names =
+ c(namesof("location", .llocation, earg = .elocation, tag = FALSE),
+ namesof("scale", .lscale, earg = .escale , tag = FALSE))
if (!length(etastart)) {
sc.init = if (is.Numeric( .iscale, positive = TRUE))
@@ -1715,8 +1768,10 @@ dfrechet <- function(x, location = 0, scale = 1, shape, log = FALSE) {
rm(log)
L = max(length(x), length(scale), length(shape), length(location))
- x = rep(x, length.out = L); scale = rep(scale, length.out = L);
- shape = rep(shape, length.out = L); location = rep(location, length.out = L);
+ x = rep(x, length.out = L);
+ scale = rep(scale, length.out = L);
+ shape = rep(shape, length.out = L);
+ location = rep(location, length.out = L);
logdensity = rep(log(0), length.out = L)
xok = (x > location)
@@ -1838,7 +1893,8 @@ frechet2.control <- function(save.weight = TRUE, ...)
y = y, x = x, w = w, maximize = FALSE,
abs.arg = TRUE)
- shape.init = if (length( .ishape )) rep( .ishape, length.out = n) else {
+ shape.init = if (length( .ishape ))
+ rep( .ishape, length.out = n) else {
rep(try.this, length.out = n) # variance exists if shape > 2
}
@@ -1848,7 +1904,8 @@ frechet2.control <- function(save.weight = TRUE, ...)
myquant = (-log(myprobs))^(-1/shape.init[1])
myfit = lsfit(x = myquant, y = myobsns)
- Scale.init = if (length( .iscale)) rep( .iscale, length.out = n) else {
+ Scale.init = if (length( .iscale))
+ rep( .iscale, length.out = n) else {
if (all(shape.init > 1)) {
myfit$coef[2]
} else {
@@ -2011,7 +2068,8 @@ if (FALSE)
namesof("scale", .lscale, earg = .escale, short = TRUE),
namesof("shape", .lshape, earg = .eshape, short = TRUE))
- anchorpt = if (is.Numeric( .anchor, allowable.length = 1)) .anchor else min(y)
+ anchorpt = if (is.Numeric( .anchor, allowable.length = 1))
+ .anchor else min(y)
if (min(y) < anchorpt)
stop("anchor point is too large")
extra$LHSanchor = anchorpt
@@ -2035,8 +2093,10 @@ if (FALSE)
print("try.this")
print( try.this )
- shape.init = if (length( .ishape )) rep( .ishape, length.out = n) else {
- rep(try.this, length.out = n) # variance exists if shape > 2
+ shape.init =
+ if (length( .ishape ))
+ rep( .ishape, length.out = n) else {
+ rep(try.this, length.out = n) # variance exists if shape > 2
}
@@ -2062,7 +2122,8 @@ if (FALSE)
}
- locinit = if (length( .ilocation)) rep( .ilocation, length.out = n) else {
+ locinit = if (length( .ilocation))
+ rep( .ilocation, length.out = n) else {
if (myfit$coef[1] < min(y)) {
print("using myfit$coef[1] for initial location")
print( myfit$coef[1] )
@@ -2223,48 +2284,49 @@ recnormal1.control <- function(save.weight = TRUE, ...)
recnormal1 <- function(lmean = "identity", lsd = "loge",
imean = NULL, isd = NULL, imethod = 1, zero = NULL)
{
+ if (mode(lmean) != "character" && mode(lmean) != "name")
+ lmean = as.character(substitute(lmean))
+ if (mode(lsd) != "character" && mode(lsd) != "name")
+ lsd = as.character(substitute(lsd))
+ if (!is.Numeric(imethod, allowable.length = 1,
+ integer.valued = TRUE, positive = TRUE) ||
+ imethod > 3.5)
+ stop("argument 'imethod' must be 1 or 2 or 3")
- if (mode(lmean) != "character" && mode(lmean) != "name")
- lmean = as.character(substitute(lmean))
- if (mode(lsd) != "character" && mode(lsd) != "name")
- lsd = as.character(substitute(lsd))
- if (!is.Numeric(imethod, allowable.length = 1, integer.valued = TRUE, positive = TRUE) ||
- imethod > 3.5)
- stop("argument 'imethod' must be 1 or 2 or 3")
-
- new("vglmff",
- blurb = c("Upper record values from a univariate normal distribution\n\n",
- "Links: ",
- namesof("mean", lmean, tag = TRUE), "; ",
- namesof("sd", lsd, tag = TRUE),
- "\n",
- "Variance: sd^2"),
- constraints=eval(substitute(expression({
- constraints = cm.zero.vgam(constraints, x, .zero, M)
- }), list( .zero = zero ))),
- initialize = eval(substitute(expression({
- predictors.names = c(namesof("mean", .lmean, tag = FALSE),
- namesof("sd", .lsd, tag = FALSE))
+ new("vglmff",
+ blurb = c("Upper record values from a univariate normal distribution\n\n",
+ "Links: ",
+ namesof("mean", lmean, tag = TRUE), "; ",
+ namesof("sd", lsd, tag = TRUE),
+ "\n",
+ "Variance: sd^2"),
+ constraints=eval(substitute(expression({
+ constraints = cm.zero.vgam(constraints, x, .zero, M)
+ }), list( .zero = zero ))),
+ initialize = eval(substitute(expression({
+ predictors.names = c(namesof("mean", .lmean, 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 (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))
- warning("weights should have unit values only")
- if (!length(etastart)) {
- mean.init = if (length( .imean)) rep( .imean, length.out = n) else {
- if (.lmean == "loge") pmax(1/1024, min(y)) else min(y)}
- sd.init = if (length( .isd)) rep( .isd, length.out = n) else {
- 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,
+ if (any(diff(y) <= 0))
+ stop("response must have increasingly larger and larger values")
+ if (any(w != 1))
+ warning("weights should have unit values only")
+ if (!length(etastart)) {
+ mean.init = if (length( .imean)) rep( .imean ,
+ length.out = n) else {
+ if (.lmean == "loge") pmax(1/1024, min(y)) else min(y)}
+ sd.init = if (length( .isd)) rep( .isd, length.out = n) else {
+ 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 ))),
linkinv = eval(substitute(function(eta, extra = NULL) {
eta2theta(eta[, 1], .lmean)
@@ -2280,45 +2342,45 @@ recnormal1.control <- function(save.weight = TRUE, ...)
"implemented yet") else {
zedd = (y - mu) / sd
NN = nrow(eta)
- sum(w * (-log(sd) - 0.5 * zedd^2)) -
- sum(w[-NN] * pnorm(zedd[-NN], lower.tail = FALSE, log.p = TRUE))
- }
- }, list( .lsd = lsd ))),
- vfamily = c("recnormal1"),
- deriv = eval(substitute(expression({
- NN = nrow(eta)
- mymu = eta2theta(eta[, 1], .lmean)
- sd = eta2theta(eta[, 2], .lsd)
- zedd = (y - mymu) / sd
- temp200 = dnorm(zedd) / (1-pnorm(zedd))
- dl.dmu = (zedd - temp200) / sd
- dl.dmu[NN] = zedd[NN] / sd[NN]
- dl.dsd = (-1 + zedd^2 - zedd * temp200) / sd
- dl.dsd[NN] = (-1 + zedd[NN]^2) / sd[NN]
- dmu.deta = dtheta.deta(mymu, .lmean)
- dsd.deta = dtheta.deta(sd, .lsd)
- if (iter == 1) {
- etanew = eta
- } else {
- derivold = derivnew
- etaold = etanew
- etanew = eta
- }
- derivnew = c(w) * cbind(dl.dmu * dmu.deta,
- dl.dsd * dsd.deta)
- derivnew
+ sum(w * (-log(sd) - 0.5 * zedd^2)) -
+ sum(w[-NN] * pnorm(zedd[-NN], lower.tail = FALSE, log.p = TRUE))
+ }
+ }, list( .lsd = lsd ))),
+ vfamily = c("recnormal1"),
+ deriv = eval(substitute(expression({
+ NN = nrow(eta)
+ mymu = eta2theta(eta[, 1], .lmean)
+ sd = eta2theta(eta[, 2], .lsd)
+ zedd = (y - mymu) / sd
+ temp200 = dnorm(zedd) / (1-pnorm(zedd))
+ dl.dmu = (zedd - temp200) / sd
+ dl.dmu[NN] = zedd[NN] / sd[NN]
+ dl.dsd = (-1 + zedd^2 - zedd * temp200) / sd
+ dl.dsd[NN] = (-1 + zedd[NN]^2) / sd[NN]
+ dmu.deta = dtheta.deta(mymu, .lmean)
+ dsd.deta = dtheta.deta(sd, .lsd)
+ if (iter == 1) {
+ etanew = eta
+ } else {
+ derivold = derivnew
+ etaold = etanew
+ etanew = eta
+ }
+ derivnew = c(w) * cbind(dl.dmu * dmu.deta,
+ dl.dsd * dsd.deta)
+ derivnew
}), list( .lmean = lmean, .lsd = lsd ))),
- weight=expression({
- if (iter == 1) {
- 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,
- trace=trace) # weights incorporated in args
- }
- wznew
- }))
+ weight = expression({
+ if (iter == 1) {
+ 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,
+ trace=trace) # weights incorporated in args
+ }
+ wznew
+ }))
}
@@ -2354,12 +2416,15 @@ recexp1.control <- function(save.weight = TRUE, ...)
if (any(w != 1))
warning("weights should have unit values only")
if (!length(etastart)) {
- rate.init = if (length( .irate)) rep( .irate, len = n) else {
+ rate.init = if (length( .irate))
+ rep( .irate, len = n) else {
init.rate =
if (.imethod == 1) length(y) / y[length(y), 1] else
if (.imethod == 2) 1/mean(y) else 1/median(y)
- if (.lrate == "loge") pmax(1/1024, init.rate) else init.rate}
- etastart = cbind(theta2eta(rep(rate.init, len = n), .lrate))
+ if (.lrate == "loge") pmax(1/1024, init.rate) else
+ init.rate}
+ etastart =
+ cbind(theta2eta(rep(rate.init, len = n), .lrate))
}
}), list( .lrate = lrate, .irate = irate, .imethod = imethod ))),
linkinv = eval(substitute(function(eta, extra = NULL) {
@@ -2406,19 +2471,24 @@ recexp1.control <- function(save.weight = TRUE, ...)
poissonp <- function(ostatistic, dimension = 2,
link = "loge", earg = list(),
idensity = NULL, imethod = 1) {
- if (!is.Numeric(ostatistic, positive = TRUE, allowable.length = 1, integer.valued = TRUE))
- stop("argument 'ostatistic' must be a single positive integer")
- if (!is.Numeric(dimension, positive = TRUE, allowable.length = 1, integer.valued = TRUE) ||
- dimension > 3)
- stop("argument 'dimension' must be 2 or 3")
+ if (!is.Numeric(ostatistic, positive = TRUE,
+ allowable.length = 1, integer.valued = TRUE))
+ stop("argument 'ostatistic' must be a single positive integer")
+ if (!is.Numeric(dimension, positive = TRUE,
+ allowable.length = 1, integer.valued = TRUE) ||
+ dimension > 3)
+ stop("argument 'dimension' must be 2 or 3")
if (mode(link) != "character" && mode(link) != "name")
- link = as.character(substitute(link))
+ link = as.character(substitute(link))
+
if (!is.list(earg)) earg = list()
- if (!is.Numeric(imethod, allowable.length = 1, positive = TRUE, integer.valued = TRUE) ||
- imethod > 2.5)
- stop("argument 'imethod' must be 1 or 2")
- if (length(idensity) && !is.Numeric(idensity, positive = TRUE))
- stop("bad input for argument 'idensity'")
+ if (!is.Numeric(imethod, allowable.length = 1,
+ positive = TRUE, integer.valued = TRUE) ||
+ imethod > 2.5)
+ stop("argument 'imethod' must be 1 or 2")
+ if (length(idensity) &&
+ !is.Numeric(idensity, positive = TRUE))
+ stop("bad input for argument 'idensity'")
new("vglmff",
blurb = c(if (dimension == 2)
@@ -2434,18 +2504,21 @@ recexp1.control <- function(save.weight = TRUE, ...)
stop("response must be a vector or a one-column matrix")
if (any(y <= 0))
stop("response must contain positive values only")
- predictors.names = namesof("density", .link, earg = .earg, tag = FALSE)
+ predictors.names =
+ namesof("density", .link, earg = .earg, tag = FALSE)
if (!length(etastart)) {
use.this = if ( .imethod == 1) median(y) + 1/8 else
weighted.mean(y,w)
if ( .dimension == 2) {
- myratio = exp(lgamma( .ostatistic +0.5) - lgamma( .ostatistic ))
+ myratio = exp(lgamma( .ostatistic + 0.5) -
+ lgamma( .ostatistic ))
density.init = if (is.Numeric( .idensity ))
rep( .idensity, len = n) else
rep(myratio^2 / (pi * use.this^2), len = n)
etastart = theta2eta(density.init, .link, earg = .earg)
} else {
- myratio = exp(lgamma( .ostatistic +1/3) - lgamma( .ostatistic ))
+ myratio = exp(lgamma( .ostatistic +1/3) -
+ lgamma( .ostatistic ))
density.init = if (is.Numeric( .idensity ))
rep( .idensity, len = n) else
rep(3 * myratio^3 / (4 * pi * use.this^3), len = n)
diff --git a/R/family.functions.R b/R/family.functions.R
index 21e8086..42e608f 100644
--- a/R/family.functions.R
+++ b/R/family.functions.R
@@ -37,32 +37,33 @@ remove.arg <- function(string)
add.arg <- function(string, arg.string)
{
- if (arg.string == "")
- return(string)
- nc <- nchar(string)
- lastc <- substring(string, nc, nc)
- if (lastc == ")")
- {
- if (substring(string, nc-1, nc-1) == "(")
- {
- paste(substring(string, 1, nc-2), "(", arg.string, ")", sep = "")
- } else
- paste(substring(string, 1, nc-1), ", ", arg.string, ")", sep = "")
+ if (arg.string == "")
+ return(string)
+ nc <- nchar(string)
+ lastc <- substring(string, nc, nc)
+ if (lastc == ")") {
+ if (substring(string, nc-1, nc-1) == "(") {
+ paste(substring(string, 1, nc-2), "(", arg.string, ")",
+ sep = "")
} else
- paste(string, "(", arg.string, ")", sep = "")
+ paste(substring(string, 1, nc-1), ", ", arg.string, ")",
+ sep = "")
+ } else {
+ paste(string, "(", arg.string, ")", sep = "")
+ }
}
get.arg <- function(string)
{
- nc <- nchar(string)
- bits <- substring(string, 1:nc, 1:nc)
- b1 <- (1:nc)[bits == "("]
- b2 <- (1:nc)[bits == ")"]
- b1 <- if (length(b1)) min(b1) else return("") # stop('no "(" in string')
- b2 <- if (length(b2)) max(b2) else return("") # stop('no ")" in string')
- if (b2-b1 == 1) "" else paste(bits[(1+b1):(b2-1)], collapse = "")
+ nc <- nchar(string)
+ bits <- substring(string, 1:nc, 1:nc)
+ b1 <- (1:nc)[bits == "("]
+ b2 <- (1:nc)[bits == ")"]
+ b1 <- if (length(b1)) min(b1) else return("") # stop('no "(" in string')
+ b2 <- if (length(b2)) max(b2) else return("") # stop('no ")" in string')
+ if (b2-b1 == 1) "" else paste(bits[(1+b1):(b2-1)], collapse = "")
}
@@ -85,18 +86,20 @@ eij = function(i, n) {
dneg.binomial <- function(x, k, prob)
{
- care.exp(x * log1p(-prob) + k * log(prob) + lgamma(x+k) - lgamma(k) -
- lgamma(x+1))
+ care.exp(x * log1p(-prob) + k * log(prob) + lgamma(x+k) -
+ lgamma(k) - lgamma(x + 1))
}
-tapplymat1 <- function(mat, function.arg = c("cumsum", "diff", "cumprod"))
+tapplymat1 <- function(mat,
+ function.arg = c("cumsum", "diff", "cumprod"))
{
if (!missing(function.arg))
function.arg <- as.character(substitute(function.arg))
- function.arg <- match.arg(function.arg, c("cumsum", "diff", "cumprod"))[1]
+ function.arg <- match.arg(function.arg,
+ c("cumsum", "diff", "cumprod"))[1]
type <- switch(function.arg,
cumsum = 1,
@@ -178,7 +181,7 @@ rss.vgam <- function(z, wz, M)
if (M == 1)
return(sum(c(wz) * c(z^2)))
- wz.z <- mux22(t(wz), z, M = M, as.matrix = TRUE) # else mux2(wz, z)
+ wz.z <- mux22(t(wz), z, M = M, as.matrix = TRUE)
ans <- sum(wz.z * z)
ans
}
@@ -196,7 +199,7 @@ wweighted.mean <- function(y, w = NULL, matrix.arg = TRUE)
if (missing(w)) mean(y) else sum(w * y)/sum(w)
} else {
if (missing(w)) y %*% rep(1, n) else {
- numer <- mux22(t(w), y, M, as.matrix = TRUE) # matrix.arg = matrix.arg,
+ numer <- mux22(t(w), y, M, as.matrix = TRUE)
numer <- t(numer) %*% rep(1, n)
denom <- t(w) %*% rep(1, n)
denom <- matrix(denom, 1, length(denom))
@@ -233,7 +236,8 @@ veigen <- function(x, M)
error.code = integer(1))
if (z$error.code)
- stop("eigen algorithm (rs) returned error code ", z$error.code)
+ stop("eigen algorithm (rs) returned error code ",
+ z$error.code)
ord <- M:1
dim(z$values) <- c(M, n)
z$values <- z$values[ord,,drop = FALSE]
@@ -259,12 +263,16 @@ ima <- function(j, k, M)
-checkwz <- function(wz, M, trace = FALSE, wzepsilon = .Machine$double.eps^0.75) {
- if (wzepsilon > 0.5) warning("'wzepsilon' is probably too large")
- if (!is.matrix(wz)) wz = as.matrix(wz)
- if ((temp <- sum(wz[,1:M,drop = FALSE] < wzepsilon)))
- warning(paste(temp, "elements replaced by", signif(wzepsilon, 5)))
- wz[,1:M] = pmax(wzepsilon, wz[,1:M])
+checkwz <- function(wz, M, trace = FALSE,
+ wzepsilon = .Machine$double.eps^0.75) {
+ if (wzepsilon > 0.5)
+ warning("'wzepsilon' is probably too large")
+ if (!is.matrix(wz))
+ wz = as.matrix(wz)
+ if ((temp <- sum(wz[, 1:M, drop = FALSE] < wzepsilon)))
+ warning(paste(temp, "elements replaced by",
+ signif(wzepsilon, 5)))
+ wz[, 1:M] = pmax(wzepsilon, wz[, 1:M])
wz
}
diff --git a/R/family.glmgam.R b/R/family.glmgam.R
index f001b4f..7be170b 100644
--- a/R/family.glmgam.R
+++ b/R/family.glmgam.R
@@ -392,20 +392,23 @@
dinv.gaussian = function(x, mu, lambda, log = FALSE) {
- if (!is.logical(log.arg <- log))
- stop("bad input for argument 'log'")
- rm(log)
-
- LLL = max(length(x), length(mu), length(lambda))
- x = rep(x, len = LLL); mu = rep(mu, len = LLL); lambda = rep(lambda, len = LLL)
- logdensity = rep(log(0), len = LLL)
- xok = (x > 0)
- logdensity[xok] = 0.5 * log(lambda[xok] / (2 * pi * x[xok]^3)) -
- lambda[xok] *
- (x[xok]-mu[xok])^2 / (2*mu[xok]^2 * x[xok])
- logdensity[mu <= 0] = NaN
- logdensity[lambda <= 0] = NaN
- if (log.arg) logdensity else exp(logdensity)
+ if (!is.logical(log.arg <- log))
+ stop("bad input for argument 'log'")
+ rm(log)
+
+ LLL = max(length(x), length(mu), length(lambda))
+ x = rep(x, len = LLL);
+ mu = rep(mu, len = LLL);
+ lambda = rep(lambda, len = LLL)
+ logdensity = rep(log(0), len = LLL)
+
+ xok = (x > 0)
+ logdensity[xok] = 0.5 * log(lambda[xok] / (2 * pi * x[xok]^3)) -
+ lambda[xok] *
+ (x[xok]-mu[xok])^2 / (2*mu[xok]^2 * x[xok])
+ logdensity[mu <= 0] = NaN
+ logdensity[lambda <= 0] = NaN
+ if (log.arg) logdensity else exp(logdensity)
}
@@ -431,21 +434,21 @@ pinv.gaussian = function(q, mu, lambda) {
rinv.gaussian = function(n, mu, lambda) {
- use.n = if ((length.n <- length(n)) > 1) length.n else
- if (!is.Numeric(n, integer.valued = TRUE,
- allowable.length = 1, positive = TRUE))
- stop("bad input for argument 'n'") else n
-
- mu = rep(mu, len = use.n); lambda = rep(lambda, len = use.n)
-
- u = runif(use.n)
- Z = rnorm(use.n)^2 # rchisq(use.n, df = 1)
- phi = lambda / mu
- y1 = 1 - 0.5 * (sqrt(Z^2 + 4*phi*Z) - Z) / phi
- ans = mu * ifelse((1+y1)*u > 1, 1/y1, y1)
- ans[mu <= 0] = NaN
- ans[lambda <= 0] = NaN
- ans
+ use.n = if ((length.n <- length(n)) > 1) length.n else
+ if (!is.Numeric(n, integer.valued = TRUE,
+ allowable.length = 1, positive = TRUE))
+ stop("bad input for argument 'n'") else n
+
+ mu = rep(mu, len = use.n); lambda = rep(lambda, len = use.n)
+
+ u = runif(use.n)
+ Z = rnorm(use.n)^2 # rchisq(use.n, df = 1)
+ phi = lambda / mu
+ y1 = 1 - 0.5 * (sqrt(Z^2 + 4*phi*Z) - Z) / phi
+ ans = mu * ifelse((1+y1)*u > 1, 1/y1, y1)
+ ans[mu <= 0] = NaN
+ ans[lambda <= 0] = NaN
+ ans
}
@@ -476,7 +479,8 @@ rinv.gaussian = function(n, mu, lambda) {
if (!is.list(emu)) emu = list()
if (!is.list(elambda)) elambda = list()
- if (!is.Numeric(imethod, allowable.length = 1, integer.valued = TRUE, positive = TRUE) ||
+ if (!is.Numeric(imethod, allowable.length = 1,
+ integer.valued = TRUE, positive = TRUE) ||
imethod > 3)
stop("argument 'imethod' must be 1 or 2 or 3")
if (!is.Numeric(shrinkage.init, allowable.length = 1) ||
@@ -547,7 +551,7 @@ rinv.gaussian = function(n, mu, lambda) {
.imethod = imethod ))),
loglikelihood = eval(substitute(
- function(mu, y, w, residuals = FALSE, eta, extra = NULL) {
+ function(mu, y, w, residuals = FALSE, eta, extra = NULL) {
lambda <- eta2theta(eta[, 2], link = .llambda, earg = .elambda)
if (residuals) stop("loglikelihood residuals ",
"not implemented yet") else {
@@ -599,10 +603,12 @@ rinv.gaussian = function(n, mu, lambda) {
link <- as.character(substitute(link))
if (!is.list(earg)) earg = list()
- if (!is.Numeric(imethod, allowable.length = 1, integer.valued = TRUE, positive = TRUE) ||
- imethod > 3)
+ if (!is.Numeric(imethod, allowable.length = 1,
+ integer.valued = TRUE, positive = TRUE) ||
+ imethod > 3)
stop("argument 'imethod' must be 1 or 2 or 3")
- if (length(imu) && !is.Numeric(imu, positive = TRUE))
+ if (length(imu) &&
+ !is.Numeric(imu, positive = TRUE))
stop("bad input for argument 'imu'")
new("vglmff",
@@ -698,7 +704,8 @@ rinv.gaussian = function(n, mu, lambda) {
theta2eta(mu, link = .link, earg = .earg)
}, list( .link = link, .earg = earg ))),
- loglikelihood = function(mu, y, w, residuals = FALSE, eta, extra = NULL) {
+ 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))
}
@@ -803,45 +810,49 @@ poissonqn.control <- function(save.weight = TRUE, ...)
etastart <- theta2eta(mu, link = .link, earg = .earg)
}), list( .link = link, .estimated.dispersion = estimated.dispersion,
.earg = earg ))),
- linkinv = eval(substitute(function(eta, extra = NULL) {
- eta2theta(eta, link = .link, earg = .earg)
- }, list( .link = link,
- .earg = earg ))),
- last = eval(substitute(expression({
- dpar <- .dispersion
- if (!dpar) {
- temp87= (y-mu)^2 * wz/(dtheta.deta(mu, link = .link, earg = .earg)^2)
- if (M > 1 && ! .onedpar) {
- dpar = rep(as.numeric(NA), len = M)
- temp87 = cbind(temp87)
- nrow.mu = if (is.matrix(mu)) nrow(mu) else length(mu)
- for(i in 1:M)
- dpar[i] = sum(temp87[,i]) / (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$BFGS = TRUE
- misc$dispersion <- dpar
- misc$default.dispersion <- 1
- misc$estimated.dispersion <- .estimated.dispersion
- misc$expected = FALSE
- misc$link = rep( .link, length = M)
- names(misc$link) = if (M > 1) dn2 else "mu"
+ linkinv = eval(substitute(function(eta, extra = NULL) {
+ eta2theta(eta, link = .link, earg = .earg)
+ }, list( .link = link,
+ .earg = earg ))),
+ last = eval(substitute(expression({
+ dpar <- .dispersion
+ if (!dpar) {
+ temp87 = (y-mu)^2 *
+ wz / (dtheta.deta(mu, link = .link, earg = .earg)^2)
+ if (M > 1 && ! .onedpar) {
+ dpar = rep(as.numeric(NA), len = M)
+ temp87 = cbind(temp87)
+ nrow.mu = if (is.matrix(mu)) nrow(mu) else length(mu)
+ for(i in 1:M)
+ dpar[i] = sum(temp87[,i]) / (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$BFGS = TRUE
+ misc$dispersion <- dpar
+ misc$default.dispersion <- 1
+ misc$estimated.dispersion <- .estimated.dispersion
+ misc$expected = FALSE
+ 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
- }), list( .dispersion = dispersion,
- .earg = earg,
- .estimated.dispersion = estimated.dispersion,
- .onedpar = onedpar, .link = link ))),
- 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) {
+ misc$earg = vector("list", M)
+ names(misc$earg) = names(misc$link)
+ for(ii in 1:M)
+ misc$earg[[ii]] = .earg
+ }), list( .dispersion = dispersion,
+ .earg = earg,
+ .estimated.dispersion = estimated.dispersion,
+ .onedpar = onedpar, .link = link ))),
+ 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) {
if (residuals) w*(y/mu - 1) else {
sum(w * dpois(x=y, lambda=mu, log = TRUE))
}
@@ -862,7 +873,8 @@ poissonqn.control <- function(save.weight = TRUE, ...)
} else {
lambda <- mu
dl.dlambda <- (y-lambda) / lambda
- dlambda.deta <- dtheta.deta(theta = lambda, link = .link, earg = .earg)
+ dlambda.deta <- dtheta.deta(theta = lambda,
+ link = .link, earg = .earg)
w * dl.dlambda * dlambda.deta
}
derivnew
@@ -874,7 +886,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),
+ wznew = qnupdate(w = w, wzold=wzold,
+ dderiv=(derivold-derivnew),
deta = etanew-etaold, M=M,
trace=trace) # weights incorporated in args
}
@@ -897,7 +910,7 @@ poissonqn.control <- function(save.weight = TRUE, ...)
}
}
wznew
- }), list( .wwts=wwts, .link = link,
+ }), list( .wwts = wwts, .link = link,
.earg = earg ))))
}
@@ -909,14 +922,15 @@ poissonqn.control <- function(save.weight = TRUE, ...)
idispersion=0.8,
zero = NULL)
{
- if (mode(lmean)!= "character" && mode(lmean)!= "name")
- lmean = as.character(substitute(lmean))
- if (mode(ldispersion)!= "character" && mode(ldispersion)!= "name")
- ldispersion = as.character(substitute(ldispersion))
- if (!is.Numeric(idispersion, positive = TRUE))
- stop("bad input for 'idispersion'")
- if (!is.list(emean)) emean = list()
- if (!is.list(edispersion)) edispersion = list()
+ if (mode(lmean)!= "character" && mode(lmean)!= "name")
+ lmean = as.character(substitute(lmean))
+ if (mode(ldispersion)!= "character" && mode(ldispersion)!= "name")
+ ldispersion = as.character(substitute(ldispersion))
+ if (!is.Numeric(idispersion, positive = TRUE))
+ stop("bad input for 'idispersion'")
+ if (!is.list(emean)) emean = list()
+ if (!is.list(edispersion)) edispersion = list()
+
new("vglmff",
blurb = c("Double exponential Poisson distribution\n\n",
@@ -944,9 +958,12 @@ poissonqn.control <- function(save.weight = TRUE, ...)
earg = .edispersion, short = TRUE))
init.mu = pmax(y, 1/8)
if (!length(etastart))
- etastart = cbind(theta2eta(init.mu, link = .lmean,earg = .emean),
- theta2eta(rep( .idispersion, len = n),
- link = .ldispersion, earg = .edispersion))
+ etastart = cbind(theta2eta(init.mu,
+ link = .lmean ,
+ earg = .emean ),
+ theta2eta(rep( .idispersion, length.out = n),
+ link = .ldispersion ,
+ earg = .edispersion))
}), list( .lmean = lmean, .emean = emean,
.ldispersion = ldispersion, .edispersion = edispersion,
.idispersion = idispersion ))),
@@ -961,36 +978,45 @@ poissonqn.control <- function(save.weight = TRUE, ...)
}), list( .lmean = lmean, .emean = emean,
.ldispersion = ldispersion, .edispersion = edispersion ))),
loglikelihood = eval(substitute(
- function(mu, y, w, residuals = FALSE, eta, extra = NULL) {
- lambda = eta2theta(eta[, 1], link = .lmean, earg = .emean)
- Disper = eta2theta(eta[, 2], link = .ldispersion, earg = .edispersion)
+ function(mu, y, w, residuals = FALSE, eta, extra = NULL) {
+ lambda = eta2theta(eta[, 1], link = .lmean,
+ earg = .emean )
+ Disper = eta2theta(eta[, 2], link = .ldispersion,
+ earg = .edispersion )
if (residuals) stop("loglikelihood residuals ",
"not implemented yet") else {
- sum(w*(0.5*log(Disper) + Disper*(y-lambda) + Disper*y*log(lambda)))
+ sum(w * (0.5*log(Disper) +
+ Disper*(y-lambda) + Disper*y*log(lambda)))
}
- }, list( .lmean = lmean, .emean = emean,
- .ldispersion = ldispersion, .edispersion = edispersion ))),
- vfamily = "dexppoisson",
- deriv = eval(substitute(expression({
- lambda = eta2theta(eta[, 1], link = .lmean, earg = .emean)
- Disper = eta2theta(eta[, 2], link = .ldispersion, earg = .edispersion)
- dl.dlambda = Disper * (y / lambda - 1)
- dl.dDisper = y * log(lambda) + y - lambda + 0.5 / Disper
- dlambda.deta = dtheta.deta(theta = lambda, link = .lmean, earg = .emean)
- dDisper.deta = dtheta.deta(theta = Disper, link = .ldispersion,
- earg = .edispersion)
- c(w) * cbind(dl.dlambda * dlambda.deta,
- dl.dDisper * dDisper.deta)
- }), list( .lmean = lmean, .emean = emean,
- .ldispersion = ldispersion, .edispersion = edispersion ))),
- weight = eval(substitute(expression({
- wz = matrix(as.numeric(NA), nrow=n, ncol=2) # diagonal
- usethis.lambda = pmax(lambda, .Machine$double.eps / 10000)
- wz[,iam(1, 1,M)] = (Disper / usethis.lambda) * dlambda.deta^2
- wz[,iam(2, 2,M)] = (0.5 / Disper^2) * dDisper.deta^2
- c(w) * wz
- }), list( .lmean = lmean, .emean = emean,
- .ldispersion = ldispersion, .edispersion = edispersion ))))
+ }, list( .lmean = lmean, .emean = emean,
+ .ldispersion = ldispersion, .edispersion = edispersion ))),
+ vfamily = "dexppoisson",
+ deriv = eval(substitute(expression({
+ lambda = eta2theta(eta[, 1], link = .lmean, earg = .emean)
+ Disper = eta2theta(eta[, 2], link = .ldispersion,
+ earg = .edispersion)
+
+ dl.dlambda = Disper * (y / lambda - 1)
+ dl.dDisper = y * log(lambda) + y - lambda + 0.5 / Disper
+
+ dlambda.deta = dtheta.deta(theta = lambda, link = .lmean,
+ earg = .emean)
+ dDisper.deta = dtheta.deta(theta = Disper, link = .ldispersion,
+ earg = .edispersion)
+
+ c(w) * cbind(dl.dlambda * dlambda.deta,
+ dl.dDisper * dDisper.deta)
+ }), list( .lmean = lmean, .emean = emean,
+ .ldispersion = ldispersion, .edispersion = edispersion ))),
+ weight = eval(substitute(expression({
+ wz = matrix(as.numeric(NA), nrow=n, ncol=2) # diagonal
+ usethis.lambda = pmax(lambda, .Machine$double.eps / 10000)
+ wz[,iam(1, 1,M)] = (Disper / usethis.lambda) * dlambda.deta^2
+ wz[,iam(2, 2,M)] = (0.5 / Disper^2) * dDisper.deta^2
+ c(w) * wz
+ }), list( .lmean = lmean, .emean = emean,
+ .ldispersion = ldispersion,
+ .edispersion = edispersion ))))
}
@@ -1000,14 +1026,14 @@ poissonqn.control <- function(save.weight = TRUE, ...)
idispersion=0.25,
zero=2)
{
- if (mode(lmean)!= "character" && mode(lmean)!= "name")
- lmean = as.character(substitute(lmean))
- if (mode(ldispersion)!= "character" && mode(ldispersion)!= "name")
- ldispersion = as.character(substitute(ldispersion))
- if (!is.Numeric(idispersion, positive = TRUE))
- stop("bad input for 'idispersion'")
- if (!is.list(emean)) emean = list()
- if (!is.list(edispersion)) edispersion = list()
+ if (mode(lmean)!= "character" && mode(lmean)!= "name")
+ lmean = as.character(substitute(lmean))
+ if (mode(ldispersion)!= "character" && mode(ldispersion)!= "name")
+ ldispersion = as.character(substitute(ldispersion))
+ if (!is.Numeric(idispersion, positive = TRUE))
+ stop("bad input for 'idispersion'")
+ if (!is.list(emean)) emean = list()
+ if (!is.list(edispersion)) edispersion = list()
new("vglmff",
blurb = c("Double Exponential Binomial distribution\n\n",
@@ -1061,7 +1087,8 @@ poissonqn.control <- function(save.weight = TRUE, ...)
} else
stop("for the dexpbinomial 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")
@@ -1076,9 +1103,12 @@ poissonqn.control <- function(save.weight = TRUE, ...)
namesof("dispersion", link = .ldispersion,
earg = .edispersion, short = TRUE))
if (!length(etastart))
- etastart = cbind(theta2eta(init.mu, link = .lmean,earg = .emean),
+ etastart = cbind(theta2eta(init.mu,
+ link = .lmean,
+ earg = .emean),
theta2eta(rep( .idispersion, len = n),
- link = .ldispersion, earg = .edispersion))
+ link = .ldispersion,
+ earg = .edispersion))
}), list( .lmean = lmean, .emean = emean,
.ldispersion = ldispersion, .edispersion = edispersion,
.idispersion = idispersion ))),
@@ -1094,8 +1124,9 @@ poissonqn.control <- function(save.weight = TRUE, ...)
.ldispersion = ldispersion, .edispersion = edispersion ))),
loglikelihood = eval(substitute(
function(mu, y, w, residuals = FALSE, eta, extra = NULL) {
- prob = eta2theta(eta[, 1], link = .lmean, earg = .emean)
- Disper = eta2theta(eta[, 2], link = .ldispersion, earg = .edispersion)
+ prob = eta2theta(eta[, 1], link = .lmean, earg = .emean)
+ Disper = eta2theta(eta[, 2], link = .ldispersion,
+ earg = .edispersion)
if (residuals) stop("loglikelihood residuals ",
"not implemented yet") else {
@@ -1112,17 +1143,21 @@ poissonqn.control <- function(save.weight = TRUE, ...)
vfamily = "dexpbinomial",
deriv = eval(substitute(expression({
prob = eta2theta(eta[, 1], link = .lmean, earg = .emean)
- Disper = eta2theta(eta[, 2], link = .ldispersion, earg = .edispersion)
+ Disper = eta2theta(eta[, 2], link = .ldispersion,
+ earg = .edispersion)
temp1 = y * log(ifelse(y > 0, y, 1)) # y*log(y)
temp2 = (1.0-y) * log1p(ifelse(y < 1, -y, 0)) # (1-y)*log(1-y)
temp3 = prob * (1.0-prob)
temp3 = pmax(temp3, .Machine$double.eps * 10000)
+
dl.dprob = w * Disper * (y - prob) / temp3
dl.dDisper = 0.5 / Disper + w * (y * log(prob) +
(1-y)*log1p(-prob) - temp1 - temp2)
+
dprob.deta = dtheta.deta(theta=prob, link = .lmean, earg = .emean)
dDisper.deta = dtheta.deta(theta = Disper, link = .ldispersion,
earg = .edispersion)
+
cbind(dl.dprob * dprob.deta,
dl.dDisper * dDisper.deta)
}), list( .lmean = lmean, .emean = emean,
@@ -1140,15 +1175,18 @@ poissonqn.control <- function(save.weight = TRUE, ...)
mbinomial = function(mvar = NULL, link = "logit", earg = list(),
- parallel = TRUE, smallno = .Machine$double.eps^(3/4))
+ parallel = TRUE,
+ smallno = .Machine$double.eps^(3/4))
{
- if (mode(link )!= "character" && mode(link )!= "name")
- link <- as.character(substitute(link))
- if (!is.list(earg)) earg = list()
- if (!is.Numeric(smallno, positive = TRUE, allowable.length = 1) || smallno > 1e-4)
- stop("bad input for 'smallno'")
- if (is.logical(parallel) && !parallel)
- stop("'parallel' must be TRUE")
+ if (mode(link )!= "character" && mode(link )!= "name")
+ link <- as.character(substitute(link))
+ if (!is.list(earg)) earg = list()
+ if (!is.Numeric(smallno, positive = TRUE,
+ allowable.length = 1) ||
+ smallno > 1e-4)
+ stop("bad input for 'smallno'")
+ if (is.logical(parallel) && !parallel)
+ stop("'parallel' must be TRUE")
temp = terms(mvar)
mvar = attr(temp,"term.labels")
@@ -1167,7 +1205,8 @@ poissonqn.control <- function(save.weight = TRUE, ...)
specialCM = list(a = vector("list", M-1))
for(ii in 1:(M-1)) {
- specialCM[[1]][[ii]] = (constraints[[extra$mvar]])[, 1+ii,drop = FALSE]
+ specialCM[[1]][[ii]] =
+ (constraints[[extra$mvar]])[, 1+ii,drop = FALSE]
}
names(specialCM) = extra$mvar
}), list( .parallel = parallel ))),
@@ -1234,7 +1273,8 @@ poissonqn.control <- function(save.weight = TRUE, ...)
temp = theta2eta(mu, .link, earg = .earg )
matrix(temp, extra$n, extra$M)
}, list( .link = link, .earg = earg ))),
- loglikelihood = function(mu, y, w, residuals = FALSE, eta, extra = NULL) {
+ loglikelihood =
+ 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
@@ -1258,13 +1298,14 @@ poissonqn.control <- function(save.weight = TRUE, ...)
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 - smallno] = 1 - smallno
- -w * (y - mu) * log1p(-mu.use) / mu.use
+ mu.use = mu
+ smallno = 100 * .Machine$double.eps
+ mu.use[mu.use < smallno] = smallno
+ mu.use[mu.use > 1 - smallno] = 1 - smallno
+ -w * (y - mu) * log1p(-mu.use) / mu.use
} else
- w * dtheta.deta(mu, link = .link, earg = .earg )* (y/mu - 1)/(1-mu)
+ w * dtheta.deta(mu, link = .link, earg = .earg ) *
+ (y/mu - 1)/(1-mu)
result = matrix(0, n, M)
result[cbind(1:n, extra$index9)] = answer
result
@@ -1272,11 +1313,12 @@ poissonqn.control <- function(save.weight = TRUE, ...)
weight = eval(substitute(expression({
tmp100 = mu*(1-mu)
answer = if ( .link == "logit") {
- cbind(w * tmp100)
+ cbind(w * tmp100)
} else if ( .link == "cloglog") {
- cbind(w * (1-mu.use) * (log1p(-mu.use))^2 / mu.use )
+ cbind(w * (1-mu.use) * (log1p(-mu.use))^2 / mu.use )
} else {
- cbind(w * dtheta.deta(mu, link = .link, earg = .earg)^2 / tmp100)
+ cbind(w * dtheta.deta(mu, link = .link,
+ earg = .earg)^2 / tmp100)
}
result = matrix( .smallno, n, M)
@@ -1378,7 +1420,8 @@ mypool = function(x, index) {
misc$earg = list( mu = .earg )
misc$expected = TRUE
}), list( .link = link, .earg = earg ))),
- loglikelihood = function(mu, y, w, residuals = FALSE, eta, extra = NULL) {
+ loglikelihood =
+ function(mu, y, w, residuals = FALSE, eta, extra = NULL) {
if (residuals) w*(y/mu - (1-y)/(1-mu)) else {
sum(w*(y*log(mu) + (1-y)*log1p(-mu)))
}
@@ -1599,7 +1642,8 @@ mypool = function(x, index) {
}
myderiv = (cbind(deriv1,
- deriv2))[, interleave.VGAM(Musual * NOS, M = Musual)]
+ deriv2))[, interleave.VGAM(Musual * NOS,
+ M = Musual)]
myderiv
}), list( .link = link, .earg = earg ))),
weight = eval(substitute(expression({
diff --git a/R/family.normal.R b/R/family.normal.R
index a73b788..c5d2fd8 100644
--- a/R/family.normal.R
+++ b/R/family.normal.R
@@ -14,7 +14,7 @@ VGAM.weights.function = function(w, M, n) {
ncolw = ncol(as.matrix(w))
if (ncolw == 1) {
- wz = matrix(w, nrow=n, ncol=M) # w_i * diag(M)
+ wz = matrix(w, nrow = n, ncol = M) # w_i * diag(M)
} else if (ncolw == M) {
wz = as.matrix(w)
} else if (ncolw < M && M > 1) {
@@ -40,18 +40,19 @@ VGAM.weights.function = function(w, M, n) {
gaussianff = function(dispersion = 0, parallel = FALSE, zero = NULL)
{
- if (!is.Numeric(dispersion, allowable.length = 1) || dispersion < 0)
- stop("bad input for argument 'dispersion'")
- estimated.dispersion = dispersion == 0
+ if (!is.Numeric(dispersion, allowable.length = 1) ||
+ dispersion < 0)
+ stop("bad input for argument 'dispersion'")
+ estimated.dispersion = dispersion == 0
- new("vglmff",
- blurb = c("Vector linear/additive model\n",
- "Links: identity for Y1,...,YM"),
- 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) {
+ new("vglmff",
+ blurb = c("Vector linear/additive model\n",
+ "Links: identity for Y1,...,YM"),
+ 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) {
M = if (is.matrix(y)) ncol(y) else 1
n = if (is.matrix(y)) nrow(y) else length(y)
wz = VGAM.weights.function(w = w, M = M, n = n)
@@ -95,7 +96,7 @@ VGAM.weights.function = function(w, M, n) {
misc$dispersion = dpar
misc$default.dispersion = 0
misc$estimated.dispersion = .estimated.dispersion
- misc$link = rep("identity", length=M)
+ misc$link = rep("identity", length = M)
names(misc$link) = predictors.names
if (is.R()) {
@@ -168,7 +169,9 @@ dposnorm = function(x, mean = 0, sd = 1, log = FALSE) {
if (!is.logical(log.arg) || length(log.arg) != 1)
stop("bad input for argument 'log'")
L = max(length(x), length(mean), length(sd))
- x = rep(x, len = L); mean = rep(mean, len = L); sd = rep(sd, len = L);
+ x = rep(x, len = L);
+ mean = rep(mean, len = L);
+ sd = rep(sd, len = L);
if (log.arg) {
ifelse(x < 0, log(0), dnorm(x, mean = mean, sd = sd, log = TRUE) -
@@ -181,7 +184,9 @@ 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);
+ q = rep(q, len = L);
+ mean = rep(mean, len = L);
+ sd = rep(sd, len = L);
ifelse(q < 0, 0, (pnorm(q, mean = mean, sd = sd) -
pnorm(0, mean = mean, sd = sd)) / pnorm(q = mean/sd))
}
@@ -220,45 +225,50 @@ rposnorm = function(n, mean = 0, sd = 1) {
{
warning("this VGAM family function is not working properly yet")
- if (mode(lmean) != "character" && mode(lmean) != "name")
- lmean = as.character(substitute(lmean))
- if (mode(lsd) != "character" && mode(lsd) != "name")
- lsd = as.character(substitute(lsd))
+ if (mode(lmean) != "character" && mode(lmean) != "name")
+ lmean = as.character(substitute(lmean))
+ if (mode(lsd) != "character" && mode(lsd) != "name")
+ lsd = as.character(substitute(lsd))
- if (length(zero) && !is.Numeric(zero, integer.valued = TRUE, positive = TRUE))
- stop("bad input for argument 'zero'")
- if (length(isd) && !is.Numeric(isd, positive = TRUE))
- stop("bad input for argument 'isd'")
+ if (length(zero) &&
+ !is.Numeric(zero, integer.valued = TRUE, positive = TRUE))
+ stop("bad input for argument 'zero'")
+ if (length(isd) &&
+ !is.Numeric(isd, positive = TRUE))
+ stop("bad input for argument 'isd'")
- if (!is.list(emean)) emean = list()
- if (!is.list(esd)) esd = list()
+ if (!is.list(emean)) emean = list()
+ if (!is.list(esd)) esd = list()
- if (length(nsimEIM))
- if (!is.Numeric(nsimEIM, allowable.length = 1, integer.valued = TRUE) || nsimEIM <= 10)
- stop("argument 'nsimEIM' should be an integer greater than 10")
+ if (length(nsimEIM))
+ if (!is.Numeric(nsimEIM, allowable.length = 1,
+ integer.valued = TRUE) ||
+ nsimEIM <= 10)
+ stop("argument 'nsimEIM' should be an integer greater than 10")
- new("vglmff",
- blurb = c("Positive (univariate) normal distribution\n\n",
- "Links: ",
- namesof("mean", lmean, earg = emean, tag = TRUE), "; ",
- namesof("sd", lsd, earg = esd, tag = TRUE)),
- 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("response must be a vector or a one-column matrix")
- if (min(y) <= 0)
- stop("response must be positive")
+ new("vglmff",
+ blurb = c("Positive (univariate) normal distribution\n\n",
+ "Links: ",
+ namesof("mean", lmean, earg = emean, tag = TRUE), "; ",
+ namesof("sd", lsd, earg = esd, tag = TRUE)),
+ 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("response must be a vector or a one-column matrix")
- predictors.names =
- c(namesof("mean", .lmean, earg = .emean, tag = FALSE),
- namesof("sd", .lsd, earg = .esd, tag = FALSE))
+ if (min(y) <= 0)
+ stop("response must be positive")
- 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
+ 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))
@@ -383,9 +393,10 @@ pbetanorm = function(q, shape1, shape2, mean = 0, sd = 1,
qbetanorm = function(p, shape1, shape2, mean = 0, sd = 1) {
- if (!is.Numeric(p, positive = TRUE) || max(p) >= 1)
- stop("bad input for argument 'p'")
- qnorm(p=qbeta(p=p, shape1=shape1, shape2=shape2), mean = mean, sd = sd)
+ if (!is.Numeric(p, positive = TRUE) || max(p) >= 1)
+ stop("bad input for argument 'p'")
+ qnorm(p = qbeta(p = p, shape1 = shape1, shape2 = shape2),
+ mean = mean, sd = sd)
}
@@ -400,80 +411,86 @@ rbetanorm = function(n, shape1, shape2, mean = 0, sd = 1) {
dtikuv = function(x, d, mean = 0, sigma = 1, log = FALSE) {
- if (!is.logical(log.arg <- log))
- stop("bad input for argument 'log'")
- rm(log)
+ if (!is.logical(log.arg <- log))
+ stop("bad input for argument 'log'")
+ rm(log)
- if (!is.Numeric(d, allowable.length = 1) ||
- max(d) >= 2)
- stop("bad input for argument 'd'")
+ if (!is.Numeric(d, allowable.length = 1) ||
+ max(d) >= 2)
+ stop("bad input for argument 'd'")
- L = max(length(x), length(mean), length(sigma))
- x = rep(x, len = L); mean = rep(mean, len = L);
- sigma = rep(sigma, len = L);
- hh = 2 - d
- KK = 1 / (1 + 1/hh + 0.75/hh^2)
- if (log.arg) {
- dnorm(x = x, mean = mean, sd = sigma, log = TRUE) + log(KK) +
- 2 * log1p(((x-mean)/sigma)^2 / (2*hh))
- } else {
- dnorm(x = x, mean = mean, sd = sigma) * KK *
- (1 + ((x-mean)/sigma)^2 / (2*hh))^2
- }
+ L = max(length(x), length(mean), length(sigma))
+ x = rep(x, len = L); mean = rep(mean, len = L);
+ sigma = rep(sigma, len = L);
+ hh = 2 - d
+ KK = 1 / (1 + 1/hh + 0.75/hh^2)
+ if (log.arg) {
+ dnorm(x = x, mean = mean, sd = sigma, log = TRUE) + log(KK) +
+ 2 * log1p(((x-mean)/sigma)^2 / (2*hh))
+ } else {
+ dnorm(x = x, mean = mean, sd = sigma) * KK *
+ (1 + ((x-mean)/sigma)^2 / (2*hh))^2
+ }
}
ptikuv = function(q, d, mean = 0, sigma=1) {
- if (!is.Numeric(d, allowable.length = 1) ||
- max(d) >= 2)
- stop("bad input for argument 'd'")
+ if (!is.Numeric(d, allowable.length = 1) ||
+ max(d) >= 2)
+ stop("bad input for argument 'd'")
- L = max(length(q), length(mean), length(sigma))
- q = rep(q, len = L); mean = rep(mean, len = L);
- sigma = rep(sigma, len = L);
- zedd1 = 0.5 * ((q - mean) / sigma)^2
- ans = q*0 + 0.5
- hh = 2 - d
- KK = 1 / (1 + 1/hh + 0.75/hh^2)
- if (any(lhs <- q < mean)) {
- ans[lhs] = ( KK/(2*sqrt(pi))) * (
- gamma(0.5) * (1 - pgamma(zedd1[lhs], 0.5)) +
- 2 * gamma(1.5) * (1 - pgamma(zedd1[lhs], 1.5)) / hh +
- gamma(2.5) * (1 - pgamma(zedd1[lhs], 2.5)) / hh^2)
- }
- if (any(rhs <- q > mean)) {
- ans[rhs] = 1.0 - Recall(q = (2*mean[rhs] - q[rhs]), d = d,
- mean = mean[rhs], sigma = sigma[rhs])
- }
- ans
+ L = max(length(q), length(mean), length(sigma))
+ q = rep(q, len = L); mean = rep(mean, len = L);
+ sigma = rep(sigma, len = L);
+ zedd1 = 0.5 * ((q - mean) / sigma)^2
+ ans = q*0 + 0.5
+ hh = 2 - d
+ KK = 1 / (1 + 1/hh + 0.75/hh^2)
+ if (any(lhs <- q < mean)) {
+ ans[lhs] = ( KK/(2*sqrt(pi))) * (
+ gamma(0.5) * (1 - pgamma(zedd1[lhs], 0.5)) +
+ 2 * gamma(1.5) * (1 - pgamma(zedd1[lhs], 1.5)) / hh +
+ gamma(2.5) * (1 - pgamma(zedd1[lhs], 2.5)) / hh^2)
+ }
+ if (any(rhs <- q > mean)) {
+ ans[rhs] = 1.0 - Recall(q = (2*mean[rhs] - q[rhs]), d = d,
+ mean = mean[rhs], sigma = sigma[rhs])
+ }
+ ans
}
qtikuv = function(p, d, mean = 0, sigma = 1, ...) {
- if (!is.Numeric(p, positive = TRUE) || max(p) >= 1)
- stop("bad input for argument 'p'")
- if (!is.Numeric(d, allowable.length = 1) || max(d) >= 2)
- stop("bad input for argument 'd'")
- if (!is.Numeric(mean))
- stop("bad input for argument 'mean'")
- if (!is.Numeric(sigma))
- stop("bad input for argument 'sigma'")
- L = max(length(p), length(mean), length(sigma))
- p = rep(p, len = L); mean = rep(mean, len = L); sigma = rep(sigma, len = L);
- ans = rep(0.0, len = L)
- myfun = function(x, d, mean = 0, sigma = 1, p)
- ptikuv(q = x, d = d, mean = mean, sigma = sigma) - p
- for(i in 1:L) {
- Lower = ifelse(p[i] <= 0.5, mean[i] - 3 * sigma[i], mean[i])
- while (ptikuv(q = Lower, d = d, mean = mean[i], sigma = sigma[i]) > p[i])
- Lower = Lower - sigma[i]
- Upper = ifelse(p[i] >= 0.5, mean[i] + 3 * sigma[i], mean[i])
- while (ptikuv(q = Upper, d = d, mean = mean[i], sigma = sigma[i]) < p[i])
- Upper = Upper + sigma[i]
- ans[i] = uniroot(f=myfun, lower = Lower, upper = Upper, d = d, p=p[i],
- mean = mean[i], sigma = sigma[i], ...)$root
- }
- ans
+ if (!is.Numeric(p, positive = TRUE) || max(p) >= 1)
+ stop("bad input for argument 'p'")
+ if (!is.Numeric(d, allowable.length = 1) || max(d) >= 2)
+ stop("bad input for argument 'd'")
+ if (!is.Numeric(mean))
+ stop("bad input for argument 'mean'")
+ if (!is.Numeric(sigma))
+ stop("bad input for argument 'sigma'")
+ L = max(length(p), length(mean), length(sigma))
+ p = rep(p, len = L);
+ mean = rep(mean, len = L);
+ sigma = rep(sigma, len = L);
+ ans = rep(0.0, len = L)
+
+ myfun = function(x, d, mean = 0, sigma = 1, p)
+ ptikuv(q = x, d = d, mean = mean, sigma = sigma) - p
+ for(i in 1:L) {
+ Lower = ifelse(p[i] <= 0.5, mean[i] - 3 * sigma[i], mean[i])
+ while (ptikuv(q = Lower, d = d, mean = mean[i],
+ sigma = sigma[i]) > p[i])
+ Lower = Lower - sigma[i]
+ Upper = ifelse(p[i] >= 0.5, mean[i] + 3 * sigma[i], mean[i])
+ while (ptikuv(q = Upper, d = d, mean = mean[i],
+ sigma = sigma[i]) < p[i])
+ Upper = Upper + sigma[i]
+ ans[i] = uniroot(f = myfun, lower = Lower, upper = Upper,
+ d = d, p = p[i],
+ mean = mean[i], sigma = sigma[i], ...)$root
+ }
+ ans
}
@@ -522,55 +539,59 @@ rtikuv = function(n, d, mean = 0, sigma = 1, Smallno = 1.0e-6) {
- tikuv = function(d, lmean = "identity", lsigma="loge",
- emean = list(), esigma=list(),
- isigma = NULL, zero=2)
+ tikuv = function(d, lmean = "identity", lsigma = "loge",
+ emean = list(), esigma = list(),
+ isigma = NULL, zero = 2)
{
- if (mode(lmean) != "character" && mode(lmean) != "name")
- lmean = as.character(substitute(lmean))
- if (mode(lsigma) != "character" && mode(lsigma) != "name")
- lsigma = as.character(substitute(lsigma))
- if (length(zero) && (!is.Numeric(zero, integer.valued = TRUE, positive = TRUE) ||
- max(zero) > 2))
- stop("bad input for argument 'zero'")
- if (!is.Numeric(d, allowable.length = 1) || max(d) >= 2)
- stop("bad input for argument 'd'")
- if (!is.list(emean)) emean = list()
- if (!is.list(esigma)) esigma = list()
+ if (mode(lmean) != "character" && mode(lmean) != "name")
+ lmean = as.character(substitute(lmean))
+ if (mode(lsigma) != "character" && mode(lsigma) != "name")
+ lsigma = as.character(substitute(lsigma))
+ if (length(zero) &&
+ (!is.Numeric(zero, integer.valued = TRUE, positive = TRUE) ||
+ max(zero) > 2))
+ stop("bad input for argument 'zero'")
+ if (!is.Numeric(d, allowable.length = 1) || max(d) >= 2)
+ stop("bad input for argument 'd'")
- new("vglmff",
- blurb = c("Short-tailed symmetric [Tiku and Vaughan (1999)] distribution\n",
- "Link: ",
- namesof("mean", lmean, earg = emean), ", ",
- namesof("sigma", lsigma, earg = esigma),
- "\n",
- "\n",
- "Mean: mean"),
- 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("the response must be a vector or one-column matrix")
- predictors.names =
- c(namesof("mean", .lmean, earg = .emean, tag = FALSE),
- namesof("sigma", .lsigma, earg = .esigma, tag = FALSE))
- if (!length(etastart)) {
- sigma.init = if (length(.isigma)) rep(.isigma, length = n) else {
- hh = 2 - .d
- KK = 1 / (1 + 1/hh + 0.75/hh^2)
- K2 = 1 + 3/hh + 15/(4*hh^2)
- rep(sqrt(var(y) / (KK*K2)), len = n)
- }
- mean.init = rep(weighted.mean(y, w), len = n)
- etastart = cbind(theta2eta(mean.init, .lmean, earg = .emean),
- theta2eta(sigma.init, .lsigma, earg = .esigma))
- }
- }),list( .lmean = lmean, .lsigma=lsigma, .isigma=isigma, .d = d,
- .emean = emean, .esigma=esigma ))),
- linkinv = eval(substitute(function(eta, extra = NULL) {
- eta2theta(eta[,1], .lmean, earg = .emean)
- }, list( .lmean = lmean,
+ if (!is.list(emean)) emean = list()
+ if (!is.list(esigma)) esigma = list()
+
+
+ new("vglmff",
+ blurb = c("Short-tailed symmetric [Tiku and Vaughan (1999)] ",
+ "distribution\n",
+ "Link: ",
+ namesof("mean", lmean, earg = emean), ", ",
+ namesof("sigma", lsigma, earg = esigma),
+ "\n",
+ "\n",
+ "Mean: mean"),
+ 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("the response must be a vector or one-column matrix")
+ predictors.names =
+ c(namesof("mean", .lmean, earg = .emean, tag = FALSE),
+ namesof("sigma", .lsigma, earg = .esigma, tag = FALSE))
+ if (!length(etastart)) {
+ sigma.init = if (length(.isigma)) rep(.isigma, length = n) else {
+ hh = 2 - .d
+ KK = 1 / (1 + 1/hh + 0.75/hh^2)
+ K2 = 1 + 3/hh + 15/(4*hh^2)
+ rep(sqrt(var(y) / (KK*K2)), len = n)
+ }
+ mean.init = rep(weighted.mean(y, w), len = n)
+ etastart = cbind(theta2eta(mean.init, .lmean, earg = .emean),
+ theta2eta(sigma.init, .lsigma, earg = .esigma))
+ }
+ }),list( .lmean = lmean, .lsigma=lsigma, .isigma=isigma, .d = d,
+ .emean = emean, .esigma=esigma ))),
+ linkinv = eval(substitute(function(eta, extra = NULL) {
+ eta2theta(eta[,1], .lmean, earg = .emean)
+ }, list( .lmean = lmean,
.emean = emean, .esigma=esigma ))),
last = eval(substitute(expression({
misc$link = c("mean"= .lmean, "sigma"= .lsigma)
@@ -622,68 +643,83 @@ rtikuv = function(n, d, mean = 0, sigma = 1, Smallno = 1.0e-6) {
dfnorm = function(x, mean = 0, sd = 1, a1 = 1, a2=1) {
- if (!is.Numeric(a1, positive = TRUE) || !is.Numeric(a2, positive = TRUE))
- stop("bad input for arguments 'a1' and 'a2'")
- if (any(a1 <= 0 | a2 <= 0))
- stop("arguments 'a1' and 'a2' must have positive values only")
- ans = dnorm(x = x/(a1*sd) - mean/sd)/(a1*sd) +
- dnorm(x = x/(a2*sd) + mean/sd)/(a2*sd)
- ans[x < 0] = 0
- ans[a1 <= 0 | a2 <= 0 | is.na(a1) | is.na(a2)] = NA
- ans
+ if (!is.Numeric(a1, positive = TRUE) ||
+ !is.Numeric(a2, positive = TRUE))
+ stop("bad input for arguments 'a1' and 'a2'")
+ if (any(a1 <= 0 | a2 <= 0))
+ stop("arguments 'a1' and 'a2' must have positive values only")
+ ans = dnorm(x = x/(a1*sd) - mean/sd)/(a1*sd) +
+ dnorm(x = x/(a2*sd) + mean/sd)/(a2*sd)
+ ans[x < 0] = 0
+ ans[a1 <= 0 | a2 <= 0 | is.na(a1) | is.na(a2)] = NA
+ ans
}
+
pfnorm = function(q, mean = 0, sd = 1, a1 = 1, a2=1) {
- if (!is.Numeric(a1, positive = TRUE) || !is.Numeric(a2, positive = TRUE))
- stop("bad input for arguments 'a1' and 'a2'")
- if (any(a1 <= 0 | a2 <= 0))
- stop("arguments 'a1' and 'a2' must have positive values only")
- L = max(length(q), length(mean), length(sd))
- q = rep(q, len = L); mean = rep(mean, len = L); sd = rep(sd, len = L);
- ifelse(q < 0, 0,
- pnorm(q = q/(a1*sd) - mean/sd) -
- pnorm(q = -q/(a2*sd) - mean/sd))
+ if (!is.Numeric(a1, positive = TRUE) ||
+ !is.Numeric(a2, positive = TRUE))
+ stop("bad input for arguments 'a1' and 'a2'")
+ if (any(a1 <= 0 | a2 <= 0))
+ stop("arguments 'a1' and 'a2' must have positive values only")
+ L = max(length(q), length(mean), length(sd))
+ q = rep(q, len = L);
+ mean = rep(mean, len = L);
+ sd = rep(sd, len = L);
+
+ ifelse(q < 0, 0,
+ pnorm(q = q/(a1*sd) - mean/sd) -
+ pnorm(q = -q/(a2*sd) - mean/sd))
}
+
qfnorm = function(p, mean = 0, sd = 1, a1 = 1, a2 = 1, ...) {
- if (!is.Numeric(p, positive = TRUE) || max(p) >= 1)
- stop("bad input for argument 'p'")
- if (!is.Numeric(a1, positive = TRUE) || !is.Numeric(a2, positive = TRUE))
- stop("bad input for arguments 'a1' and 'a2'")
- if (any(a1 <= 0 | a2 <= 0))
- stop("arguments 'a1' and 'a2' must have positive values only")
-
- L = max(length(p), length(mean), length(sd), length(a1), length(a2))
- p = rep(p, len = L); mean = rep(mean, len = L); sd = rep(sd, len = L);
- a1 = rep(a1, len = L); a2 = rep(a2, len = L);
- ans = rep(0.0, len = L)
- myfun = function(x, mean = 0, sd = 1, a1 = 1, a2=2, p)
- pfnorm(q = x, mean = mean, sd = sd, a1 = a1, a2 = a2) - p
- for(i in 1:L) {
- mytheta = mean[i]/sd[i]
- EY = sd[i] * ((a1[i]+a2[i]) *
- (mytheta * pnorm(mytheta) + dnorm(mytheta)) -
- a2[i] * mytheta)
- Upper = 2 * EY
- while (pfnorm(q = Upper, mean = mean[i], sd = sd[i],
- a1 = a1[i], a2 = a2[i]) < p[i])
- Upper = Upper + sd[i]
- ans[i] = uniroot(f=myfun, lower = 0, upper = Upper, mean = mean[i],
- sd = sd[i], a1 = a1[i], a2 = a2[i],
- p=p[i], ...)$root
- }
- ans
+ if (!is.Numeric(p, positive = TRUE) || max(p) >= 1)
+ stop("bad input for argument 'p'")
+ if (!is.Numeric(a1, positive = TRUE) ||
+ !is.Numeric(a2, positive = TRUE))
+ stop("bad input for arguments 'a1' and 'a2'")
+ if (any(a1 <= 0 | a2 <= 0))
+ stop("arguments 'a1' and 'a2' must have positive values only")
+
+ L = max(length(p), length(mean), length(sd), length(a1), length(a2))
+ p = rep(p, len = L);
+ mean = rep(mean, len = L);
+ sd = rep(sd, len = L);
+ a1 = rep(a1, len = L);
+ a2 = rep(a2, len = L);
+ ans = rep(0.0, len = L)
+
+ myfun = function(x, mean = 0, sd = 1, a1 = 1, a2=2, p)
+ pfnorm(q = x, mean = mean, sd = sd, a1 = a1, a2 = a2) - p
+ for(i in 1:L) {
+ mytheta = mean[i]/sd[i]
+ EY = sd[i] * ((a1[i]+a2[i]) *
+ (mytheta * pnorm(mytheta) + dnorm(mytheta)) -
+ a2[i] * mytheta)
+ Upper = 2 * EY
+ while (pfnorm(q = Upper, mean = mean[i], sd = sd[i],
+ a1 = a1[i], a2 = a2[i]) < p[i])
+ Upper = Upper + sd[i]
+ ans[i] = uniroot(f = myfun, lower = 0, upper = Upper,
+ mean = mean[i],
+ sd = sd[i], a1 = a1[i], a2 = a2[i],
+ p = p[i], ...)$root
+ }
+ ans
}
+
rfnorm = function(n, mean = 0, sd = 1, a1 = 1, a2=1) {
- if (!is.Numeric(n, integer.valued = TRUE, positive = TRUE))
- stop("bad input for argument 'n'")
- if (!is.Numeric(a1, positive = TRUE) || !is.Numeric(a2, positive = TRUE))
- stop("bad input for arguments 'a1' and 'a2'")
- if (any(a1 <= 0 | a2 <= 0))
- stop("arguments 'a1' and 'a2' must have positive values only")
- X = rnorm(n, mean = mean, sd = sd)
- pmax(a1 * X, -a2*X)
+ if (!is.Numeric(n, integer.valued = TRUE, positive = TRUE))
+ stop("bad input for argument 'n'")
+ if (!is.Numeric(a1, positive = TRUE) ||
+ !is.Numeric(a2, positive = TRUE))
+ stop("bad input for arguments 'a1' and 'a2'")
+ if (any(a1 <= 0 | a2 <= 0))
+ stop("arguments 'a1' and 'a2' must have positive values only")
+ X = rnorm(n, mean = mean, sd = sd)
+ pmax(a1 * X, -a2*X)
}
@@ -696,30 +732,34 @@ rfnorm = function(n, mean = 0, sd = 1, a1 = 1, a2=1) {
nsimEIM = 500, imethod = 1, zero = NULL)
{
if (!is.Numeric(a1, positive = TRUE, allowable.length = 1) ||
- !is.Numeric(a2, positive = TRUE, allowable.length = 1))
- stop("bad input for arguments 'a1' and 'a2'")
+ !is.Numeric(a2, positive = TRUE, allowable.length = 1))
+ stop("bad input for arguments 'a1' and 'a2'")
if (any(a1 <= 0 | a2 <= 0))
- stop("arguments 'a1' and 'a2' must each be a positive value")
- if (!is.Numeric(imethod, allowable.length = 1, integer.valued = TRUE, positive = TRUE) ||
- imethod > 2)
- stop("argument 'imethod' must be 1 or 2")
+ stop("arguments 'a1' and 'a2' must each be a positive value")
+ if (!is.Numeric(imethod, allowable.length = 1,
+ integer.valued = TRUE, positive = TRUE) ||
+ imethod > 2)
+ stop("argument 'imethod' must be 1 or 2")
if (mode(lmean) != "character" && mode(lmean) != "name")
lmean = as.character(substitute(lmean))
if (mode(lsd) != "character" && mode(lsd) != "name")
lsd = as.character(substitute(lsd))
- if (length(zero) && !is.Numeric(zero, integer.valued = TRUE, positive = TRUE))
- stop("bad input for argument 'zero'")
+ if (length(zero) &&
+ !is.Numeric(zero, integer.valued = TRUE, positive = TRUE))
+ stop("bad input for argument 'zero'")
if (!is.list(emean)) emean = list()
- if (!is.list(esd)) esd = list()
+ if (!is.list(esd)) esd = list()
- if (!is.Numeric(nsimEIM, allowable.length = 1, integer.valued = TRUE) || nsimEIM <= 10)
- stop("argument 'nsimEIM' should be an integer greater than 10")
+ if (!is.Numeric(nsimEIM, allowable.length = 1,
+ integer.valued = TRUE) ||
+ nsimEIM <= 10)
+ stop("argument 'nsimEIM' should be an integer greater than 10")
if (length(imean) && !is.Numeric(imean))
- stop("bad input for 'imean'")
+ stop("bad input for 'imean'")
if (length(isd) && !is.Numeric(isd, positive = TRUE))
- stop("bad input for 'isd'")
+ stop("bad input for 'isd'")
new("vglmff",
blurb = c("(Generalized) folded univariate normal distribution\n\n",
@@ -735,7 +775,7 @@ rfnorm = function(n, mean = 0, sd = 1, a1 = 1, a2=1) {
"matrix with positive values")
if (!length(etastart)) {
junk = if (is.R()) lm.wfit(x = x, y=y, w = w) else
- lm.wfit(x = x, y=y, w = w, method="qr")
+ lm.wfit(x = x, y=y, w = w, method = "qr")
if (FALSE) {
@@ -864,15 +904,19 @@ lqnorm = function(qpower = 2, link = "identity", earg = list(),
imethod = 1, imu = NULL, shrinkage.init = 0.95)
{
if (mode(link) != "character" && mode(link) != "name")
- link = as.character(substitute(link))
+ link = as.character(substitute(link))
if (!is.list(earg)) eerg = list()
if (!is.Numeric(qpower, allowable.length = 1) || qpower <= 1)
- stop("bad input for argument 'qpower'")
- if (!is.Numeric(imethod, allowable.length = 1, integer.valued = TRUE, positive = TRUE) ||
+ stop("bad input for argument 'qpower'")
+ if (!is.Numeric(imethod, allowable.length = 1,
+ integer.valued = TRUE, positive = TRUE) ||
imethod > 3)
- stop("argument 'imethod' must be 1 or 2 or 3")
- if (!is.Numeric(shrinkage.init, allowable.length = 1) || shrinkage.init < 0 ||
- shrinkage.init > 1) stop("bad input for argument 'shrinkage.init'")
+ stop("argument 'imethod' must be 1 or 2 or 3")
+ if (!is.Numeric(shrinkage.init, allowable.length = 1) ||
+ shrinkage.init < 0 ||
+ shrinkage.init > 1)
+ stop("bad input for argument 'shrinkage.init'")
+
new("vglmff",
blurb = c("Minimizing the q-norm of residuals\n",
@@ -884,7 +928,7 @@ lqnorm = function(qpower = 2, link = "identity", earg = list(),
stop("response must be a vector or a one-column matrix")
dy = dimnames(y)
predictors.names = if (!is.null(dy[[2]])) dy[[2]] else
- paste("mu", 1:M, sep="")
+ paste("mu", 1:M, sep = "")
predictors.names = namesof(predictors.names, link = .link,
earg = .earg, short = TRUE)
if (!length(etastart)) {
@@ -906,7 +950,7 @@ lqnorm = function(qpower = 2, link = "identity", earg = list(),
dy = dimnames(y)
if (!is.null(dy[[2]]))
dimnames(fit$fitted.values) = dy
- misc$link = rep( .link, length=M)
+ misc$link = rep( .link, length = M)
names(misc$link) = predictors.names
misc$earg = list(mu = .earg)
misc$qpower = .qpower
@@ -949,8 +993,11 @@ dtobit = function(x, mean = 0, sd = 1,
L = max(length(x), length(mean), length(sd), length(Lower),
length(Upper))
- x = rep(x, len = L); mean = rep(mean, len = L); sd = rep(sd, len = L);
- Lower = rep(Lower, len = L); Upper = rep(Upper, len = L);
+ x = rep(x, len = L);
+ mean = rep(mean, len = L);
+ sd = rep(sd, len = L);
+ Lower = rep(Lower, len = L);
+ Upper = rep(Upper, len = L);
ans = dnorm(x = x, mean = mean, sd = sd, log = log.arg)
ans[x < Lower] = if (log.arg) log(0.0) else 0.0
@@ -992,8 +1039,11 @@ ptobit = function(q, mean = 0, sd = 1,
L = max(length(q), length(mean), length(sd), length(Lower),
length(Upper))
- q = rep(q, len = L); mean = rep(mean, len = L); sd = rep(sd, len = L);
- Lower = rep(Lower, len = L); Upper = rep(Upper, len = L);
+ q = rep(q, len = L);
+ mean = rep(mean, len = L);
+ sd = rep(sd, len = L);
+ Lower = rep(Lower, len = L);
+ Upper = rep(Upper, len = L);
ans = pnorm(q = q, mean = mean, sd = sd, lower.tail = lower.tail)
ind1 <- q < Lower
@@ -1014,8 +1064,11 @@ qtobit = function(p, mean = 0, sd = 1,
L = max(length(p), length(mean), length(sd), length(Lower),
length(Upper))
- p = rep(p, len = L); mean = rep(mean, len = L); sd = rep(sd, len = L);
- Lower = rep(Lower, len = L); Upper = rep(Upper, len = L);
+ p = rep(p, len = L);
+ mean = rep(mean, len = L);
+ sd = rep(sd, len = L);
+ Lower = rep(Lower, len = L);
+ Upper = rep(Upper, len = L);
ans = qnorm(p = p, mean = mean, sd = sd)
pnorm.Lower = ptobit(q = Lower, mean = mean, sd = sd)
@@ -1039,12 +1092,15 @@ rtobit = function(n, mean = 0, sd = 1,
Lower = 0, Upper = Inf) {
use.n = if ((length.n <- length(n)) > 1) length.n else
- if (!is.Numeric(n, integer.valued = TRUE, allowable.length = 1, positive = TRUE))
- stop("bad input for argument 'n'") else n
+ if (!is.Numeric(n, integer.valued = TRUE,
+ allowable.length = 1, positive = TRUE))
+ stop("bad input for argument 'n'") else n
L = max(use.n, length(mean), length(sd), length(Lower),
length(Upper))
- mean = rep(mean, len = L); sd = rep(sd, len = L);
- Lower = rep(Lower, len = L); Upper = rep(Upper, len = L);
+ mean = rep(mean, len = L);
+ sd = rep(sd, len = L);
+ Lower = rep(Lower, len = L);
+ Upper = rep(Upper, len = L);
ans = rnorm(n = use.n, mean = mean, sd = sd)
cenL <- (ans < Lower)
@@ -1091,16 +1147,18 @@ tobit.control <- function(save.weight = TRUE, ...)
imethod > 2)
stop("argument 'imethod' must be 1 or 2")
if ( # length(Lower) != 1 || length(Upper) != 1 ||
- !is.numeric(Lower) || !is.numeric(Upper) ||
+ !is.numeric(Lower) ||
+ !is.numeric(Upper) ||
any(Lower >= Upper))
stop("Lower and Upper must ",
"be numeric with Lower < Upper")
if (length(zero) &&
- !is.Numeric(zero, integer.valued = TRUE))
+ !is.Numeric(zero, integer.valued = TRUE))
stop("bad input for argument 'zero'")
- if (!is.Numeric(nsimEIM, allowable.length = 1, integer.valued = TRUE) ||
+ if (!is.Numeric(nsimEIM, allowable.length = 1,
+ integer.valued = TRUE) ||
nsimEIM <= 10)
- stop("argument 'nsimEIM' should be an integer greater than 10")
+ stop("argument 'nsimEIM' should be an integer greater than 10")
if(mode(type.fitted) != "character" && mode(type.fitted) != "name")
type.fitted <- as.character(substitute(type.fitted))
@@ -1492,7 +1550,8 @@ tobit.control <- function(save.weight = TRUE, ...)
if (!is.list(esd)) esd <- list()
if (!is.list(evar)) evar <- list()
- if (!is.Numeric(imethod, allowable.length = 1, integer.valued = TRUE, positive = TRUE) ||
+ if (!is.Numeric(imethod, allowable.length = 1,
+ integer.valued = TRUE, positive = TRUE) ||
imethod > 3)
stop("argument 'imethod' must be 1 or 2 or 3")
if (!is.logical(var.arg) || length(var.arg) != 1)
@@ -1743,9 +1802,11 @@ tobit.control <- function(save.weight = TRUE, ...)
lmeanlog = as.character(substitute(lmeanlog))
if (mode(lsdlog) != "character" && mode(lsdlog) != "name")
lsdlog = as.character(substitute(lsdlog))
- if (length(zero) && (!is.Numeric(zero, integer.valued = TRUE, positive = TRUE) ||
- zero > 2))
+ if (length(zero) &&
+ (!is.Numeric(zero, integer.valued = TRUE, positive = TRUE) ||
+ zero > 2))
stop("bad input for argument argument 'zero'")
+
if (!is.list(emeanlog)) emeanlog = list()
if (!is.list(esdlog)) esdlog = list()
@@ -1838,15 +1899,18 @@ tobit.control <- function(save.weight = TRUE, ...)
{
- if (length(delta) && !is.Numeric(delta, positive = TRUE))
- stop("bad input for argument argument 'delta'")
+ if (length(delta) &&
+ !is.Numeric(delta, positive = TRUE))
+ stop("bad input for argument argument 'delta'")
if (mode(lmeanlog) != "character" && mode(lmeanlog) != "name")
- lmeanlog = as.character(substitute(lmeanlog))
+ lmeanlog = as.character(substitute(lmeanlog))
if (mode(lsdlog) != "character" && mode(lsdlog) != "name")
- lsdlog = as.character(substitute(lsdlog))
- if (length(zero) && (!is.Numeric(zero, integer.valued = TRUE, positive = TRUE) ||
- zero > 3))
- stop("bad input for argument argument 'zero'")
+ lsdlog = as.character(substitute(lsdlog))
+ if (length(zero) &&
+ (!is.Numeric(zero, integer.valued = TRUE, positive = TRUE) ||
+ zero > 3))
+ stop("bad input for argument argument 'zero'")
+
if (!is.list(emeanlog)) emeanlog = list()
if (!is.list(esdlog)) esdlog = list()
@@ -1963,39 +2027,39 @@ tobit.control <- function(save.weight = TRUE, ...)
dsnorm = function(x, location = 0, scale = 1, shape = 0, log = FALSE) {
- if (!is.logical(log.arg <- log))
- stop("bad input for argument 'log'")
- rm(log)
-
- if (!is.Numeric(scale, positive = TRUE))
- stop("bad input for argument 'scale'")
- zedd = (x - location) / scale
- loglik = log(2) + dnorm(zedd, log = TRUE) +
- pnorm(shape * zedd, log.p = TRUE) -
- log(scale)
- if (log.arg) {
- loglik
- } else {
- exp(loglik)
- }
+ if (!is.logical(log.arg <- log))
+ stop("bad input for argument 'log'")
+ rm(log)
+
+ if (!is.Numeric(scale, positive = TRUE))
+ stop("bad input for argument 'scale'")
+ zedd = (x - location) / scale
+ loglik = log(2) + dnorm(zedd, log = TRUE) +
+ pnorm(shape * zedd, log.p = TRUE) -
+ log(scale)
+ if (log.arg) {
+ loglik
+ } else {
+ exp(loglik)
+ }
}
rsnorm = function(n, location = 0, scale = 1, shape=0) {
- if (!is.Numeric(n, positive = TRUE,
- integer.valued = TRUE, allowable.length = 1))
- stop("bad input for argument 'n'")
- if (!is.Numeric(scale, positive = TRUE))
- stop("bad input for argument 'scale'")
- if (!is.Numeric(shape))
- stop("bad input for argument 'shape'")
-
- rho = shape / sqrt(1 + shape^2)
- u0 = rnorm(n)
- v = rnorm(n)
- u1 = rho*u0 + sqrt(1 - rho^2) * v
- location + scale * ifelse(u0 >= 0, u1, -u1)
+ if (!is.Numeric(n, positive = TRUE,
+ integer.valued = TRUE, allowable.length = 1))
+ stop("bad input for argument 'n'")
+ if (!is.Numeric(scale, positive = TRUE))
+ stop("bad input for argument 'scale'")
+ if (!is.Numeric(shape))
+ stop("bad input for argument 'shape'")
+
+ rho = shape / sqrt(1 + shape^2)
+ u0 = rnorm(n)
+ v = rnorm(n)
+ u1 = rho*u0 + sqrt(1 - rho^2) * v
+ location + scale * ifelse(u0 >= 0, u1, -u1)
}
@@ -2008,8 +2072,11 @@ rsnorm = function(n, location = 0, scale = 1, shape=0) {
lshape = as.character(substitute(lshape))
if (!is.list(earg)) earg = list()
if (length(nsimEIM) &&
- (!is.Numeric(nsimEIM, allowable.length = 1, integer.valued = TRUE) || nsimEIM <= 10))
- stop("argument 'nsimEIM' should be an integer greater than 10")
+ (!is.Numeric(nsimEIM, allowable.length = 1,
+ integer.valued = TRUE) ||
+ nsimEIM <= 10))
+ stop("argument 'nsimEIM' should be an integer greater than 10")
+
new("vglmff",
blurb = c("1-parameter Skew-normal distribution\n\n",
@@ -2028,7 +2095,8 @@ rsnorm = function(n, location = 0, scale = 1, shape=0) {
predictors.names =
namesof("shape", .lshape, earg = .earg, tag = FALSE)
if (!length(etastart)) {
- init.shape = if (length( .ishape)) rep( .ishape, len = n) else {
+ init.shape = if (length( .ishape))
+ rep( .ishape, len = n) else {
temp = y
index = abs(y) < sqrt(2/pi)-0.01
temp[!index] = y[!index]
diff --git a/R/family.positive.R b/R/family.positive.R
index 987dd13..d9697e0 100644
--- a/R/family.positive.R
+++ b/R/family.positive.R
@@ -50,20 +50,21 @@ rhuggins91 =
paste("x", 2:pvars, sep = ""))))
- linpred.baseline = xcoeff[1]
+ lin.pred.baseline = xcoeff[1]
if (pvars > 1)
- linpred.baseline = linpred.baseline +
- Xmatrix[, 2:pvars, drop = FALSE] %*% xcoeff[2:pvars]
+ lin.pred.baseline = lin.pred.baseline +
+ Xmatrix[, 2:pvars, drop = FALSE] %*%
+ xcoeff[2:pvars]
sumrowy = rep(0, length = use.n)
for (jlocal in 1:nTimePts) {
CHmatrix[, jlocal] = as.numeric(sumrowy > 0) *
(1 + double.ch)
- linpred = linpred.baseline + (CHmatrix[, jlocal] > 0) * capeffect
+ lin.pred = lin.pred.baseline + (CHmatrix[, jlocal] > 0) * capeffect
Ymatrix[, jlocal] = rbinom(use.n, size = 1,
- prob = eta2theta(linpred, link = link, earg = earg))
+ prob = eta2theta(lin.pred, link = link, earg = earg))
sumrowy = sumrowy + Ymatrix[, jlocal]
}
@@ -393,14 +394,16 @@ dposnegbin = function(x, size, prob = NULL, munb = NULL, log = FALSE) {
if (length(munb)) {
if (length(prob))
stop("'prob' and 'munb' both specified")
- prob <- size/(size + munb)
+ prob <- size / (size + munb)
}
- if (!is.logical(log.arg <- log)) stop("bad input for 'log'")
+ if (!is.logical(log.arg <- log))
+ stop("bad input for 'log'")
rm(log)
- L = max(length(x), length(prob), length(size))
- x = rep(x, len = L); prob = rep(prob, len = L);
- size = rep(size, len = L);
+ LLL = max(length(x), length(prob), length(size))
+ x = rep(x, len = LLL);
+ prob = rep(prob, len = LLL);
+ size = rep(size, len = LLL);
ans = dnbinom(x = x, size = size, prob = prob, log = log.arg)
index0 = (x == 0)
@@ -420,59 +423,43 @@ dposnegbin = function(x, size, prob = NULL, munb = NULL, log = FALSE) {
pposnegbin = function(q, size, prob = NULL, munb = NULL) {
+
if (length(munb)) {
if (length(prob))
stop("'prob' and 'munb' both specified")
- prob <- size/(size + munb)
+ prob <- size / (size + munb)
}
L = max(length(q), length(prob), length(size))
- q = rep(q, len = L); prob = rep(prob, len = L); size = rep(size, len = L)
+ if (length(q) != L)
+ q = rep(q, length.out = L);
+ if (length(prob) != L)
+ prob = rep(prob, length.out = L);
+ if (length(size) != L)
+ size = rep(size, length.out = L)
- ifelse(q < 1, 0, (pnbinom(q, size = size, prob = prob) -
- dnbinom(q*0, size = size, prob = prob))
- / pnbinom(q*0, size = size, prob = prob,
- lower.tail = FALSE))
+ ifelse(q < 1, 0,
+ (pnbinom(q, size = size, prob = prob) -
+ dnbinom(0, size = size, prob = prob))
+ / pnbinom(0, size = size, prob = prob, lower.tail = FALSE))
}
qposnegbin = function(p, size, prob = NULL, munb = NULL) {
- if (length(munb)) {
- if (length(prob))
- stop("'prob' and 'munb' both specified")
- prob <- size / (size + munb)
- }
- if (!is.Numeric(p, positive = TRUE) ||
- any(p >= 1))
- stop("bad input for argument 'p'")
- qnbinom(p * pnbinom(q = p*0, size = size, prob = prob,
- lower.tail = FALSE) +
- dnbinom(x = p*0, size = size, prob = prob),
- size = size, prob = prob)
-}
-
-
-rposnegbin = function(n, size, prob = NULL, munb = NULL) {
- use.n = if ((length.n <- length(n)) > 1) length.n else
- if (!is.Numeric(n, integer.valued = TRUE, allowable.length = 1, positive = TRUE))
- stop("bad input for argument 'n'") else n
-
if (length(munb)) {
if (length(prob))
stop("'prob' and 'munb' both specified")
prob <- size / (size + munb)
}
- ans = rnbinom(use.n, size = size, prob = prob)
- index = (ans == 0)
- size = rep(size, len = use.n)
- prob = rep(prob, len = use.n)
- while(any(index, na.rm = TRUE)) {
- more = rnbinom(n = sum(index), size = size[index],
- prob = prob[index])
- ans[index] = more
- index = (ans == 0)
- }
+
+ ans = qnbinom(pnbinom(q = 0, size = size, prob = prob,
+ lower.tail = FALSE) * p +
+ dnbinom(x = 0, size = size, prob = prob),
+ size = size, prob = prob)
+ ans[p > 1] = NaN
+ ans[p < 0] = NaN
+ ans[p == 1] = Inf
ans
}
@@ -483,6 +470,7 @@ rposnegbin = function(n, size, prob = NULL, munb = NULL) {
+
posnegbinomial.control <- function(save.weight = TRUE, ...)
{
list(save.weight = save.weight)
@@ -497,7 +485,8 @@ posnegbinomial.control <- function(save.weight = TRUE, ...)
shrinkage.init = 0.95, imethod = 1)
{
- if (!is.Numeric(imethod, allowable.length = 1, integer.valued = TRUE, positive = TRUE) ||
+ if (!is.Numeric(imethod, allowable.length = 1,
+ integer.valued = TRUE, positive = TRUE) ||
imethod > 2)
stop("argument 'imethod' must be 1 or 2")
if (length(isize) && !is.Numeric(isize, positive = TRUE))
@@ -516,7 +505,8 @@ posnegbinomial.control <- function(save.weight = TRUE, ...)
if (!is.list(esize)) esize = list()
- if (!is.Numeric(nsimEIM, allowable.length = 1, positive = TRUE, integer.valued = TRUE))
+ if (!is.Numeric(nsimEIM, allowable.length = 1,
+ positive = TRUE, integer.valued = TRUE))
stop("argument 'nsimEIM' must be a positive integer")
if (nsimEIM <= 30)
warning("argument 'nsimEIM' should be greater than 30, say")
@@ -751,35 +741,34 @@ pposgeom = function(q, prob) {
if (!is.Numeric(prob, positive = TRUE))
stop("bad input for argument 'prob'")
L = max(length(q), length(prob))
- if (length(q) != L) q = rep(q, len = L);
- if (length(prob) != L) prob = rep(prob, len = L);
- ifelse(q < 1, 0, (pgeom(q, prob) - prob) / (1 - prob))
+ if (length(q) != L) q = rep(q, length.out = L);
+ if (length(prob) != L) prob = rep(prob, length.out = L);
+ ifelse(q < 1, 0,
+ (pgeom(q, prob) -
+ dgeom(0, prob))
+ / pgeom(0, prob, lower.tail = FALSE))
}
qposgeom = function(p, prob) {
- if (!is.Numeric(prob, positive = TRUE))
- stop("bad input for argument 'prob'")
- if (!is.Numeric(p, positive = TRUE) || any(p >= 1))
- stop("bad input for argument 'p'")
- qgeom(p * (1 - prob) + prob, prob = prob)
+
+
+
+
+ ans = qgeom(pgeom(0, prob, lower.tail = FALSE) * p +
+ dgeom(0, prob),
+ prob = prob)
+ ans[p > 1] = NaN
+ ans[p < 0] = NaN
+ ans[p == 1] = Inf
+ ans
}
+
+
rposgeom = function(n, prob) {
- use.n = if ((length.n <- length(n)) > 1) length.n else
- if (!is.Numeric(n, integer.valued = TRUE, allowable.length = 1, positive = TRUE))
- stop("bad input for argument 'n'") else n
-
- ans = rgeom(use.n, prob = prob)
- prob = rep(prob, len = use.n)
- index = (ans == 0)
- while(any(index)) {
- more = rgeom(n = sum(index), prob[index])
- ans[index] = more
- index = (ans == 0)
- }
- ans
+ qgeom(p = runif(n, min = dgeom(0, prob)), prob)
}
@@ -788,6 +777,8 @@ rposgeom = function(n, prob) {
+
+
dpospois = function(x, lambda, log = FALSE) {
if (!is.logical(log.arg <- log)) stop("bad input for 'log'")
rm(log)
@@ -796,6 +787,7 @@ dpospois = function(x, lambda, log = FALSE) {
stop("bad input for argument 'lambda'")
L = max(length(x), length(lambda))
x = rep(x, len = L); lambda = rep(lambda, len = L);
+
ans = if (log.arg) {
ifelse(x == 0, log(0.0), dpois(x, lambda, log = TRUE) -
log1p(-exp(-lambda)))
@@ -810,36 +802,50 @@ ppospois = function(q, lambda) {
if (!is.Numeric(lambda, positive = TRUE))
stop("bad input for argument 'lambda'")
L = max(length(q), length(lambda))
- q = rep(q, len = L); lambda = rep(lambda, len = L);
- ifelse(q < 1, 0, (ppois(q, lambda) - exp(-lambda)) / (-expm1(-lambda)))
+ if (length(q) != L) q = rep(q, length.out = L);
+ if (length(lambda) != L) lambda = rep(lambda, length.out = L);
+
+ ifelse(q < 1, 0,
+ (ppois(q, lambda) -
+ dpois(0, lambda))
+ / ppois(0, lambda, lower.tail = FALSE))
}
qpospois = function(p, lambda) {
- if (!is.Numeric(lambda, positive = TRUE))
- stop("bad input for argument 'lambda'")
- if (!is.Numeric(p, positive = TRUE) || any(p >= 1))
- stop("bad input for argument 'p'")
- qpois(p * (-expm1(-lambda)) + exp(-lambda), lambda)
+
+
+ ans = qpois(ppois(0, lambda, lower.tail = FALSE) * p +
+ dpois(0, lambda),
+ lambda = lambda)
+
+ ans[p > 1] = NaN
+ ans[p < 0] = NaN
+ ans[p == 1] = Inf
+ ans
}
+
+
rpospois = function(n, lambda) {
- use.n = if ((length.n <- length(n)) > 1) length.n else
- if (!is.Numeric(n, integer.valued = TRUE, allowable.length = 1, positive = TRUE))
- stop("bad input for argument 'n'") else n
-
- if (any(lambda == 0))
- stop("no zero values allowed for argument 'lambda'")
- ans = rpois(use.n, lambda)
- lambda = rep(lambda, len = use.n)
- index = (ans == 0)
- while(any(index)) {
- more = rpois(n = sum(index), lambda[index])
- ans[index] = more
- index = (ans == 0)
+ qpois(p = runif(n, min = dpois(0, lambda)), lambda)
+}
+
+
+
+rposnegbin = function(n, size, prob = NULL, munb = NULL) {
+ if (!is.null(munb)) {
+ if (!is.null(prob))
+ stop("'prob' and 'mu' both specified")
+ qnbinom(p = runif(n,
+ min = dnbinom(0, size, mu = munb)),
+ size, mu = munb)
+ } else {
+ qnbinom(p = runif(n,
+ min = dnbinom(0, size, prob = prob )),
+ size, prob = prob )
}
- ans
}
@@ -858,7 +864,8 @@ rpospois = function(n, lambda) {
if (length( ilambda) && !is.Numeric(ilambda, positive = TRUE))
stop("bad input for argument 'ilambda'")
- if (!is.Numeric(imethod, allowable.length = 1, integer.valued = TRUE, positive = TRUE) ||
+ if (!is.Numeric(imethod, allowable.length = 1,
+ integer.valued = TRUE, positive = TRUE) ||
imethod > 3)
stop("argument 'imethod' must be 1 or 2 or 3")
@@ -953,60 +960,63 @@ rpospois = function(n, lambda) {
-pposbinom = function(q, size, prob, lower.tail = TRUE, log.p = FALSE) {
+pposbinom = function(q, size, prob
+ ) {
+
+
if (!is.Numeric(prob, positive = TRUE))
stop("no zero or non-numeric values allowed for argument 'prob'")
L = max(length(q), length(size), length(prob))
- q = rep(q, len = L); size = rep(size, len = L); prob = rep(prob, len = L)
+ if (length(q) != L) q = rep(q, length.out = L);
+ if (length(size) != L) size = rep(size, length.out = L);
+ if (length(prob) != L) prob = rep(prob, length.out = L);
+
ifelse(q < 1, 0,
- (pbinom(q = q, size = size, prob = prob, lower.tail = lower.tail,
- log.p = log.p) - (1-prob)^size) / (1 - (1-prob)^size))
+ (pbinom(q = q, size = size, prob = prob) -
+ dbinom(x = 0, size = size, prob = prob))
+ / pbinom(q = 0, size = size, prob = prob, lower.tail = FALSE))
}
-qposbinom = function(p, size, prob, lower.tail = TRUE, log.p = FALSE) {
- if (!is.Numeric(prob, positive = TRUE))
- stop("no zero or non-numeric values allowed for argument 'prob'")
- if (!is.Numeric(p, positive = TRUE) || any(p >= 1))
- stop("bad input for argument 'p'")
- qbinom(p = p * (1 - (1-prob)^size) + (1-prob)^size, size = size,
- prob = prob, lower.tail = lower.tail, log.p = log.p)
+qposbinom = function(p, size, prob
+ ) {
+
+
+
+
+ ans = qbinom(pbinom(0, size, prob, lower.tail = FALSE) * p +
+ dbinom(0, size, prob),
+ size = size, prob = prob)
+
+ ans[p > 1] = NaN
+ ans[p < 0] = NaN
+ ans[p == 1] = size[p == 1]
+ ans
}
+
rposbinom = function(n, size, prob) {
- use.n = if ((length.n <- length(n)) > 1) length.n else
- if (!is.Numeric(n, integer.valued = TRUE, allowable.length = 1, positive = TRUE))
- stop("bad input for argument 'n'") else n
-
- if (any(prob == 0))
- stop("no zero values allowed for argument 'prob'")
- ans = rbinom(n = use.n, size = size, prob = prob)
- index = (ans == 0)
- size = rep(size, len=length(ans))
- prob = rep(prob, len=length(ans))
- while(any(index)) {
- more = rbinom(n = sum(index), size[index], prob = prob[index])
- ans[index] = more
- index = (ans == 0)
- }
- ans
+ qbinom(p = runif(n, min = dbinom(0, size, prob)), size, prob)
}
+
dposbinom = function(x, size, prob, log = FALSE) {
log.arg = log
rm(log)
L = max(length(x), length(size), length(prob))
- x = rep(x, len = L); size = rep(size, len = L);
- prob = rep(prob, len = L);
+ x = rep(x, len = L);
+ size = rep(size, len = L);
+ prob = rep(prob, len = L);
answer = NaN * x
is0 <- (x == 0)
ok2 <- (prob > 0) & (prob <= 1) &
(size == round(size)) & (size > 0)
+
answer = dbinom(x = x, size = size, prob = prob, log = TRUE) -
- log1p(-dbinom(x = 0*x, size = size, prob = prob))
+ log1p(-dbinom(x = 0 , size = size, prob = prob))
answer[!ok2] = NaN
if (log.arg) {
answer[is0 & ok2] = log(0.0)
diff --git a/R/family.qreg.R b/R/family.qreg.R
index 046f754..f418a55 100644
--- a/R/family.qreg.R
+++ b/R/family.qreg.R
@@ -26,7 +26,7 @@ lms.yjn.control <- function(trace = TRUE, ...)
- lms.bcn <- function(percentiles = c(25,50,75),
+ lms.bcn <- function(percentiles = c(25, 50, 75),
zero = c(1, 3),
llambda = "identity",
lmu = "identity",
@@ -50,7 +50,8 @@ lms.yjn.control <- function(trace = TRUE, ...)
if (!is.Numeric(ilambda))
stop("bad input for argument 'ilambda'")
- if (length(isigma) && !is.Numeric(isigma, positive = TRUE))
+ if (length(isigma) &&
+ !is.Numeric(isigma, positive = TRUE))
stop("bad input for argument 'isigma'")
if (length(expectiles) != 1 || !is.logical(expectiles))
stop("bad input for argument 'expectiles'")
@@ -82,14 +83,14 @@ lms.yjn.control <- function(trace = TRUE, ...)
y = y, w = w, df = .dfmu.init)
fv.init = c(predict(Fit5, x = x[, min(ncol(x), 2)])$y)
- lambda.init = if (is.Numeric( .ilambda)) .ilambda else 1.0
+ lambda.init = if (is.Numeric( .ilambda )) .ilambda else 1.0
sigma.init = if (is.null(.isigma)) {
myratio = ((y/fv.init)^lambda.init - 1) / lambda.init
- if (is.Numeric( .dfsigma.init)) {
- fit600 = vsmooth.spline(x = x[, min(ncol(x), 2)],
- y = myratio^2,
- w = w, df = .dfsigma.init)
- sqrt(c(abs(predict(fit600, x = x[, min(ncol(x), 2)])$y)))
+ if (is.Numeric( .dfsigma.init )) {
+ fit600 = vsmooth.spline(x = x[, min(ncol(x), 2)],
+ y = myratio^2,
+ w = w, df = .dfsigma.init)
+ sqrt(c(abs(predict(fit600, x = x[, min(ncol(x), 2)])$y)))
} else
sqrt(var(myratio))
} else .isigma
@@ -105,9 +106,9 @@ lms.yjn.control <- function(trace = TRUE, ...)
.dfsigma.init = dfsigma.init,
.ilambda = ilambda, .isigma = isigma ))),
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[, 1] = eta2theta(eta[, 1], .llambda, earg = .elambda)
+ 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)
} else {
@@ -115,7 +116,7 @@ lms.yjn.control <- function(trace = TRUE, ...)
}
}, list( .llambda = llambda, .lmu = lmu, .lsigma = lsigma,
.elambda = elambda, .emu = emu, .esigma = esigma,
- .percentiles=percentiles, .expectiles = expectiles ))),
+ .percentiles = percentiles, .expectiles = expectiles ))),
last = eval(substitute(expression({
misc$percentiles = .percentiles
misc$links = c(lambda = .llambda, mu = .lmu, sigma = .lsigma)
@@ -128,12 +129,12 @@ lms.yjn.control <- function(trace = TRUE, ...)
}
}), list( .llambda = llambda, .lmu = lmu, .lsigma = lsigma,
.elambda = elambda, .emu = emu, .esigma = esigma,
- .percentiles=percentiles, .expectiles = expectiles ))),
+ .percentiles = percentiles, .expectiles = expectiles ))),
loglikelihood = eval(substitute(
function(mu,y, w, residuals= FALSE, eta, extra = NULL) {
- lambda = eta2theta(eta[,1], .llambda, earg = .elambda)
- muvec = eta2theta(eta[,2], .lmu, earg = .emu)
- sigma = eta2theta(eta[,3], .lsigma, earg = .esigma)
+ lambda = eta2theta(eta[, 1], .llambda, earg = .elambda)
+ muvec = eta2theta(eta[, 2], .lmu, earg = .emu)
+ sigma = eta2theta(eta[, 3], .lsigma, earg = .esigma)
zedd = ((y/muvec)^lambda - 1) / (lambda * sigma)
if (residuals) stop("loglikelihood residuals not ",
"implemented") else {
@@ -147,9 +148,9 @@ lms.yjn.control <- function(trace = TRUE, ...)
.elambda = elambda, .emu = emu, .esigma = esigma ))),
vfamily = c("lms.bcn", "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)
+ lambda = eta2theta(eta[, 1], .llambda, earg = .elambda)
+ mymu = eta2theta(eta[, 2], .lmu, earg = .emu)
+ sigma = eta2theta(eta[, 3], .lsigma, earg = .esigma)
zedd = ((y/mymu)^lambda - 1) / (lambda * sigma)
z2m1 = zedd * zedd - 1
dl.dlambda = zedd*(zedd - log(y/mymu) / sigma) / lambda -
@@ -179,7 +180,7 @@ lms.yjn.control <- function(trace = TRUE, ...)
- lms.bcg = function(percentiles = c(25,50,75),
+ lms.bcg = function(percentiles = c(25, 50, 75),
zero = c(1,3),
llambda = "identity",
lmu = "identity",
@@ -236,8 +237,9 @@ lms.yjn.control <- function(trace = TRUE, ...)
lambda.init = if (is.Numeric( .ilambda)) .ilambda else 1.0
sigma.init = if (is.null(.isigma)) {
- myratio=((y/fv.init)^lambda.init-1)/lambda.init #~(0,var=sigma^2)
- if (is.numeric( .dfsigma.init) && is.finite( .dfsigma.init)) {
+ myratio = ((y/fv.init)^lambda.init-1) / lambda.init
+ if (is.numeric( .dfsigma.init ) &&
+ is.finite( .dfsigma.init )) {
fit600 = vsmooth.spline(x = x[, min(ncol(x), 2)],
y=(myratio)^2,
w = w, df = .dfsigma.init)
@@ -257,13 +259,13 @@ lms.yjn.control <- function(trace = TRUE, ...)
.dfsigma.init = dfsigma.init,
.ilambda = ilambda, .isigma = isigma ))),
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[, 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)
}, list( .llambda = llambda, .lmu = lmu, .lsigma = lsigma,
.elambda = elambda, .emu = emu, .esigma = esigma,
- .percentiles=percentiles ))),
+ .percentiles = percentiles ))),
last = eval(substitute(expression({
misc$percentiles = .percentiles
misc$link = c(lambda = .llambda, mu = .lmu, sigma = .lsigma)
@@ -275,12 +277,12 @@ lms.yjn.control <- function(trace = TRUE, ...)
}
}), list( .llambda = llambda, .lmu = lmu, .lsigma = lsigma,
.elambda = elambda, .emu = emu, .esigma = esigma,
- .percentiles=percentiles ))),
+ .percentiles = percentiles ))),
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)
- sigma = eta2theta(eta[,3], .lsigma, earg = .esigma)
+ lambda = eta2theta(eta[, 1], .llambda, earg = .elambda)
+ mu = eta2theta(eta[, 2], .lmu, earg = .emu)
+ sigma = eta2theta(eta[, 3], .lsigma, earg = .esigma)
Gee = (y / mu)^lambda
theta = 1 / (sigma * lambda)^2
if (residuals) stop("loglikelihood residuals not ",
@@ -291,9 +293,9 @@ lms.yjn.control <- function(trace = TRUE, ...)
.elambda = elambda, .emu = emu, .esigma = esigma ))),
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)
+ lambda = eta2theta(eta[, 1], .llambda, earg = .elambda)
+ mymu = eta2theta(eta[, 2], .lmu, earg = .emu)
+ sigma = eta2theta(eta[, 3], .lsigma, earg = .esigma)
Gee = (y / mymu)^lambda
theta = 1 / (sigma * lambda)^2
@@ -344,15 +346,19 @@ lms.yjn.control <- function(trace = TRUE, ...)
dy.dpsi.yeojohnson = function(psi, lambda) {
L = max(length(psi), length(lambda))
- psi = rep(psi, length.out = L); lambda = rep(lambda, length.out = L);
- ifelse(psi>0, (1 + psi * lambda)^(1/lambda - 1),
- (1 - (2-lambda) * psi)^((lambda - 1)/(2-lambda)))
+ psi = rep(psi, length.out = L);
+ lambda = rep(lambda, length.out = L);
+
+ ifelse(psi > 0, (1 + psi * lambda)^(1/lambda - 1),
+ (1 - (2-lambda) * psi)^((lambda - 1) / (2-lambda)))
}
dyj.dy.yeojohnson = function(y, lambda) {
L = max(length(y), length(lambda))
- y = rep(y, length.out = L); lambda = rep(lambda, length.out = L);
+ y = rep(y, length.out = L);
+ lambda = rep(lambda, length.out = L);
+
ifelse(y>0, (1 + y)^(lambda - 1), (1 - y)^(1 - lambda))
}
@@ -371,46 +377,50 @@ dyj.dy.yeojohnson = function(y, lambda) {
if (!is.Numeric(epsilon, allowable.length = 1, positive = TRUE))
stop("argument 'epsilon' must be a single positive number")
L = max(length(lambda), length(y))
- if (length(y) != L) y = rep(y, length.out = L)
- if (length(lambda) != L) lambda = rep(lambda, length.out = L) # lambda may be of length 1
+ if (length(y) != L)
+ y = rep(y, length.out = L)
+ if (length(lambda) != L)
+ lambda = rep(lambda, length.out = L) # lambda may be of length 1
if (inverse) {
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
+ ans[index] = (y[index]*lambda[index] + 1)^(1/lambda[index]) - 1
if (any(index <- y >= 0 & abs(lambda) <= epsilon))
- ans[index] = expm1(y[index])
+ ans[index] = expm1(y[index])
if (any(index <- y < 0 & abs(lambda-2) > epsilon))
- ans[index] = 1-(-(2-lambda[index])*y[index]+1)^(1/(2-lambda[index]))
+ ans[index] = 1- (-(2-lambda[index]) *
+ y[index]+1)^(1/(2-lambda[index]))
if (any(index <- y < 0 & abs(lambda-2) <= epsilon))
ans[index] = -expm1(-y[index])
return(ans)
}
if (derivative == 0) {
if (any(index <- y >= 0 & abs(lambda) > epsilon))
- ans[index] = ((y[index]+1)^(lambda[index]) - 1) / lambda[index]
+ ans[index] = ((y[index]+1)^(lambda[index]) - 1) / lambda[index]
if (any(index <- y >= 0 & abs(lambda) <= epsilon))
- ans[index] = log1p(y[index])
+ ans[index] = log1p(y[index])
if (any(index <- y < 0 & abs(lambda-2) > epsilon))
- ans[index] = -((-y[index]+1)^(2-lambda[index])-1)/(2-lambda[index])
+ ans[index] = -((-y[index]+1)^(2-lambda[index]) - 1)/(2 -
+ lambda[index])
if (any(index <- y < 0 & abs(lambda-2) <= epsilon))
- ans[index] = -log1p(-y[index])
+ ans[index] = -log1p(-y[index])
} else {
psi <- Recall(y = y, lambda=lambda, derivative=derivative-1,
epsilon=epsilon, inverse=inverse)
if (any(index <- y >= 0 & abs(lambda) > epsilon))
- ans[index] = ( (y[index]+1)^(lambda[index]) *
- (log1p(y[index]))^(derivative) - derivative *
- psi[index] ) / lambda[index]
+ ans[index] = ( (y[index]+1)^(lambda[index]) *
+ (log1p(y[index]))^(derivative) - derivative *
+ psi[index] ) / lambda[index]
if (any(index <- y >= 0 & abs(lambda) <= epsilon))
- ans[index] = (log1p(y[index]))^(derivative + 1) / (derivative + 1)
+ ans[index] = (log1p(y[index]))^(derivative + 1) / (derivative+1)
if (any(index <- y < 0 & abs(lambda-2) > epsilon))
- ans[index] = -( (-y[index]+1)^(2-lambda[index]) *
- (-log1p(-y[index]))^(derivative) - derivative *
- psi[index] ) / (2-lambda[index])
+ ans[index] = -( (-y[index]+1)^(2-lambda[index]) *
+ (-log1p(-y[index]))^(derivative) - derivative *
+ psi[index] ) / (2-lambda[index])
if (any(index <- y < 0 & abs(lambda-2) <= epsilon))
- ans[index] = (-log1p(-y[index]))^(derivative + 1) / (derivative + 1)
+ ans[index] = (-log1p(-y[index]))^(derivative + 1) / (derivative+1)
}
ans
}
@@ -419,7 +429,9 @@ dyj.dy.yeojohnson = function(y, lambda) {
dpsi.dlambda.yjn = function(psi, lambda, mymu, sigma,
derivative = 0, smallno=1.0e-8) {
- if (!is.Numeric(derivative, allowable.length = 1, integer.valued = TRUE) || derivative<0)
+ if (!is.Numeric(derivative, allowable.length = 1,
+ integer.valued = TRUE) ||
+ derivative < 0)
stop("argument 'derivative' must be a non-negative integer")
if (!is.Numeric(smallno, allowable.length = 1, positive = TRUE))
stop("argument 'smallno' must be a single positive number")
@@ -446,7 +458,7 @@ 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
}
@@ -454,34 +466,40 @@ gh.weight.yjn.11 = function(z, lambda, mymu, sigma, derivmat = NULL) {
if (length(derivmat)) {
- ((derivmat[,2]/sigma)^2 + sqrt(2) * z * derivmat[,3] / sigma) / sqrt(pi)
+ ((derivmat[, 2]/sigma)^2 +
+ sqrt(2) * z * derivmat[, 3] / sigma) / sqrt(pi)
} else {
# 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) {
if (length(derivmat)) {
- (-derivmat[,2]) / (sqrt(pi) * sigma^2)
+ (-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
+ derivative = 1)[, 2]) / sigma^2
}
}
+
gh.weight.yjn.13 = function(z, lambda, mymu, sigma, derivmat = NULL) {
if (length(derivmat)) {
- sqrt(8 / pi) * (-derivmat[,2]) * z / sigma^2
+ 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
}
}
@@ -491,39 +509,39 @@ 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])
+ 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 +
+ (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
}
}
glag.weight.yjn.12 = function(z, lambda, mymu, sigma, derivmat = NULL) {
discontinuity = -mymu / (sqrt(2) * sigma)
if (length(derivmat)) {
- derivmat[,4] * (-derivmat[,2])
+ 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
+ (- 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
+ 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]) *
+ (-2 * dpsi.dlambda.yjn(psi, lambda, mymu, sigma, derivative = 1)[, 2]) *
(psi - mymu) / sigma^3
}
}
@@ -535,34 +553,35 @@ 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])
+ 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 +
+ (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
}
}
gleg.weight.yjn.12 = function(z, lambda, mymu, sigma, derivmat = NULL) {
if (length(derivmat)) {
- derivmat[,4] * (- derivmat[,2])
+ 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
+ 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
+ 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]) *
+ (-2 * dpsi.dlambda.yjn(psi, lambda, mymu, sigma, derivative = 1)[, 2]) *
(psi - mymu) / sigma^3
}
}
@@ -574,7 +593,7 @@ lms.yjn2.control <- function(save.weight = TRUE, ...)
list(save.weight=save.weight)
}
- lms.yjn2 = function(percentiles = c(25,50,75),
+ lms.yjn2 = function(percentiles = c(25, 50, 75),
zero = c(1,3),
llambda = "identity",
lmu = "identity",
@@ -599,9 +618,9 @@ 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, positive = TRUE))
+ if (length(isigma) &&
+ !is.Numeric(isigma, positive = TRUE))
stop("bad input for argument 'isigma'")
new("vglmff",
@@ -630,11 +649,12 @@ lms.yjn2.control <- function(save.weight = TRUE, ...)
y = y + yoff
if (!length(etastart)) {
- lambda.init = if (is.Numeric( .ilambda)) .ilambda else 1.
+ lambda.init = if (is.Numeric( .ilambda )) .ilambda else 1.
y.tx = yeo.johnson(y, lambda.init)
- fv.init =
- if (smoothok <- (length(unique(sort(x[, min(ncol(x), 2)]))) > 7)) {
+ fv.init =
+ if (smoothok <-
+ (length(unique(sort(x[, min(ncol(x), 2)]))) > 7)) {
fit700 = vsmooth.spline(x = x[, min(ncol(x), 2)],
y=y.tx, w = w, df = .dfmu.init)
c(predict(fit700, x = x[, min(ncol(x), 2)])$y)
@@ -643,22 +663,22 @@ lms.yjn2.control <- function(save.weight = TRUE, ...)
}
sigma.init = if (!is.Numeric(.isigma)) {
- if (is.Numeric( .dfsigma.init) && smoothok) {
- fit710 = vsmooth.spline(x = x[, min(ncol(x), 2)],
+ if (is.Numeric( .dfsigma.init) && smoothok) {
+ fit710 = vsmooth.spline(x = x[, min(ncol(x), 2)],
y = (y.tx - fv.init)^2,
w = w, df = .dfsigma.init)
- sqrt(c(abs(predict(fit710,
- x = x[, min(ncol(x), 2)])$y)))
- } else {
- sqrt( sum( w * (y.tx - fv.init)^2 ) / sum(w) )
- }
- } else
- .isigma
+ sqrt(c(abs(predict(fit710,
+ x = x[, min(ncol(x), 2)])$y)))
+ } else {
+ sqrt( sum( w * (y.tx - fv.init)^2 ) / sum(w) )
+ }
+ } else
+ .isigma
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[, 1] = theta2eta(lambda.init, .llambda, earg = .elambda)
+ etastart[, 2] = theta2eta(fv.init, .lmu, earg = .emu)
+ etastart[, 3] = theta2eta(sigma.init, .lsigma, earg = .esigma)
}
}), list(.llambda = llambda, .lmu = lmu, .lsigma = lsigma,
@@ -669,10 +689,11 @@ lms.yjn2.control <- function(save.weight = TRUE, ...)
.yoffset=yoffset,
.isigma = isigma))),
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)
- }, list(.percentiles=percentiles,
+ 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)
+ }, list(.percentiles = percentiles,
.esigma = esigma, .elambda = elambda,
.llambda = llambda,
.lsigma = lsigma))),
@@ -692,15 +713,15 @@ lms.yjn2.control <- function(save.weight = TRUE, ...)
eta0=matrix(c(lambda,mymu,sigma),
ncol=3, dimnames = list(dimnames(x)[[1]], NULL)))
}
- }), list(.percentiles=percentiles,
+ }), list(.percentiles = percentiles,
.elambda = elambda, .emu = emu, .esigma = esigma,
.nsimEIM=nsimEIM,
.llambda = llambda, .lmu = lmu, .lsigma = lsigma ))),
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)
- sigma = eta2theta(eta[,3], .lsigma, earg = .esigma)
+ lambda = eta2theta(eta[, 1], .llambda, earg = .elambda)
+ mu = eta2theta(eta[, 2], .lmu, earg = .emu)
+ sigma = eta2theta(eta[, 3], .lsigma, earg = .esigma)
psi = yeo.johnson(y, lambda)
if (residuals) stop("loglikelihood residuals not ",
"implemented yet") else
@@ -711,9 +732,9 @@ lms.yjn2.control <- function(save.weight = TRUE, ...)
.lsigma = lsigma ))),
vfamily = c("lms.yjn2", "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)
+ lambda = eta2theta(eta[, 1], .llambda, earg = .elambda)
+ mymu = eta2theta(eta[, 2], .lmu, earg = .emu)
+ sigma = eta2theta(eta[, 3], .lsigma, earg = .esigma)
dlambda.deta = dtheta.deta(lambda, link = .llambda, earg = .elambda)
dmu.deta = dtheta.deta(mymu, link = .lmu, earg = .emu)
dsigma.deta = dtheta.deta(sigma, link = .lsigma, earg = .esigma)
@@ -763,7 +784,7 @@ lms.yjn2.control <- function(save.weight = TRUE, ...)
}
- lms.yjn <- function(percentiles = c(25,50,75),
+ lms.yjn <- function(percentiles = c(25, 50, 75),
zero = c(1,3),
llambda = "identity",
lsigma = "loge",
@@ -772,7 +793,7 @@ lms.yjn2.control <- function(save.weight = TRUE, ...)
dfsigma.init = 2,
ilambda=1.0,
isigma = NULL,
- rule = c(10,5),
+ rule = c(10, 5),
yoffset = NULL,
diagW = FALSE, iters.diagW=6)
{
@@ -809,16 +830,17 @@ lms.yjn2.control <- function(save.weight = TRUE, ...)
namesof("sigma", .lsigma, earg = .esigma, short= TRUE))
y.save = y
- yoff = if (is.Numeric( .yoffset)) .yoffset else -median(y)
+ yoff = if (is.Numeric( .yoffset )) .yoffset else -median(y)
extra$yoffset = yoff
y = y + yoff
if (!length(etastart)) {
- lambda.init = if (is.Numeric( .ilambda)) .ilambda else 1.0
+ lambda.init = if (is.Numeric( .ilambda )) .ilambda else 1.0
y.tx = yeo.johnson(y, lambda.init)
- if (smoothok <- (length(unique(sort(x[, min(ncol(x), 2)]))) > 7)) {
+ if (smoothok <-
+ (length(unique(sort(x[, min(ncol(x), 2)]))) > 7)) {
fit700 = vsmooth.spline(x = x[, min(ncol(x), 2)],
y = y.tx, w = w, df = .dfmu.init)
fv.init = c(predict(fit700, x = x[, min(ncol(x), 2)])$y)
@@ -826,15 +848,16 @@ lms.yjn2.control <- function(save.weight = TRUE, ...)
fv.init = rep(weighted.mean(y, w), length.out = n)
}
- sigma.init = if (!is.Numeric(.isigma)) {
- if (is.Numeric( .dfsigma.init) && smoothok) {
- fit710 = vsmooth.spline(x = x[, min(ncol(x), 2)],
- y = (y.tx - fv.init)^2,
- w = w, df = .dfsigma.init)
+ sigma.init = if (!is.Numeric( .isigma )) {
+ if (is.Numeric( .dfsigma.init) &&
+ smoothok) {
+ fit710 = vsmooth.spline(x = x[, min(ncol(x), 2)],
+ y = (y.tx - fv.init)^2,
+ w = w, df = .dfsigma.init)
sqrt(c(abs(predict(fit710,
x = x[, min(ncol(x), 2)])$y)))
} else {
- sqrt( sum( w * (y.tx - fv.init)^2 ) / sum(w) )
+ sqrt( sum( w * (y.tx - fv.init)^2 ) / sum(w) )
}
} else
.isigma
@@ -854,36 +877,40 @@ lms.yjn2.control <- function(save.weight = TRUE, ...)
.yoffset=yoffset,
.isigma = isigma))),
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)
- }, list(.percentiles=percentiles,
- .esigma = esigma, .elambda = elambda,
+ 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)
+ }, list(.percentiles = percentiles,
+ .esigma = esigma,
+ .elambda = elambda,
.llambda = llambda,
.lsigma = lsigma))),
last = eval(substitute(expression({
- misc$percentiles = .percentiles
- misc$link = c(lambda = .llambda, mu = "identity", sigma = .lsigma)
- misc$earg = list(lambda = .elambda, mu = list(), sigma = .esigma)
- misc$true.mu = FALSE # $fitted is not a true mu
- misc[["yoffset"]] = extra$yoff
-
- y = y.save # Restore back the value; to be attached to object
-
- 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)))
- }
- }), list(.percentiles=percentiles,
+ misc$percentiles = .percentiles
+ misc$link = c(lambda = .llambda, mu = "identity", sigma = .lsigma)
+ misc$earg = list(lambda = .elambda, mu = list(), sigma = .esigma)
+ misc$true.mu = FALSE # $fitted is not a true mu
+ misc[["yoffset"]] = extra$yoff
+
+ y = y.save # Restore back the value; to be attached to object
+
+ 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)))
+ }
+ }), list(.percentiles = percentiles,
.esigma = esigma, .elambda = elambda,
.llambda = llambda,
.lsigma = lsigma))),
loglikelihood = eval(substitute(
function(mu,y, w, residuals= FALSE, eta, extra = NULL) {
- lambda = eta2theta(eta[,1], .llambda, earg = .elambda)
- mu = eta[,2]
- sigma = eta2theta(eta[,3], .lsigma, earg = .esigma)
+ lambda = eta2theta(eta[, 1], .llambda, earg = .elambda)
+ mu = eta[, 2]
+ sigma = eta2theta(eta[, 3], .lsigma, earg = .esigma)
psi = yeo.johnson(y, lambda)
if (residuals) stop("loglikelihood residuals not ",
"implemented yet") else
@@ -893,9 +920,9 @@ lms.yjn2.control <- function(save.weight = TRUE, ...)
.lsigma = lsigma, .llambda = llambda))),
vfamily = c("lms.yjn", "lmscreg"),
deriv = eval(substitute(expression({
- lambda = eta2theta(eta[,1], .llambda, earg = .elambda)
- mymu = eta[,2]
- sigma = eta2theta(eta[,3], .lsigma, earg = .esigma)
+ lambda = eta2theta(eta[, 1], .llambda, earg = .elambda)
+ mymu = eta[, 2]
+ sigma = eta2theta(eta[, 3], .lsigma, earg = .esigma)
psi = yeo.johnson(y, lambda)
d1 = yeo.johnson(y, lambda, deriv = 1)
@@ -921,33 +948,45 @@ lms.yjn2.control <- function(save.weight = TRUE, ...)
if (.rule == 10) {
- glag.abs = c(0.13779347054,0.729454549503,1.80834290174,3.40143369785,
- 5.55249614006,8.33015274676,11.8437858379,16.2792578314,
+ glag.abs = c(0.13779347054,0.729454549503,
+ 1.80834290174,3.40143369785,
+ 5.55249614006,8.33015274676,
+ 11.8437858379,16.2792578314,
21.996585812, 29.9206970123)
glag.wts = c(0.308441115765, 0.401119929155, 0.218068287612,
0.0620874560987, 0.00950151697517, 0.000753008388588,
2.82592334963e-5,
4.24931398502e-7, 1.83956482398e-9, 9.91182721958e-13)
} else {
- glag.abs = c(0.2635603197180449, 1.4134030591060496, 3.5964257710396850,
+ glag.abs = c(0.2635603197180449, 1.4134030591060496,
+ 3.5964257710396850,
7.0858100058570503, 12.6408008442729685)
- glag.wts = c(5.217556105826727e-01,3.986668110832433e-01,7.594244968176882e-02,
+ glag.wts = c(5.217556105826727e-01,3.986668110832433e-01,
+ 7.594244968176882e-02,
3.611758679927785e-03, 2.336997238583738e-05)
}
if (.rule == 10) {
- sgh.abs = c(0.03873852801690856, 0.19823332465268367, 0.46520116404433082,
- 0.81686197962535023, 1.23454146277833154, 1.70679833036403172,
- 2.22994030591819214, 2.80910399394755972, 3.46387269067033854,
+ sgh.abs = c(0.03873852801690856, 0.19823332465268367,
+ 0.46520116404433082,
+ 0.81686197962535023, 1.23454146277833154,
+ 1.70679833036403172,
+ 2.22994030591819214, 2.80910399394755972,
+ 3.46387269067033854,
4.25536209637269280)
- sgh.wts = c(9.855210713854302e-02,2.086780884700499e-01,2.520517066468666e-01,
- 1.986843323208932e-01,9.719839905023238e-02,2.702440190640464e-02,
- 3.804646170194185e-03, 2.288859354675587e-04, 4.345336765471935e-06,
+ sgh.wts = c(9.855210713854302e-02,2.086780884700499e-01,
+ 2.520517066468666e-01,
+ 1.986843323208932e-01,9.719839905023238e-02,
+ 2.702440190640464e-02,
+ 3.804646170194185e-03, 2.288859354675587e-04,
+ 4.345336765471935e-06,
1.247734096219375e-08)
} else {
- sgh.abs = c(0.1002421519682381, 0.4828139660462573, 1.0609498215257607,
+ sgh.abs = c(0.1002421519682381, 0.4828139660462573,
+ 1.0609498215257607,
1.7797294185202606, 2.6697603560875995)
- sgh.wts = c(0.2484061520284881475,0.3923310666523834311,0.2114181930760276606,
+ sgh.wts = c(0.2484061520284881475,0.3923310666523834311,
+ 0.2114181930760276606,
0.0332466603513424663, 0.0008248533445158026)
}
@@ -961,12 +1000,13 @@ lms.yjn2.control <- function(save.weight = TRUE, ...)
} else {
gleg.abs = c(-0.9061798459386643,-0.5384693101056820, 0,
0.5384693101056828, 0.9061798459386635)
- gleg.wts = c(0.2369268850561853,0.4786286704993680,0.5688888888888889,
+ gleg.wts = c(0.2369268850561853,0.4786286704993680,
+ 0.5688888888888889,
0.4786286704993661, 0.2369268850561916)
}
- discontinuity = -mymu/(sqrt(2)*sigma) # Needs to be near 0, eg within 4
+ discontinuity = -mymu/(sqrt(2)*sigma)
LL = pmin(discontinuity, 0)
@@ -974,21 +1014,23 @@ lms.yjn2.control <- function(save.weight = TRUE, ...)
if (FALSE) {
AA = (UU-LL)/2
for(kk in 1:length(gleg.wts)) {
- 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 = cbind(temp9, exp(-abscissae^2) / (sqrt(pi) * sigma^2))
-
- wz[,iam(1,1,M)] = wz[,iam(1,1,M)] + temp1 *
- gleg.weight.yjn.11(abscissae, lambda, mymu, sigma, temp9)
- wz[,iam(1,2,M)] = wz[,iam(1,2,M)] + temp1 *
- gleg.weight.yjn.12(abscissae, lambda, mymu, sigma, temp9)
- wz[,iam(1,3,M)] = wz[,iam(1,3,M)] + temp1 *
- gleg.weight.yjn.13(abscissae, lambda, mymu, sigma, temp9)
+ 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 = cbind(temp9, exp(-abscissae^2) / (sqrt(pi) * sigma^2))
+
+ wz[,iam(1,1,M)] = wz[,iam(1,1,M)] + temp1 *
+ gleg.weight.yjn.11(abscissae, lambda, mymu, sigma, temp9)
+ wz[,iam(1,2,M)] = wz[,iam(1,2,M)] + temp1 *
+ gleg.weight.yjn.12(abscissae, lambda, mymu, sigma, temp9)
+ wz[,iam(1,3,M)] = wz[,iam(1,3,M)] + temp1 *
+ gleg.weight.yjn.13(abscissae, lambda, mymu, sigma, temp9)
}
} else {
- temp9 = dotFortran(name = "yjngintf", as.double(LL), as.double(UU),
+ temp9 = dotFortran(name = "yjngintf", as.double(LL),
+ as.double(UU),
as.double(gleg.abs), as.double(gleg.wts), as.integer(n),
as.integer(length(gleg.abs)), as.double(lambda),
as.double(mymu), as.double(sigma), answer=double(3*n),
@@ -1005,7 +1047,8 @@ 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] *
@@ -1016,19 +1059,20 @@ lms.yjn2.control <- function(save.weight = TRUE, ...)
temp1 = exp(-discontinuity^2)
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 = cbind(temp9,
- 1 / (2 * sqrt((abscissae-discontinuity^2)^2 + discontinuity^2) *
+ 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 = cbind(temp9,
+ 1 / (2 * sqrt((abscissae-discontinuity^2)^2 +
+ discontinuity^2) *
sqrt(pi) * sigma^2))
- temp7 = temp1 * glag.wts[kk]
- wz[,iam(1,1,M)] = wz[,iam(1,1,M)] + temp7 *
- glag.weight.yjn.11(abscissae, lambda, mymu, sigma, temp9)
- wz[,iam(1,2,M)] = wz[,iam(1,2,M)] + temp7 *
- glag.weight.yjn.12(abscissae, lambda, mymu, sigma, temp9)
- wz[,iam(1,3,M)] = wz[,iam(1,3,M)] + temp7 *
- glag.weight.yjn.13(abscissae, lambda, mymu, sigma, temp9)
+ temp7 = temp1 * glag.wts[kk]
+ wz[,iam(1,1,M)] = wz[,iam(1,1,M)] + temp7 *
+ glag.weight.yjn.11(abscissae, lambda, mymu, sigma, temp9)
+ wz[,iam(1,2,M)] = wz[,iam(1,2,M)] + temp7 *
+ glag.weight.yjn.12(abscissae, lambda, mymu, sigma, temp9)
+ wz[,iam(1,3,M)] = wz[,iam(1,3,M)] + temp7 *
+ glag.weight.yjn.13(abscissae, lambda, mymu, sigma, temp9)
}
wz[,iam(1,1,M)] = wz[,iam(1,1,M)] * dlambda.deta^2
@@ -1104,7 +1148,8 @@ amlnormal.deviance = function(mu, y, w, residuals = FALSE, eta, extra = NULL) {
if (!is.Numeric(w.aml, positive = TRUE))
stop("argument 'w.aml' must be a vector of positive values")
- if (!is.Numeric(imethod, allowable.length = 1, integer.valued = TRUE, positive = TRUE) ||
+ if (!is.Numeric(imethod, allowable.length = 1,
+ integer.valued = TRUE, positive = TRUE) ||
imethod > 3)
stop("argument 'imethod' must be 1, 2 or 3")
@@ -1216,7 +1261,8 @@ amlnormal.deviance = function(mu, y, w, residuals = FALSE, eta, extra = NULL) {
-amlpoisson.deviance = function(mu, y, w, residuals = FALSE, eta, extra = NULL) {
+amlpoisson.deviance = function(mu, y, w, residuals = FALSE, eta,
+ extra = NULL) {
M <- length(extra$w.aml)
@@ -1270,8 +1316,9 @@ amlpoisson.deviance = function(mu, y, w, residuals = FALSE, eta, extra = NULL) {
extra$y.names = y.names =
paste("w.aml = ", round(extra$w.aml, digits = .digw), sep = "")
extra$individual = FALSE
- predictors.names = c(namesof(paste("expectile(",y.names,")", sep = ""),
- .link, earg = .earg, tag = FALSE))
+ predictors.names =
+ c(namesof(paste("expectile(",y.names,")", sep = ""),
+ .link , earg = .earg, tag = FALSE))
if (!length(etastart)) {
mean.init = if ( .imethod == 2)
@@ -1282,19 +1329,19 @@ amlpoisson.deviance = function(mu, y, w, residuals = FALSE, eta, extra = NULL) {
abs(junk$fitted)
}
etastart =
- matrix(theta2eta(mean.init, .link, earg = .earg), n, M)
+ matrix(theta2eta(mean.init, .link , earg = .earg), n, M)
}
}), list( .link = link, .earg = earg, .imethod = imethod,
.digw = digw, .w.aml = w.aml ))),
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)
+ mu.ans[,ii] = eta2theta(eta[,ii], .link , earg = .earg)
dimnames(mu.ans) = list(dimnames(eta)[[1]], extra$y.names)
mu.ans
}, list( .link = link, .earg = earg ))),
last = eval(substitute(expression({
- misc$link = rep(.link, length = M)
+ misc$link = rep(.link , length = M)
names(misc$link) = extra$y.names
misc$earg = vector("list", M)
names(misc$earg) = names(misc$link)
@@ -1311,12 +1358,12 @@ amlpoisson.deviance = function(mu, y, w, residuals = FALSE, eta, extra = NULL) {
names(extra$deviance) = extra$y.names
}), list( .link = link, .earg = earg, .parallel = parallel ))),
linkfun = eval(substitute(function(mu, extra = NULL) {
- theta2eta(mu, link = .link, earg = .earg)
+ 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)
+ 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,
byrow = TRUE))
@@ -1334,7 +1381,8 @@ amlpoisson.deviance = function(mu, y, w, residuals = FALSE, eta, extra = NULL) {
-amlbinomial.deviance = function(mu, y, w, residuals = FALSE, eta, extra = NULL) {
+amlbinomial.deviance = function(mu, y, w, residuals = FALSE,
+ eta, extra = NULL) {
M <- length(extra$w.aml)
@@ -1414,8 +1462,8 @@ amlbinomial.deviance = function(mu, y, w, residuals = FALSE, eta, extra = NULL)
} else if (NCOL(y) == 2) {
if (any(abs(y - round(y)) > 0.001))
stop("Count data must be integer-valued")
- nn = y[,1] + y[,2]
- y = ifelse(nn > 0, y[,1]/nn, 0)
+ nn = y[, 1] + y[, 2]
+ y = ifelse(nn > 0, y[, 1]/nn, 0)
w = w * nn
if (!length(mustart) && !length(etastart))
mustart = (0.5 + nn * y) / (1 + nn)
@@ -1433,10 +1481,10 @@ amlbinomial.deviance = function(mu, y, w, residuals = FALSE, eta, extra = NULL)
extra$individual = FALSE
predictors.names =
c(namesof(paste("expectile(", y.names, ")", sep = ""),
- .link, earg = .earg, tag = FALSE))
+ .link , earg = .earg, tag = FALSE))
if (!length(etastart)) {
- etastart = matrix(theta2eta(mustart, .link, earg = .earg), n, M)
+ etastart = matrix(theta2eta(mustart, .link , earg = .earg), n, M)
mustart = NULL
}
@@ -1446,12 +1494,12 @@ amlbinomial.deviance = function(mu, y, w, residuals = FALSE, 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)
+ mu.ans[,ii] = eta2theta(eta[,ii], .link , earg = .earg)
dimnames(mu.ans) = list(dimnames(eta)[[1]], extra$y.names)
mu.ans
}, list( .link = link, .earg = earg ))),
last = eval(substitute(expression({
- misc$link = rep(.link, length = M)
+ misc$link = rep(.link , length = M)
names(misc$link) = extra$y.names
misc$earg = vector("list", M)
names(misc$earg) = names(misc$link)
@@ -1468,14 +1516,14 @@ amlbinomial.deviance = function(mu, y, w, residuals = FALSE, eta, extra = NULL)
names(extra$deviance) = extra$y.names
}), list( .link = link, .earg = earg, .parallel = parallel ))),
linkfun = eval(substitute(function(mu, extra = NULL) {
- theta2eta(mu, link = .link, earg = .earg)
+ theta2eta(mu, link = .link , earg = .earg)
}, list( .link = link, .earg = earg ))),
vfamily = c("amlbinomial"),
deriv = eval(substitute(expression({
- mymu = eta2theta(eta, .link, earg = .earg)
+ 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)
+ 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))
@@ -1551,8 +1599,9 @@ amlexponential.deviance = function(mu, y, w, residuals = FALSE,
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)
+ amlexponential.deviance(mu = mu, y = y, w = w,
+ residuals = residuals,
+ eta = eta, extra = extra)
},
initialize = eval(substitute(expression({
extra$w.aml = .w.aml
@@ -1566,7 +1615,8 @@ amlexponential.deviance = function(mu, y, w, residuals = FALSE,
paste("w.aml = ", round(extra$w.aml, digits = .digw), sep = "")
extra$individual = FALSE
predictors.names = c(namesof(
- paste("expectile(",y.names,")", sep = ""), .link, earg = .earg, tag = FALSE))
+ paste("expectile(", y.names, ")", sep = ""),
+ .link , earg = .earg , tag = FALSE))
if (!length(etastart)) {
mean.init = if ( .imethod == 1)
@@ -1575,7 +1625,7 @@ amlexponential.deviance = function(mu, y, w, residuals = FALSE,
rep(weighted.mean(y, w), length = n) else {
1 / (y + 1)
}
- etastart = matrix(theta2eta(mean.init, .link, earg = .earg),
+ etastart = matrix(theta2eta(mean.init, .link , earg = .earg),
n, M)
}
}), list( .link = link, .earg = earg, .imethod = imethod,
@@ -1583,12 +1633,12 @@ amlexponential.deviance = function(mu, y, w, residuals = FALSE,
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)
+ mu.ans[,ii] = eta2theta(eta[,ii], .link , earg = .earg)
dimnames(mu.ans) = list(dimnames(eta)[[1]], extra$y.names)
mu.ans
}, list( .link = link, .earg = earg ))),
last = eval(substitute(expression({
- misc$link = rep(.link, length = M)
+ misc$link = rep(.link , length = M)
names(misc$link) = extra$y.names
misc$earg = vector("list", M)
names(misc$earg) = names(misc$link)
@@ -1605,14 +1655,14 @@ amlexponential.deviance = function(mu, y, w, residuals = FALSE,
names(extra$deviance) = extra$y.names
}), list( .link = link, .earg = earg, .parallel = parallel ))),
linkfun = eval(substitute(function(mu, extra = NULL) {
- theta2eta(mu, link = .link, earg = .earg)
+ theta2eta(mu, link = .link , earg = .earg)
}, list( .link = link, .earg = earg ))),
vfamily = c("amlexponential"),
deriv = eval(substitute(expression({
- mymu = eta2theta(eta, .link, earg = .earg)
+ mymu = eta2theta(eta, .link , earg = .earg)
bigy = matrix(y,extra$n,extra$M)
dl.dmu = (bigy - mymu) / mymu^2
- dmu.deta = dtheta.deta(mymu, .link, earg = .earg)
+ dmu.deta = dtheta.deta(mymu, .link , earg = .earg)
myresid = bigy - cbind(mymu)
wor1 = Wr2(myresid, w = matrix(extra$w.aml, extra$n, extra$M,
byrow = TRUE))
@@ -1639,8 +1689,10 @@ dalap = function(x, location = 0, scale = 1, tau = 0.5,
rm(log)
NN = max(length(x), length(location), length(scale), length(kappa))
- location = rep(location, length.out = NN); scale = rep(scale, length.out = NN)
- kappa = rep(kappa, length.out = NN); x = rep(x, length.out = NN)
+ location = rep(location, length.out = NN);
+ scale = rep(scale, length.out = NN)
+ kappa = rep(kappa, length.out = NN);
+ x = rep(x, length.out = NN)
tau = rep(tau, length.out = NN)
logconst = 0.5 * log(2) - log(scale) + log(kappa) - log1p(kappa^2)
@@ -1657,11 +1709,14 @@ 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))) {
use.n = if ((length.n <- length(n)) > 1) length.n else
- if (!is.Numeric(n, integer.valued = TRUE, allowable.length = 1, positive = TRUE))
+ if (!is.Numeric(n, integer.valued = TRUE,
+ allowable.length = 1, positive = TRUE))
stop("bad input for argument 'n'") else n
- location = rep(location, length.out = use.n); scale = rep(scale, length.out = use.n)
- tau = rep(tau, length.out = use.n); kappa = rep(kappa, length.out = use.n);
+ location = rep(location, length.out = use.n);
+ scale = rep(scale, length.out = use.n)
+ tau = rep(tau, length.out = use.n);
+ kappa = rep(kappa, length.out = use.n);
ans = location + scale *
log(runif(use.n)^kappa / runif(use.n)^(1/kappa)) / sqrt(2)
indexTF = (scale > 0) & (tau > 0) & (tau < 1) & (kappa > 0) # &
@@ -1673,8 +1728,10 @@ 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))) {
NN = max(length(q), length(location), length(scale), length(kappa))
- location = rep(location, length.out = NN); scale = rep(scale, length.out = NN)
- kappa = rep(kappa, length.out = NN); q= rep(q, length.out = NN)
+ location = rep(location, length.out = NN);
+ scale = rep(scale, length.out = NN)
+ kappa = rep(kappa, length.out = NN);
+ q = rep(q, length.out = NN)
tau = rep(tau, length.out = NN);
exponent = -(sqrt(2) / scale) * abs(q - location) *
@@ -1692,25 +1749,29 @@ palap = function(q, location = 0, scale = 1, tau = 0.5,
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, length.out = NN); scale = rep(scale, length.out = NN)
- kappa = rep(kappa, length.out = NN); p = rep(p, length.out = NN)
- tau = rep(tau, length.out = NN)
- ans = p
- temp5 = kappa^2 / (1 + kappa^2)
- index1 = (p <= temp5)
- exponent = p[index1] / temp5[index1]
- ans[index1] = location[index1] + (scale[index1] * kappa[index1]) *
- log(exponent) / sqrt(2)
- ans[!index1] = location[!index1] - (scale[!index1] / kappa[!index1]) *
- (log1p((kappa[!index1])^2) + log1p(-p[!index1])) / sqrt(2)
-
- indexTF = (scale > 0) & (tau > 0) & (tau < 1) & (kappa > 0) &
- (p >= 0) & (p <= 1)
- ans[!indexTF] = NaN
- ans[p == 0 & indexTF] = -Inf
- ans[p == 1 & indexTF] = Inf
- ans
+ NN = max(length(p), length(location), length(scale), length(kappa))
+ location = rep(location, length.out = NN);
+ scale = rep(scale, length.out = NN)
+ kappa = rep(kappa, length.out = NN);
+ p = rep(p, length.out = NN)
+ tau = rep(tau, length.out = NN)
+
+ ans = p
+ temp5 = kappa^2 / (1 + kappa^2)
+ index1 = (p <= temp5)
+ exponent = p[index1] / temp5[index1]
+ ans[index1] = location[index1] + (scale[index1] * kappa[index1]) *
+ log(exponent) / sqrt(2)
+ ans[!index1] = location[!index1] - (scale[!index1] / kappa[!index1]) *
+ (log1p((kappa[!index1])^2) +
+ log1p(-p[!index1])) / sqrt(2)
+
+ indexTF = (scale > 0) & (tau > 0) & (tau < 1) & (kappa > 0) &
+ (p >= 0) & (p <= 1)
+ ans[!indexTF] = NaN
+ ans[p == 0 & indexTF] = -Inf
+ ans[p == 1 & indexTF] = Inf
+ ans
}
@@ -1718,48 +1779,58 @@ qalap = function(p, location = 0, scale = 1, tau = 0.5,
if (FALSE)
dqregal = function(x, tau = 0.5, location = 0, scale = 1) {
- if (!is.Numeric(scale, positive = TRUE)) stop("'scale' must be positive")
- if (!is.Numeric(tau, positive = 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))
+ if (!is.Numeric(scale, positive = TRUE))
+ stop("'scale' must be positive")
+ if (!is.Numeric(tau, positive = TRUE) ||
+ max(tau) >= 1)
+ stop("argument 'tau' must have values in (0,1)")
+ const = tau * (1-tau) / scale
+ const * exp(-rho1check((x-location)/scale, tau = tau))
}
if (FALSE)
rqregal = function(n, tau = 0.5, location = 0, scale = 1) {
- if (!is.Numeric(n, positive = TRUE, integer.valued = TRUE, allowable.length = 1))
- stop("bad input for argument 'n'")
- if (!is.Numeric(scale, positive = TRUE)) stop("'scale' must be positive")
- if (!is.Numeric(tau, positive = TRUE) || max(tau) >= 1)
- stop("'tau' must have values in (0,1)")
- location = rep(location, length.out = n);
- scale = rep(scale, length.out = n)
- r = runif(n)
- location - sign(r-tau) * scale * log(2*ifelse(r < tau, r, 1-r))
+ if (!is.Numeric(n, positive = TRUE, integer.valued = TRUE,
+ allowable.length = 1))
+ stop("bad input for argument 'n'")
+ if (!is.Numeric(scale, positive = TRUE))
+ stop("'scale' must be positive")
+ if (!is.Numeric(tau, positive = TRUE) || max(tau) >= 1)
+ stop("'tau' must have values in (0,1)")
+
+ location = rep(location, length.out = n);
+ scale = rep(scale, length.out = n)
+ r = runif(n)
+ location - sign(r-tau) * scale * log(2*ifelse(r < tau, r, 1-r))
}
if (FALSE)
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, positive = TRUE)) stop("'scale' must be positive")
- if (!is.Numeric(tau, positive = 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, length.out = N); scale = rep(scale, length.out = N)
- tau = rep(tau, length.out = N); q= rep(q, length.out = N)
- ans = tau * exp(-(location - q) * (1 - tau))
- index1 = (q > location)
- ans[index1] = (1 - (1-tau) * exp(-tau * (q - location)))[index1]
- ans
+ 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, positive = TRUE))
+ stop("'scale' must be positive")
+ if (!is.Numeric(tau, positive = TRUE) || max(tau) >= 1)
+ stop("argument 'tau' must have values in (0,1)")
+
+ N = max(length(q), length(tau), length(location), length(scale))
+ location = rep(location, length.out = N);
+ scale = rep(scale, length.out = N)
+ tau = rep(tau, length.out = N);
+ q = rep(q, length.out = N)
+
+ ans = tau * exp(-(location - q) * (1 - tau))
+ index1 = (q > location)
+ ans[index1] = (1 - (1-tau) * exp(-tau * (q - location)))[index1]
+ ans
}
if (FALSE)
@@ -1772,10 +1843,12 @@ qregal = function(tau = c(0.25, 0.5, 0.75),
if (mode(llocation) != "character" && mode(llocation) != "name")
llocation = as.character(substitute(llocation))
- if (!is.Numeric(imethod, allowable.length = 1, integer.valued = TRUE, positive = TRUE) ||
- imethod > 2) stop("argument 'imethod' must be 1 or 2")
+ if (!is.Numeric(imethod, allowable.length = 1,
+ integer.valued = TRUE, positive = TRUE) ||
+ imethod > 2)
+ stop("argument 'imethod' must be 1 or 2")
if (!is.Numeric(tau, positive = TRUE) || max(tau) >= 1)
- stop("bad input for argument 'tau'")
+ stop("bad input for argument 'tau'")
if (!is.list(elocation)) elocation = list()
@@ -1784,26 +1857,27 @@ qregal = function(tau = c(0.25, 0.5, 0.75),
if (!is.list(escale)) escale = list()
new("vglmff",
- blurb = c("Quantile REGression via an Asymmetric Laplace distribution\n\n",
+ blurb = c("Quantile Regression via an ",
+ "Asymmetric Laplace distribution\n\n",
"Links: ",
- namesof("scale", lscale, earg =escale), ", ",
- namesof("location", llocation, earg =elocation)),
+ namesof("scale", lscale, earg = escale), ", ",
+ namesof("location", llocation, earg = elocation)),
constraints = eval(substitute(expression({
constraints = cm.vgam(matrix(1,M,1), x, .parallel, constraints)
}), 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")
+ stop("response must be a vector or a one-column matrix")
extra$M = M = 1 + length(extra$tau)
extra$n = n
extra$y.names = y.names =
- paste("tau = ", round(extra$tau, digits = .digt), sep = "")
+ paste("tau = ", round(extra$tau, digits = .digt ), sep = "")
extra$individual = FALSE
predictors.names = c(
- namesof("scale", .lscale, earg = .escale, tag = FALSE),
- namesof(paste("quantile(",y.names,")", sep = ""),
- link = .llocat, earg = .elocat, tag = FALSE))
+ namesof("scale", .lscale, earg = .escale , tag = FALSE),
+ namesof(paste("quantile(", y.names, ")", sep = ""),
+ link = .llocat , earg = .elocat , tag = FALSE))
if (!length(etastart)) {
if ( .imethod == 1) {
@@ -1857,28 +1931,32 @@ qregal = function(tau = c(0.25, 0.5, 0.75),
locmat = eta2theta(eta[, -1, drop = FALSE],
.llocat, earg = .elocat)
scalemat = matrix(eta2theta(eta[,1,drop = FALSE], .lscale,
- earg = .escale), nrow=extra$n, ncol=extra$M - 1)
- taumat = matrix(extra$tau, nrow=extra$n, ncol=extra$M - 1, byrow = TRUE)
- ymat = matrix(y, nrow=extra$n, ncol=extra$M - 1)
+ earg = .escale), nrow = extra$n, ncol = extra$M - 1)
+ taumat = matrix(extra$tau, nrow = extra$n, ncol = extra$M - 1, byrow = TRUE)
+ ymat = matrix(y, nrow = extra$n, ncol = extra$M - 1)
if (residuals) stop("loglikelihood residuals not ",
"implemented yet") else
sum(w * (-log(scalemat) + log(taumat) + log1p(-taumat) -
- rho1check((ymat-locmat)/scalemat, tau=taumat)))
+ rho1check((ymat-locmat)/scalemat, tau = taumat)))
}, list( .elocat = elocation, .llocat = llocation,
.escale = escale, .lscale = lscale, .tau = tau ))),
vfamily = c("qregal"),
deriv = eval(substitute(expression({
- ymat = matrix(y, nrow=extra$n, ncol=extra$M - 1)
- taumat = matrix(extra$tau, nrow=extra$n, ncol=extra$M - 1,
+ ymat = matrix(y, nrow = extra$n, ncol = extra$M - 1)
+ taumat = matrix(extra$tau, nrow = extra$n, ncol = extra$M - 1,
byrow = TRUE)
scalemat = matrix(eta2theta(eta[,1,drop = FALSE], .lscale,
- earg = .escale), nrow=extra$n, ncol=extra$M - 1)
+ earg = .escale),
+ nrow = extra$n, ncol = extra$M - 1)
locmat = eta2theta(eta[,-1,drop = FALSE], .llocat, earg = .elocat)
- dl.dlocation = taumat /scalemat
+
+ dl.dlocation = taumat / scalemat
index1 = (ymat < locmat)
- dl.dlocation[index1] = ((taumat - 1)/scalemat)[index1]
+ dl.dlocation[index1] = ((taumat - 1) / scalemat)[index1]
+
dlocation.deta = dtheta.deta(locmat, .llocat, earg = .elocat)
dscale.deta = dtheta.deta(scalemat, .lscale, earg = .escale)
+
c(w) * cbind(dl.dlocation * dlocation.deta)
}), list( .tau = tau, .elocat = elocation, .llocat = llocation,
.escale = escale, .lscale = lscale ))),
@@ -2002,19 +2080,23 @@ 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()) {
- logit(ralap(n=n, location=location.ald, scale=scale.ald,
- tau=tau, kappa=kappa), inverse = TRUE, earg = earg)
+ logit(ralap(n = n, location = location.ald, scale = scale.ald,
+ 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()) {
+ 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, length.out = NN); scale = rep(scale.ald, length.out = NN)
- kappa = rep(kappa, length.out = NN); x = rep(x, length.out = NN)
+ NN = max(length(x), length(location.ald),
+ length(scale.ald), length(kappa))
+ location = rep(location.ald, length.out = NN);
+ scale = rep(scale.ald, length.out = NN)
+ kappa = rep(kappa, length.out = NN);
+ x = rep(x, length.out = NN)
tau = rep(tau, length.out = NN)
Alpha = sqrt(2) * kappa / scale.ald
@@ -2034,9 +2116,10 @@ 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()) {
- qqq = qalap(p=p, location=location.ald, scale=scale.ald,
- tau=tau, kappa=kappa)
+ 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[(p < 0) | (p > 1)] = NaN
ans[p == 0] = 0
@@ -2047,19 +2130,21 @@ 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()) {
+ 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, length.out = NN); scale.ald= rep(scale.ald, length.out = NN)
+ location.ald = rep(location.ald, length.out = NN);
+ scale.ald= rep(scale.ald, length.out = NN)
kappa = rep(kappa, length.out = NN); q= rep(q, length.out = NN)
tau = rep(tau, length.out = NN);
indexTF = (q > 0) & (q < 1)
qqq = logit(q[indexTF], earg = earg)
ans = q
- ans[indexTF] = palap(q = qqq, location=location.ald[indexTF],
- scale=scale.ald[indexTF],
- tau=tau[indexTF], kappa=kappa[indexTF])
+ ans[indexTF] = palap(q = qqq, location = location.ald[indexTF],
+ scale = scale.ald[indexTF],
+ tau = tau[indexTF], kappa = kappa[indexTF])
ans[q >= 1] = 1
ans[q <= 0] = 0
ans
@@ -2069,8 +2154,8 @@ 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()) {
- probit(ralap(n=n, location=location.ald, scale=scale.ald,
- tau=tau, kappa=kappa), inverse = TRUE, earg = earg)
+ probit(ralap(n = n, location = location.ald, scale = scale.ald,
+ tau = tau, kappa = kappa), inverse = TRUE, earg = earg)
}
@@ -2080,8 +2165,10 @@ dprobitlap = function(x, location.ald = 0, scale.ald = 1, tau = 0.5,
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, length.out = NN); scale.ald= rep(scale.ald, length.out = NN)
+ NN = max(length(x), length(location.ald), length(scale.ald),
+ length(kappa))
+ location.ald = rep(location.ald, length.out = NN);
+ scale.ald= rep(scale.ald, length.out = NN)
kappa = rep(kappa, length.out = NN); x = rep(x, length.out = NN)
tau = rep(tau, length.out = NN)
@@ -2091,9 +2178,10 @@ dprobitlap = function(x, location.ald = 0, scale.ald = 1, tau = 0.5,
if (meth2) {
dx.dy = x
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)
+ logdensity[index1] =
+ dalap(x = use.x, location = location.ald[index1],
+ scale = scale.ald[index1], tau = tau[index1],
+ kappa = kappa[index1], log = TRUE)
} else {
Alpha = sqrt(2) * kappa / scale.ald
Beta = sqrt(2) / (scale.ald * kappa)
@@ -2101,8 +2189,8 @@ dprobitlap = function(x, location.ald = 0, scale.ald = 1, tau = 0.5,
use.x = qnorm(x) # qnorm(x[index1])
log.dy.dw = dnorm(use.x, log = TRUE)
- exponent = ifelse(x >= Delta, -Alpha, Beta) * (use.x - location.ald) -
- log.dy.dw
+ exponent = ifelse(x >= Delta, -Alpha, Beta) *
+ (use.x - location.ald) - log.dy.dw
logdensity[index1] = (log(Alpha) + log(Beta) -
log(Alpha + Beta) + exponent)[index1]
@@ -2112,10 +2200,12 @@ 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)
+ if (log.arg) logdensity - log(abs(dx.dy)) else
+ exp(logdensity) / abs(dx.dy)
} else {
if (log.arg) logdensity else exp(logdensity)
}
@@ -2123,42 +2213,48 @@ 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()) {
- qqq = qalap(p=p, location=location.ald, scale=scale.ald,
- tau=tau, kappa=kappa)
- ans = probit(qqq, inverse = TRUE, earg = earg)
- ans[(p < 0) | (p > 1)] = NaN
- ans[p == 0] = 0
- ans[p == 1] = 1
- ans
+ 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[(p < 0) | (p > 1)] = NaN
+ ans[p == 0] = 0
+ ans[p == 1] = 1
+ ans
}
pprobitlap = function(q, location.ald = 0, scale.ald = 1,
- tau = 0.5, kappa = sqrt(tau/(1-tau)), earg = list()) {
+ 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, length.out = NN); scale.ald= rep(scale.ald, length.out = NN)
- kappa = rep(kappa, length.out = NN); q= rep(q, length.out = NN)
+ location.ald = rep(location.ald, length.out = NN);
+ scale.ald= rep(scale.ald, length.out = NN)
+ kappa = rep(kappa, length.out = NN);
+ q= rep(q, length.out = NN)
tau = rep(tau, length.out = NN);
indexTF = (q > 0) & (q < 1)
qqq = probit(q[indexTF], earg = earg)
ans = q
- ans[indexTF] = palap(q = qqq, location=location.ald[indexTF],
- scale=scale.ald[indexTF],
- tau=tau[indexTF], kappa=kappa[indexTF])
+ ans[indexTF] = palap(q = qqq, location = location.ald[indexTF],
+ scale = scale.ald[indexTF],
+ tau = tau[indexTF], kappa = kappa[indexTF])
ans[q >= 1] = 1
ans[q <= 0] = 0
ans
}
+
+
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)
+ cloglog(ralap(n = n, location = location.ald, scale = scale.ald,
+ tau = tau, kappa = kappa), inverse = TRUE, earg = earg)
}
@@ -2168,9 +2264,12 @@ dclogloglap = function(x, location.ald = 0, scale.ald = 1, tau = 0.5,
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, length.out = NN); scale.ald= rep(scale.ald, length.out = NN)
- kappa = rep(kappa, length.out = NN); x = rep(x, length.out = NN)
+ NN = max(length(x), length(location.ald), length(scale.ald),
+ length(kappa))
+ location.ald = rep(location.ald, length.out = NN);
+ scale.ald= rep(scale.ald, length.out = NN)
+ kappa = rep(kappa, length.out = NN);
+ x = rep(x, length.out = NN)
tau = rep(tau, length.out = NN)
logdensity = x * NaN
@@ -2179,26 +2278,29 @@ dclogloglap = function(x, location.ald = 0, scale.ald = 1, tau = 0.5,
if (meth2) {
dx.dy = x
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)
+ logdensity[index1] =
+ dalap(x = use.w, location = location.ald[index1],
+ scale = scale.ald[index1],
+ tau = tau[index1],
+ kappa = kappa[index1], log = TRUE)
} else {
- Alpha = sqrt(2) * kappa / scale.ald
- Beta = sqrt(2) / (scale.ald * kappa)
- Delta = cloglog(location.ald, inverse = TRUE)
-
- exponent = ifelse(x >= Delta, -(Alpha+1), Beta-1) * log(-log1p(-x)) +
- ifelse(x >= Delta, Alpha, -Beta) * location.ald
- logdensity[index1] = (log(Alpha) + log(Beta) -
- log(Alpha + Beta) - log1p(-x) + exponent)[index1]
+ Alpha = sqrt(2) * kappa / scale.ald
+ Beta = sqrt(2) / (scale.ald * kappa)
+ Delta = cloglog(location.ald, inverse = TRUE)
+
+ exponent = ifelse(x >= Delta, -(Alpha+1), Beta-1) * log(-log1p(-x)) +
+ ifelse(x >= Delta, Alpha, -Beta) * location.ald
+ logdensity[index1] = (log(Alpha) + log(Beta) -
+ log(Alpha + Beta) - log1p(-x) + exponent)[index1]
}
logdensity[!indexTF] = NaN
logdensity[x < 0 & indexTF] = -Inf
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
@@ -2210,9 +2312,10 @@ 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()) {
- qqq = qalap(p=p, location=location.ald, scale=scale.ald,
- tau=tau, kappa=kappa)
+ 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[(p < 0) | (p > 1)] = NaN
ans[p == 0] = 0
@@ -2223,22 +2326,25 @@ 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()) {
- NN = max(length(q), length(location.ald), length(scale.ald),
- length(kappa))
- location.ald = rep(location.ald, length.out = NN); scale.ald= rep(scale.ald, length.out = NN)
- kappa = rep(kappa, length.out = NN); q= rep(q, length.out = NN)
- tau = rep(tau, length.out = NN);
-
- indexTF = (q > 0) & (q < 1)
- qqq = cloglog(q[indexTF], earg = earg)
- ans = q
- ans[indexTF] = palap(q = qqq, location=location.ald[indexTF],
- scale=scale.ald[indexTF],
- tau=tau[indexTF], kappa=kappa[indexTF])
- ans[q >= 1] = 1
- ans[q <= 0] = 0
- ans
+ 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, length.out = NN);
+ scale.ald= rep(scale.ald, length.out = NN)
+ kappa = rep(kappa, length.out = NN);
+ q= rep(q, length.out = NN)
+ tau = rep(tau, length.out = NN);
+
+ indexTF = (q > 0) & (q < 1)
+ qqq = cloglog(q[indexTF], earg = earg)
+ ans = q
+ ans[indexTF] = palap(q = qqq, location = location.ald[indexTF],
+ scale = scale.ald[indexTF],
+ tau = tau[indexTF], kappa = kappa[indexTF])
+ ans[q >= 1] = 1
+ ans[q <= 0] = 0
+ ans
}
@@ -2275,12 +2381,15 @@ alaplace2.control <- function(maxit = 100, ...)
if (!is.Numeric(kappa, positive = TRUE))
stop("bad input for argument 'kappa'")
- if (!is.Numeric(imethod, allowable.length = 1, integer.valued = TRUE, positive = TRUE) ||
- imethod > 4)
+ if (!is.Numeric(imethod, allowable.length = 1,
+ integer.valued = TRUE, positive = TRUE) ||
+ imethod > 4)
stop("argument 'imethod' must be 1, 2 or ... 4")
- if (length(iscale) && !is.Numeric(iscale, positive = TRUE))
+ if (length(iscale) &&
+ !is.Numeric(iscale, positive = TRUE))
stop("bad input for argument 'iscale'")
- if (!is.Numeric(shrinkage.init, allowable.length = 1) || shrinkage.init < 0 ||
+ if (!is.Numeric(shrinkage.init, allowable.length = 1) ||
+ shrinkage.init < 0 ||
shrinkage.init > 1)
stop("bad input for argument 'shrinkage.init'")
if (length(zero) &&
@@ -2288,7 +2397,8 @@ alaplace2.control <- function(maxit = 100, ...)
is.character(zero )))
stop("bad input for argument 'zero'")
- if (length(tau) && max(abs(kappa - sqrt(tau/(1-tau)))) > 1.0e-6)
+ if (length(tau) &&
+ max(abs(kappa - sqrt(tau / (1 - tau)))) > 1.0e-6)
stop("arguments 'kappa' and 'tau' do not match")
if (mode(llocat) != "character" && mode(llocat) != "name")
llocat = as.character(substitute(llocat))
@@ -2508,7 +2618,8 @@ alaplace2.control <- function(maxit = 100, ...)
y.use <- if (ncoly > 1) y[, ii] else y
extra$percentile[ii] = 100 * weighted.mean(y.use <= locat[, ii], w)
}
- names(extra$percentile) = y.names # if (ncoly > 1) names(misc$link) else zz
+ # if (ncoly > 1) names(misc$link) else zz:
+ names(extra$percentile) = y.names
}), list( .elocat = elocat, .llocat = llocat,
.escale = escale, .lscale = lscale,
.fittedMean = fittedMean,
@@ -2583,6 +2694,8 @@ alaplace2.control <- function(maxit = 100, ...)
+
+
alaplace1.control <- function(maxit = 100, ...)
{
list(maxit = maxit)
@@ -2590,13 +2703,15 @@ alaplace1.control <- function(maxit = 100, ...)
+
alaplace1 = function(tau = NULL,
llocation = "identity",
elocation = list(),
ilocation = NULL,
kappa = sqrt(tau/(1-tau)),
Scale.arg = 1,
- shrinkage.init = 0.95, parallelLocation = FALSE, digt = 4,
+ shrinkage.init = 0.95,
+ parallelLocation = FALSE, digt = 4,
dfmu.init = 3,
intparloc = FALSE,
imethod = 1) {
@@ -2604,20 +2719,22 @@ alaplace1.control <- function(maxit = 100, ...)
if (!is.Numeric(kappa, positive = TRUE))
- stop("bad input for argument 'kappa'")
+ 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")
+ stop("arguments 'kappa' and 'tau' do not match")
if (mode(llocation) != "character" && mode(llocation) != "name")
- llocation = as.character(substitute(llocation))
- if (!is.Numeric(imethod, allowable.length = 1, integer.valued = TRUE, positive = TRUE) ||
+ llocation = as.character(substitute(llocation))
+ if (!is.Numeric(imethod, allowable.length = 1,
+ integer.valued = TRUE, positive = TRUE) ||
imethod > 4)
stop("argument 'imethod' must be 1, 2 or ... 4")
if (!is.list(elocation)) elocation = list()
- if (!is.Numeric(shrinkage.init, allowable.length = 1) || shrinkage.init < 0 ||
+ if (!is.Numeric(shrinkage.init, allowable.length = 1) ||
+ shrinkage.init < 0 ||
shrinkage.init > 1)
- stop("bad input for argument 'shrinkage.init'")
+ stop("bad input for argument 'shrinkage.init'")
if (!is.Numeric(Scale.arg, positive = TRUE))
stop("bad input for argument 'Scale.arg'")
@@ -2633,7 +2750,8 @@ alaplace1.control <- function(maxit = 100, ...)
"Links: ",
namesof("location", llocation, earg = elocation),
"\n", "\n",
- "Mean: location + scale * (1/kappa - kappa) / sqrt(2)", "\n",
+ "Mean: location + scale * (1/kappa - kappa) / ",
+ "sqrt(2)", "\n",
"Quantiles: location", "\n",
"Variance: scale^2 * (1 + kappa^4) / (2 * kappa^2)"),
constraints = eval(substitute(expression({
@@ -2787,7 +2905,7 @@ alaplace1.control <- function(maxit = 100, ...)
y.use <- if (ncoly > 1) y[, ii] else y
extra$percentile[ii] = 100 * weighted.mean(y.use <= locat[, ii], w)
}
- names(extra$percentile) = y.names # if (ncoly > 1) names(misc$link) else zz
+ names(extra$percentile) = y.names
extra$Scale.arg = .Scale.arg
}), list( .elocat = elocation,
@@ -2859,13 +2977,16 @@ alaplace3.control <- function(maxit = 100, ...)
if (mode(lkappa) != "character" && mode(lkappa) != "name")
lkappa = as.character(substitute(lkappa))
- if (!is.Numeric(imethod, allowable.length = 1, integer.valued = TRUE, positive = TRUE) ||
+ if (!is.Numeric(imethod, allowable.length = 1,
+ integer.valued = TRUE, positive = TRUE) ||
imethod > 2)
- stop("argument 'imethod' must be 1 or 2")
- if (length(zero) && !is.Numeric(zero, integer.valued = TRUE, positive = TRUE))
- stop("bad input for argument 'zero'")
- if (length(iscale) && !is.Numeric(iscale, positive = TRUE))
- stop("bad input for argument 'iscale'")
+ stop("argument 'imethod' must be 1 or 2")
+ if (length(zero) &&
+ !is.Numeric(zero, integer.valued = TRUE, positive = TRUE))
+ stop("bad input for argument 'zero'")
+ if (length(iscale) &&
+ !is.Numeric(iscale, positive = TRUE))
+ stop("bad input for argument 'iscale'")
if (!is.list(elocation)) elocation = list()
if (!is.list(escale)) escale = list()
@@ -2918,9 +3039,9 @@ alaplace3.control <- function(maxit = 100, ...)
.llocat = llocation, .lscale = lscale, .lkappa = lkappa,
.ilocat = ilocation, .iscale = iscale, .ikappa = ikappa ))),
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)
+ location = eta2theta(eta[, 1], .llocat, earg = .elocat)
+ Scale = eta2theta(eta[, 2], .lscale, earg = .escale)
+ kappa = eta2theta(eta[, 3], .lkappa, earg = .ekappa)
location + Scale * (1/kappa - kappa) / sqrt(2)
}, list( .elocat = elocation, .llocat = llocation,
.escale = escale, .lscale = lscale,
@@ -2938,23 +3059,23 @@ alaplace3.control <- function(maxit = 100, ...)
.ekappa = ekappa, .lkappa = lkappa ))),
loglikelihood = eval(substitute(
function(mu, y, w, residuals = FALSE, eta, extra = NULL) {
- location = eta2theta(eta[,1], .llocat, earg = .elocat)
- Scale = eta2theta(eta[,2], .lscale, earg = .escale)
- kappamat = eta2theta(eta[,3], .lkappa, earg = .ekappa)
+ location = eta2theta(eta[, 1], .llocat, earg = .elocat)
+ Scale = eta2theta(eta[, 2], .lscale, earg = .escale)
+ kappamat = eta2theta(eta[, 3], .lkappa, earg = .ekappa)
if (residuals) {
stop("loglikelihood residuals not implemented yet")
} else {
- sum(w * dalap(x=y, location=location,
- scale=Scale, kappa=kappamat, log = TRUE))
+ sum(w * dalap(x = y, location = location,
+ scale=Scale, kappa = kappamat, log = TRUE))
}
}, list( .elocat = elocation, .llocat = llocation,
.escale = escale, .lscale = lscale,
.ekappa = ekappa, .lkappa = lkappa ))),
vfamily = c("alaplace3"),
deriv = eval(substitute(expression({
- location = eta2theta(eta[,1], .llocat, earg = .elocat)
- Scale = eta2theta(eta[,2], .lscale, earg = .escale)
- kappa = eta2theta(eta[,3], .lkappa, earg = .ekappa)
+ location = eta2theta(eta[, 1], .llocat, earg = .elocat)
+ Scale = eta2theta(eta[, 2], .lscale, earg = .escale)
+ kappa = eta2theta(eta[, 3], .lkappa, earg = .ekappa)
zedd = abs(y-location) / Scale
dl.dlocation = sqrt(2) * ifelse(y >= location, kappa, 1/kappa) *
sign(y-location) / Scale
@@ -2996,43 +3117,50 @@ alaplace3.control <- function(maxit = 100, ...)
dlaplace = function(x, location = 0, scale = 1, log = FALSE) {
- if (!is.logical(log.arg <- log))
- stop("bad input for argument 'log'")
- rm(log)
+ if (!is.logical(log.arg <- log))
+ stop("bad input for argument 'log'")
+ rm(log)
- logdensity = (-abs(x-location)/scale) - log(2*scale)
- if (log.arg) logdensity else exp(logdensity)
+ logdensity = (-abs(x-location)/scale) - log(2*scale)
+ if (log.arg) logdensity else exp(logdensity)
}
+
plaplace = function(q, location = 0, scale = 1) {
- if (!is.Numeric(scale, positive = TRUE))
- stop("argument 'scale' must be positive")
- zedd = (q-location) / scale
- L = max(length(q), length(location), length(scale))
- q = rep(q, length.out = L); location = rep(location, length.out = L);
- scale = rep(scale, length.out = L)
- ifelse(q < location, 0.5*exp(zedd), 1-0.5*exp(-zedd))
+ if (!is.Numeric(scale, positive = TRUE))
+ stop("argument 'scale' must be positive")
+ zedd = (q-location) / scale
+ L = max(length(q), length(location), length(scale))
+ q = rep(q, length.out = L);
+ location = rep(location, length.out = L);
+ scale = rep(scale, length.out = L)
+
+ ifelse(q < location, 0.5*exp(zedd), 1-0.5*exp(-zedd))
}
+
qlaplace = function(p, location = 0, scale = 1) {
- if (!is.Numeric(scale, positive = TRUE))
- stop("argument 'scale' must be positive")
- L = max(length(p), length(location), length(scale))
- p = rep(p, length.out = L); location = rep(location, length.out = L);
- scale = rep(scale, length.out = L)
- location - sign(p-0.5) * scale * log(2*ifelse(p < 0.5, p, 1-p))
+ if (!is.Numeric(scale, positive = TRUE))
+ stop("argument 'scale' must be positive")
+ L = max(length(p), length(location), length(scale))
+ p = rep(p, length.out = L);
+ location = rep(location, length.out = L);
+ scale = rep(scale, length.out = L)
+
+ location - sign(p-0.5) * scale * log(2*ifelse(p < 0.5, p, 1-p))
}
+
rlaplace = function(n, location = 0, scale = 1) {
- if (!is.Numeric(n, positive = TRUE,
- integer.valued = TRUE, allowable.length = 1))
- stop("bad input for argument 'n'")
- if (!is.Numeric(scale, positive = TRUE))
- stop("'scale' must be positive")
- location = rep(location, length.out = n);
- scale = rep(scale, length.out = n)
- r = runif(n)
- location - sign(r-0.5) * scale * log(2*ifelse(r < 0.5, r, 1-r))
+ if (!is.Numeric(n, positive = TRUE,
+ integer.valued = TRUE, allowable.length = 1))
+ stop("bad input for argument 'n'")
+ if (!is.Numeric(scale, positive = TRUE))
+ stop("'scale' must be positive")
+ location = rep(location, length.out = n);
+ scale = rep(scale, length.out = n)
+ r = runif(n)
+ location - sign(r-0.5) * scale * log(2 * ifelse(r < 0.5, r, 1-r))
}
@@ -3045,16 +3173,20 @@ rlaplace = function(n, location = 0, scale = 1) {
if (mode(lscale) != "character" && mode(lscale) != "name")
lscale = as.character(substitute(lscale))
- if (!is.Numeric(imethod, allowable.length = 1, integer.valued = TRUE, positive = TRUE) ||
- imethod > 3) stop("argument 'imethod' must be 1 or 2 or 3")
- if (length(zero) && !is.Numeric(zero, integer.valued = TRUE, positive = TRUE))
- stop("bad input for argument 'zero'")
+ if (!is.Numeric(imethod, allowable.length = 1,
+ integer.valued = TRUE, positive = TRUE) ||
+ imethod > 3)
+ stop("argument 'imethod' must be 1 or 2 or 3")
+ if (length(zero) &&
+ !is.Numeric(zero, integer.valued = TRUE, positive = TRUE))
+ stop("bad input for argument 'zero'")
if (!is.list(elocation)) elocation = list()
- if (!is.list(escale)) escale = list()
+ if (!is.list(escale)) escale = list()
- if (length(iscale) && !is.Numeric(iscale, positive = TRUE))
- stop("bad input for argument 'iscale'")
+ if (length(iscale) &&
+ !is.Numeric(iscale, positive = TRUE))
+ stop("bad input for argument 'iscale'")
new("vglmff",
blurb = c("Two-parameter Laplace distribution\n\n",
@@ -3069,10 +3201,10 @@ rlaplace = function(n, location = 0, scale = 1) {
}), list( .zero = zero ))),
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("location", .llocat, earg = .elocat, tag = FALSE),
- namesof("scale", .lscale, earg = .escale, tag = FALSE))
+ c(namesof("location", .llocat, earg = .elocat, tag = FALSE),
+ namesof("scale", .lscale, earg = .escale, tag = FALSE))
if (!length(etastart)) {
if ( .imethod == 1) {
locat.init = median(y)
@@ -3099,7 +3231,7 @@ rlaplace = function(n, location = 0, scale = 1) {
.llocat = llocation, .lscale = lscale,
.ilocat = ilocation, .iscale = iscale ))),
linkinv = eval(substitute(function(eta, extra = NULL) {
- eta2theta(eta[,1], .llocat, earg = .elocat)
+ eta2theta(eta[, 1], .llocat, earg = .elocat)
}, list( .elocat = elocation, .llocat = llocation ))),
last = eval(substitute(expression({
misc$link = c(location = .llocat, scale = .lscale)
@@ -3110,19 +3242,19 @@ rlaplace = function(n, location = 0, scale = 1) {
.elocat = elocation, .llocat = llocation ))),
loglikelihood = eval(substitute(
function(mu, y, w, residuals = FALSE, eta, extra = NULL) {
- location = eta2theta(eta[,1], .llocat, earg = .elocat)
- Scale = eta2theta(eta[,2], .lscale, earg = .escale)
+ location = eta2theta(eta[, 1], .llocat, earg = .elocat)
+ Scale = eta2theta(eta[, 2], .lscale, earg = .escale)
if (residuals) {
stop("loglikelihood residuals not implemented yet")
} else {
- sum(w * dlaplace(x=y, location=location, scale=Scale, log = TRUE))
+ sum(w * dlaplace(x = y, location = location, scale=Scale, log = TRUE))
}
}, list( .escale = escale, .lscale = lscale,
.elocat = elocation, .llocat = llocation ))),
vfamily = c("laplace"),
deriv = eval(substitute(expression({
- location = eta2theta(eta[,1], .llocat, earg = .elocat)
- Scale = eta2theta(eta[,2], .lscale, earg = .escale)
+ location = eta2theta(eta[, 1], .llocat, earg = .elocat)
+ Scale = eta2theta(eta[, 2], .lscale, earg = .escale)
zedd = abs(y-location) / Scale
dl.dlocation = sign(y-location) / Scale
dl.dscale = zedd / Scale - 1/Scale
@@ -3146,25 +3278,33 @@ rlaplace = function(n, location = 0, scale = 1) {
fff.control <- function(save.weight = TRUE, ...)
{
- list(save.weight = save.weight)
+ list(save.weight = save.weight)
}
+
fff = function(link = "loge", earg = list(),
idf1 = NULL, idf2 = NULL, nsimEIM = 100, # ncp = 0,
imethod = 1, zero = NULL) {
if (mode(link) != "character" && mode(link) != "name")
link = as.character(substitute(link))
- if (!is.Numeric(imethod, allowable.length = 1, integer.valued = TRUE, positive = TRUE) ||
- imethod > 2) stop("argument 'imethod' must be 1 or 2")
+ if (!is.Numeric(imethod, allowable.length = 1,
+ integer.valued = TRUE, positive = TRUE) ||
+ imethod > 2)
+ stop("argument 'imethod' must be 1 or 2")
- if (length(zero) && !is.Numeric(zero, integer.valued = TRUE, positive = TRUE))
- stop("bad input for argument 'zero'")
+ if (length(zero) &&
+ !is.Numeric(zero, integer.valued = TRUE, positive = TRUE))
+ stop("bad input for argument 'zero'")
if (!is.list(earg)) earg = list()
- if (!is.Numeric(nsimEIM, allowable.length = 1, integer.valued = TRUE) || nsimEIM <= 10)
- stop("argument 'nsimEIM' should be an integer greater than 10")
+ if (!is.Numeric(nsimEIM, allowable.length = 1,
+ integer.valued = TRUE) ||
+ nsimEIM <= 10)
+ stop("argument 'nsimEIM' should be an integer greater than 10")
+
ncp = 0
- if (any(ncp != 0)) warning("not sure about ncp != 0 wrt dl/dtheta")
+ if (any(ncp != 0))
+ warning("not sure about ncp != 0 wrt dl/dtheta")
new("vglmff",
blurb = c("F-distribution\n\n",
@@ -3179,18 +3319,18 @@ fff.control <- function(save.weight = TRUE, ...)
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 one-column matrix")
- predictors.names = c(namesof("df1", .link, earg = .earg, tag = FALSE),
- namesof("df2", .link, earg = .earg, tag = FALSE))
- if (!length(etastart)) {
- if ( .imethod == 1) {
- df2.init = b = 2*mean(y) / (mean(y)-1)
- df1.init = 2*b^2*(b-2)/(var(y)*(b-2)^2 * (b-4) - 2*b^2)
- if (df2.init < 4) df2.init = 5
- if (df1.init < 2) df1.init = 3
- } else {
+ initialize = eval(substitute(expression({
+ if (ncol(cbind(y)) != 1)
+ stop("response must be a vector or a one-column matrix")
+ predictors.names = c(namesof("df1", .link , earg = .earg, tag = FALSE),
+ namesof("df2", .link , earg = .earg, tag = FALSE))
+ if (!length(etastart)) {
+ if ( .imethod == 1) {
+ df2.init = b = 2*mean(y) / (mean(y)-1)
+ df1.init = 2*b^2*(b-2)/(var(y)*(b-2)^2 * (b-4) - 2*b^2)
+ if (df2.init < 4) df2.init = 5
+ if (df1.init < 2) df1.init = 3
+ } else {
df2.init = b = 2*median(y) / (median(y)-1)
summy = summary(y)
var.est = summy[5] - summy[2]
@@ -3202,19 +3342,19 @@ fff.control <- function(save.weight = TRUE, ...)
df2.init = if (length( .idf2))
rep( .idf2, length.out = n) else
rep(1, length.out = n)
- etastart = cbind(theta2eta(df1.init, .link, earg = .earg),
- theta2eta(df2.init, .link, earg = .earg))
+ 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 ))),
linkinv = eval(substitute(function(eta, extra = NULL) {
- df2 = eta2theta(eta[,2], .link, earg = .earg)
+ df2 = eta2theta(eta[, 2], .link , earg = .earg)
ans = df2 * NA
ans[df2>2] = df2[df2>2] / (df2[df2>2]-2)
ans
}, list( .link = link, .earg = earg ))),
last = eval(substitute(expression({
- misc$link = c(df1 = .link, df2 = .link)
+ misc$link = c(df1 = .link , df2 = .link)
misc$earg = list(df1 = .earg, df2 = .earg)
misc$nsimEIM = .nsimEIM
misc$ncp = .ncp
@@ -3223,18 +3363,18 @@ fff.control <- function(save.weight = TRUE, ...)
.nsimEIM = nsimEIM ))),
loglikelihood = eval(substitute(
function(mu, y, w, residuals = FALSE, eta, extra = NULL) {
- df1 = eta2theta(eta[,1], .link, earg = .earg)
- df2 = eta2theta(eta[,2], .link, earg = .earg)
+ df1 = eta2theta(eta[, 1], .link , earg = .earg)
+ df2 = eta2theta(eta[, 2], .link , earg = .earg)
if (residuals) {
stop("loglikelihood residuals not implemented yet")
} else {
- sum(w * df(x=y, df1=df1, df2=df2, ncp= .ncp, log = TRUE))
+ sum(w * df(x = y, df1=df1, df2=df2, ncp= .ncp, log = TRUE))
}
}, list( .link = link, .earg = earg, .ncp=ncp ))),
vfamily = c("fff"),
deriv = eval(substitute(expression({
- df1 = eta2theta(eta[,1], .link, earg = .earg)
- df2 = eta2theta(eta[,2], .link, earg = .earg)
+ df1 = eta2theta(eta[, 1], .link , earg = .earg)
+ df2 = eta2theta(eta[, 2], .link , earg = .earg)
dl.ddf1 = 0.5*digamma(0.5*(df1+df2)) + 0.5 + 0.5*log(df1/df2) +
0.5*log(y) - 0.5*digamma(0.5*df1) -
0.5*(df1+df2)*(y/df2) / (1 + df1*y/df2) -
@@ -3243,8 +3383,8 @@ fff.control <- function(save.weight = TRUE, ...)
0.5*digamma(0.5*df2) -
0.5*(df1+df2) * (-df1*y/df2^2) / (1 + df1*y/df2) -
0.5*log1p(df1*y/df2)
- ddf1.deta = dtheta.deta(df1, .link, earg = .earg)
- ddf2.deta = dtheta.deta(df2, .link, earg = .earg)
+ ddf1.deta = dtheta.deta(df1, .link , earg = .earg)
+ ddf2.deta = dtheta.deta(df2, .link , earg = .earg)
dthetas.detas = cbind(ddf1.deta, ddf2.deta)
w * dthetas.detas * cbind(dl.ddf1, dl.ddf2)
}), list( .link = link, .earg = earg ))),
@@ -3252,7 +3392,7 @@ fff.control <- function(save.weight = TRUE, ...)
run.varcov = 0
ind1 = iam(NA, NA, M=M, both = TRUE, diag = TRUE)
for(ii in 1:( .nsimEIM )) {
- ysim = rf(n=n, df1=df1, df2=df2)
+ ysim = rf(n = n, df1=df1, df2=df2)
dl.ddf1 = 0.5*digamma(0.5*(df1+df2)) + 0.5 + 0.5*log(df1/df2) +
0.5*log(ysim) - 0.5*digamma(0.5*df1) -
0.5*(df1+df2)*(ysim/df2) / (1 + df1*ysim/df2) -
@@ -3313,15 +3453,16 @@ fff.control <- function(save.weight = TRUE, ...)
} else if (NCOL(y) == 2) {
if (any(abs(y - round(y)) > 0.001))
stop("Count data must be integer-valued")
- nn = y[,1] + y[,2]
- y = ifelse(nn > 0, y[,1]/nn, 0)
+ nn = y[, 1] + y[, 2]
+ y = ifelse(nn > 0, y[, 1]/nn, 0)
w = w * nn
mustart = (0.5 + nn * y) / (1 + nn)
mustart[mustart >= 1] = 0.95
} else
stop("Response not of the right form")
- predictors.names = namesof("prob", .lprob, earg = .earg, tag = FALSE)
+ predictors.names = namesof("prob", .lprob ,
+ earg = .earg , tag = FALSE)
extra$Nvector = .N
extra$Dvector = .D
extra$Nunknown = length(extra$Nvector) == 0
@@ -3366,7 +3507,8 @@ fff.control <- function(save.weight = TRUE, ...)
sum(lgamma(1+N*prob) + lgamma(1+N*(1-prob)) -
- lgamma(1+N*prob-yvec) - lgamma(1+N*(1-prob) -w + yvec))
+ lgamma(1+N*prob-yvec) -
+ lgamma(1+N*(1-prob) -w + yvec))
}
}
}, list( .lprob = lprob, .earg = earg ))),
@@ -3378,13 +3520,16 @@ fff.control <- function(save.weight = TRUE, ...)
Nvec = extra$Nvector
yvec = w * y
if (extra$Nunknown) {
- tmp72 = -Dvec / prob^2
- tmp12 = Dvec * (1-prob) / prob
- dl.dprob = tmp72 * (digamma(1 + tmp12) + digamma(1 + Dvec/prob -w) -
- digamma(1 + tmp12-w+yvec) - digamma(1 + Dvec/prob))
+ tmp72 = -Dvec / prob^2
+ tmp12 = Dvec * (1-prob) / prob
+ dl.dprob = tmp72 * (digamma(1 + tmp12) +
+ digamma(1 + Dvec/prob -w) -
+ digamma(1 + tmp12-w+yvec) - digamma(1 + Dvec/prob))
} else {
- dl.dprob = Nvec * (digamma(1+Nvec*prob) - digamma(1+Nvec*(1-prob)) -
- digamma(1+Nvec*prob-yvec) + digamma(1+Nvec*(1-prob)-w+yvec))
+ dl.dprob = Nvec * (digamma(1+Nvec*prob) -
+ digamma(1+Nvec*(1-prob)) -
+ digamma(1+Nvec*prob-yvec) +
+ digamma(1+Nvec*(1-prob)-w+yvec))
}
w * dl.dprob * dprob.deta
}), list( .lprob = lprob, .earg = earg ))),
@@ -3423,7 +3568,9 @@ dbenini = function(x, shape, y0, log = FALSE) {
rm(log)
N = max(length(x), length(shape), length(y0))
- x = rep(x, length.out = N); shape = rep(shape, length.out = N); y0 = rep(y0, length.out = N);
+ x = rep(x, length.out = N);
+ shape = rep(shape, length.out = N);
+ y0 = rep(y0, length.out = N);
logdensity = rep(log(0), length.out = N)
xok = (x > y0)
@@ -3433,51 +3580,55 @@ dbenini = function(x, shape, y0, log = FALSE) {
if (log.arg) logdensity else exp(logdensity)
}
+
pbenini = function(q, shape, y0) {
- if (!is.Numeric(q))
- stop("bad input for argument 'q'")
- if (!is.Numeric(shape, positive = TRUE))
- stop("bad input for argument 'shape'")
- if (!is.Numeric(y0, positive = TRUE))
- stop("bad input for argument 'y0'")
- N = max(length(q), length(shape), length(y0))
- q = rep(q, length.out = N); shape = rep(shape, length.out = N); y0 = rep(y0, length.out = N);
- ans = y0 * 0
- ok = q > y0
- ans[ok] = -expm1(-shape[ok] * (log(q[ok]/y0[ok]))^2)
- ans
+ if (!is.Numeric(q))
+ stop("bad input for argument 'q'")
+ if (!is.Numeric(shape, positive = TRUE))
+ stop("bad input for argument 'shape'")
+ if (!is.Numeric(y0, positive = TRUE))
+ stop("bad input for argument 'y0'")
+ N = max(length(q), length(shape), length(y0))
+ q = rep(q, length.out = N);
+ shape = rep(shape, length.out = N);
+ y0 = rep(y0, length.out = N);
+
+ ans = y0 * 0
+ ok = q > y0
+ ans[ok] = -expm1(-shape[ok] * (log(q[ok]/y0[ok]))^2)
+ ans
}
+
qbenini = function(p, shape, y0) {
- if (!is.Numeric(p, positive = TRUE) || any(p >= 1))
- stop("bad input for argument 'p'")
- if (!is.Numeric(shape, positive = TRUE))
- stop("bad input for argument 'shape'")
- if (!is.Numeric(y0, positive = TRUE))
- stop("bad input for argument 'y0'")
- y0 * exp(sqrt(-log1p(-p) / shape))
+ if (!is.Numeric(p, positive = TRUE) ||
+ any(p >= 1))
+ stop("bad input for argument 'p'")
+ if (!is.Numeric(shape, positive = TRUE))
+ stop("bad input for argument 'shape'")
+ if (!is.Numeric(y0, positive = TRUE))
+ stop("bad input for argument 'y0'")
+ y0 * exp(sqrt(-log1p(-p) / shape))
}
+
rbenini = function(n, shape, y0) {
- if (!is.Numeric(n, positive = TRUE, integer.valued = TRUE, allowable.length = 1))
- stop("bad input for argument 'n'")
- if (!is.Numeric(shape, positive = TRUE))
- stop("bad input for argument 'shape'")
- if (!is.Numeric(y0, positive = TRUE))
- stop("bad input for argument 'y0'")
- y0 * exp(sqrt(-log(runif(n)) / shape))
+ y0 * exp(sqrt(-log(runif(n)) / shape))
}
+
benini = function(y0 = stop("argument 'y0' must be specified"),
lshape = "loge", earg = list(),
ishape = NULL, imethod = 1) {
if (mode(lshape) != "character" && mode(lshape) != "name")
lshape = as.character(substitute(lshape))
- if (!is.Numeric(imethod, allowable.length = 1, integer.valued = TRUE, positive = TRUE) ||
- imethod > 2) stop("argument 'imethod' must be 1 or 2")
+ if (!is.Numeric(imethod, allowable.length = 1,
+ integer.valued = TRUE, positive = TRUE) ||
+ imethod > 2)
+ stop("argument 'imethod' must be 1 or 2")
if (!is.Numeric(y0, allowable.length = 1, positive = TRUE))
- stop("bad input for argument 'y0'")
+ stop("bad input for argument 'y0'")
if (!is.list(earg)) earg = list()
@@ -3496,7 +3647,7 @@ rbenini = function(n, shape, 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
+ qofy = quantile(rep(y, times=w), probs=probs)
if ( .imethod == 1) {
shape.init = mean(-log1p(-probs) / (log(qofy))^2)
} else {
@@ -3507,7 +3658,9 @@ rbenini = function(n, shape, y0) {
rep(shape.init, length.out = n)
etastart = cbind(theta2eta(shape.init, .lshape, earg = .earg))
}
- }), list( .imethod = imethod, .ishape=ishape, .lshape = lshape, .earg = earg,
+ }), list( .imethod = imethod,
+ .ishape = ishape,
+ .lshape = lshape, .earg = earg,
.y0=y0 ))),
linkinv = eval(substitute(function(eta, extra = NULL) {
shape = eta2theta(eta, .lshape, earg = .earg)
@@ -3527,7 +3680,7 @@ rbenini = function(n, shape, y0) {
if (residuals) {
stop("loglikelihood residuals not implemented yet")
} else {
- sum(w * dbenini(x=y, shape=shape, y0=y0, log = TRUE))
+ sum(w * dbenini(x = y, shape=shape, y0=y0, log = TRUE))
}
}, list( .lshape = lshape, .earg = earg ))),
vfamily = c("benini"),
@@ -3577,16 +3730,20 @@ dpolono = function(x, meanlog = 0, sdlog = 1, bigx = Inf, ...) {
zedd = (log(x[ii])-meanlog[ii]) / sdlog[ii]
temp = 1 + (zedd^2 + log(x[ii]) - meanlog[ii] -
1) / (2*x[ii]*(sdlog[ii])^2)
- ans[ii] = temp * exp(-0.5*zedd^2)/(sqrt(2*pi)*sdlog[ii] * x[ii])
+ 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],
- meanlog=meanlog[ii], sdlog = sdlog[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] *
exp(lgamma(x[ii]+1)))
} else {
- warning("could not integrate (numerically) observation ",ii)
- ans[ii] = NA
+ warning("could not integrate (numerically) observation ",
+ ii)
+ ans[ii] = NA
}
}
}
@@ -3642,7 +3799,7 @@ ppolono <- function(q, meanlog = 0, sdlog = 1,
rpolono = function(n, meanlog = 0, sdlog = 1) {
- lambda = rlnorm(n = n, meanlog = meanlog, sdlog = sdlog)
+ lambda = rlnorm(n = n, meanlog = meanlog, sdlog = sdlog)
rpois(n = n, lambda = lambda)
}
@@ -3662,7 +3819,9 @@ dtriangle = function(x, theta, lower = 0, upper = 1, log = FALSE) {
rm(log)
N = max(length(x), length(theta), length(lower), length(upper))
- x = rep(x, length.out = N); lower = rep(lower, length.out = N); upper = rep(upper, length.out = N);
+ x = rep(x, length.out = N);
+ lower = rep(lower, length.out = N);
+ upper = rep(upper, length.out = N);
theta = rep(theta, length.out = N)
denom1 = ((upper-lower)*(theta-lower))
@@ -3670,8 +3829,10 @@ dtriangle = function(x, theta, lower = 0, upper = 1, log = FALSE) {
logdensity = rep(log(0), length.out = 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])
- logdensity[xok.pos] = log(2 * (upper[xok.pos]-x[xok.pos]) / denom2[xok.pos])
+ logdensity[xok.neg] =
+ log(2 * (x[xok.neg] - lower[xok.neg]) / denom1[xok.neg])
+ logdensity[xok.pos] =
+ log(2 * (upper[xok.pos] - x[xok.pos]) / denom2[xok.pos])
logdensity[lower >= upper] = NaN
logdensity[lower > theta] = NaN
logdensity[upper < theta] = NaN
@@ -3680,183 +3841,191 @@ dtriangle = function(x, theta, lower = 0, upper = 1, log = FALSE) {
rtriangle = function(n, theta, lower = 0, upper = 1) {
- if (!is.Numeric(n, integer.valued = TRUE,allowable.length = 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")
- N = n
- lower = rep(lower, length.out = N); upper = rep(upper, length.out = N);
- theta = rep(theta, length.out = N)
- t1 = sqrt(runif(n))
- t2 = sqrt(runif(n))
- ifelse(runif(n) < (theta-lower)/(upper-lower),
- lower + (theta-lower)*t1,
- upper - (upper-theta)*t2)
+ if (!is.Numeric(n, integer.valued = TRUE, allowable.length = 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")
+ N = n
+ lower = rep(lower, length.out = N);
+ upper = rep(upper, length.out = N);
+ theta = rep(theta, length.out = N)
+ t1 = sqrt(runif(n))
+ t2 = sqrt(runif(n))
+ ifelse(runif(n) < (theta - lower) / (upper - lower),
+ lower + (theta - lower) * t1,
+ upper - (upper - theta) * t2)
}
qtriangle = function(p, theta, lower = 0, upper = 1) {
- if (!is.Numeric(p, positive = 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")
-
- N = max(length(p), length(theta), length(lower), length(upper))
- p = rep(p, length.out = N); lower = rep(lower, length.out = N); upper = rep(upper, length.out = N);
- theta = rep(theta, length.out = N)
-
- bad = (p < 0) | (p > 1)
- if (any(bad))
- stop("bad input for argument 'p'")
-
- Neg = (p <= (theta - lower)/(upper - lower))
- ans = as.numeric(NA) * p
- temp1 = p * (upper-lower) * (theta-lower)
- ans[ Neg] = lower[ Neg] + sqrt(temp1[ Neg])
-
- Pos = (p >= (theta - lower)/(upper - lower))
- if (any(Pos)) {
- pstar = (p - (theta-lower)/(upper-lower)) / (1 -
- (theta-lower)/(upper-lower))
- qstar = cbind(1 - sqrt(1-pstar), 1 + sqrt(1-pstar))
- qstar = qstar[Pos,, drop = FALSE]
- qstar = ifelse(qstar[,1] >= 0 & qstar[,1] <= 1, qstar[,1], qstar[,2])
- ans[Pos] = theta[Pos] + qstar * (upper-theta)[Pos]
- }
- ans
+ if (!is.Numeric(p, positive = 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")
+
+ N = max(length(p), length(theta), length(lower), length(upper))
+ p = rep(p, length.out = N);
+ lower = rep(lower, length.out = N);
+ upper = rep(upper, length.out = N);
+ theta = rep(theta, length.out = N)
+
+ bad = (p < 0) | (p > 1)
+ if (any(bad))
+ stop("bad input for argument 'p'")
+
+ Neg = (p <= (theta - lower)/(upper - lower))
+ ans = as.numeric(NA) * p
+ temp1 = p * (upper - lower) * (theta - lower)
+ ans[ Neg] = lower[ Neg] + sqrt(temp1[ Neg])
+
+ Pos = (p >= (theta - lower)/(upper - lower))
+ if (any(Pos)) {
+ pstar = (p - (theta - lower)/(upper - lower)) / (1 -
+ (theta - lower) / (upper - lower))
+ qstar = cbind(1 - sqrt(1-pstar), 1 + sqrt(1-pstar))
+ qstar = qstar[Pos,, drop = FALSE]
+ qstar = ifelse(qstar[, 1] >= 0 & qstar[, 1] <= 1,
+ qstar[, 1],
+ qstar[, 2])
+ ans[Pos] = theta[Pos] + qstar * (upper-theta)[Pos]
+ }
+ ans
}
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")
-
- N = max(length(q), length(theta), length(lower), length(upper))
- q = rep(q, length.out = N); lower = rep(lower, length.out = N);
- upper = rep(upper, length.out = N);
- theta = rep(theta, length.out = N)
- ans = q * 0
-
- qstar = (q - lower)^2 / ((upper-lower) * (theta-lower))
- Neg = (lower <= q & q <= theta)
- ans[Neg] = (qstar)[Neg]
-
- Pos = (theta <= q & q <= upper)
- qstar = (q - theta) / (upper-theta)
- ans[Pos] = ((theta-lower)/(upper-lower))[Pos] +
- (qstar * (2-qstar) * (upper-theta) / (upper - lower))[Pos]
- ans[q >= upper] = 1
- ans
+ 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")
+
+ N = max(length(q), length(theta), length(lower), length(upper))
+ q = rep(q, length.out = N);
+ lower = rep(lower, length.out = N);
+ upper = rep(upper, length.out = N);
+ theta = rep(theta, length.out = N)
+ ans = q * 0
+
+ qstar = (q - lower)^2 / ((upper-lower) * (theta-lower))
+ Neg = (lower <= q & q <= theta)
+ ans[Neg] = (qstar)[Neg]
+
+ Pos = (theta <= q & q <= upper)
+ qstar = (q - theta) / (upper-theta)
+ ans[Pos] = ((theta-lower)/(upper-lower))[Pos] +
+ (qstar * (2-qstar) * (upper-theta) / (upper - lower))[Pos]
+ ans[q >= upper] = 1
+ ans
}
triangle = function(lower = 0, upper = 1,
link = "elogit", earg = if (link == "elogit")
- list(min = lower, max = upper) else list(), itheta = NULL)
+ 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 (!all(lower < upper))
- stop("lower < upper values are required")
- if (length(itheta) && !is.Numeric(itheta))
- stop("bad input for 'itheta'")
-
- if (mode(link) != "character" && mode(link) != "name")
- link = as.character(substitute(link))
- if (!is.list(earg)) earg = list()
+ 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")
+ if (length(itheta) && !is.Numeric(itheta))
+ stop("bad input for 'itheta'")
+
+ if (mode(link) != "character" && mode(link) != "name")
+ link = as.character(substitute(link))
+ if (!is.list(earg)) earg = list()
- new("vglmff",
- blurb = c(
- "Triangle distribution\n\n",
- "Link: ",
- namesof("theta", link, earg = earg)),
- initialize = eval(substitute(expression({
- y = as.numeric(y)
- if (ncol(cbind(y)) != 1)
- stop("response must be a vector or a one-column matrix")
- extra$lower = rep( .lower, length.out = n)
- extra$upper = rep( .upper, length.out = n)
+ new("vglmff",
+ blurb = c(
+ "Triangle distribution\n\n",
+ "Link: ",
+ namesof("theta", link, earg = earg)),
+ initialize = eval(substitute(expression({
+ y = as.numeric(y)
+ if (ncol(cbind(y)) != 1)
+ stop("response must be a vector or a one-column matrix")
+ extra$lower = rep( .lower, length.out = n)
+ extra$upper = rep( .upper, length.out = n)
- if (any(y <= extra$lower | y >= extra$upper))
- 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 {
- weighted.mean(y, w)
- }
- Theta.init = rep(Theta.init, length = n)
- etastart = theta2eta(Theta.init, .link, earg = .earg )
- }
- }), list( .link = link, .earg = earg, .itheta=itheta,
- .upper=upper, .lower=lower ))),
- linkinv = eval(substitute(function(eta, extra = NULL) {
- Theta = eta2theta(eta, .link, earg = .earg )
- lower = extra$lower
- upper = extra$upper
- mu = ((Theta^3 / 3 - lower * Theta^2 / 2 +
- lower^3 / 6) / (Theta - lower) +
- ((Theta^3 / 3 - upper * Theta^2 / 2 +
- upper^3 / 6) / (upper - Theta))) * 2 / (upper-lower)
- mu
- }, list( .link = link, .earg = earg ))),
- last = eval(substitute(expression({
- misc$link = c(theta = .link)
- misc$earg = list(theta = .earg)
- misc$expected = TRUE
- }), list( .link = link, .earg = earg ))),
- loglikelihood = eval(substitute(
- function(mu, y, w, residuals = FALSE, eta, extra = NULL) {
- Theta = eta2theta(eta, .link, earg = .earg )
- lower = extra$lower
- upper = extra$upper
- if (residuals) {
- stop("loglikelihood residuals not implemented yet")
- } else {
- sum(w * dtriangle(x=y, theta=Theta, lower=lower,
- upper=upper, log = TRUE))
+ if (any(y <= extra$lower | y >= extra$upper))
+ 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 {
+ weighted.mean(y, w)
}
- }, list( .link = link, .earg = earg ))),
- vfamily = c("triangle"),
- deriv = eval(substitute(expression({
- Theta = eta2theta(eta, .link, earg = .earg )
- dTheta.deta = dtheta.deta(Theta, .link, earg = .earg )
- pos = y > Theta
- neg = y < Theta
- lower = extra$lower
- upper = extra$upper
- dl.dTheta = 0 * y
- dl.dTheta[neg] = -1 / (Theta[neg]-lower[neg])
- dl.dTheta[pos] = 1 / (upper[pos]-Theta[pos])
- dl.dTheta * dTheta.deta
- }), list( .link = link, .earg = earg ))),
- weight = eval(substitute(expression({
- d2l.dTheta2 = 1 / ((Theta-lower)*(upper-Theta))
- wz = dTheta.deta^2 * d2l.dTheta2
- c(w) * wz
- }), list( .link = link, .earg = earg ))))
+ Theta.init = rep(Theta.init, length = n)
+ etastart = theta2eta(Theta.init, .link , earg = .earg )
+ }
+ }), list( .link = link, .earg = earg, .itheta=itheta,
+ .upper = upper, .lower = lower ))),
+ linkinv = eval(substitute(function(eta, extra = NULL) {
+ Theta = eta2theta(eta, .link , earg = .earg )
+ lower = extra$lower
+ upper = extra$upper
+ mu = ((Theta^3 / 3 - lower * Theta^2 / 2 +
+ lower^3 / 6) / (Theta - lower) +
+ ((Theta^3 / 3 - upper * Theta^2 / 2 +
+ upper^3 / 6) / (upper - Theta))) * 2 / (upper-lower)
+ mu
+ }, list( .link = link, .earg = earg ))),
+ last = eval(substitute(expression({
+ misc$link = c(theta = .link)
+ misc$earg = list(theta = .earg)
+ misc$expected = TRUE
+ }), list( .link = link, .earg = earg ))),
+ loglikelihood = eval(substitute(
+ function(mu, y, w, residuals = FALSE, eta, extra = NULL) {
+ Theta = eta2theta(eta, .link , earg = .earg )
+ lower = extra$lower
+ upper = extra$upper
+ if (residuals) {
+ stop("loglikelihood residuals not implemented yet")
+ } else {
+ sum(w * dtriangle(x = y, theta=Theta, lower = lower,
+ upper = upper, log = TRUE))
+ }
+ }, list( .link = link, .earg = earg ))),
+ vfamily = c("triangle"),
+ deriv = eval(substitute(expression({
+ Theta = eta2theta(eta, .link , earg = .earg )
+ dTheta.deta = dtheta.deta(Theta, .link , earg = .earg )
+ pos = y > Theta
+ neg = y < Theta
+ lower = extra$lower
+ upper = extra$upper
+ dl.dTheta = 0 * y
+ dl.dTheta[neg] = -1 / (Theta[neg]-lower[neg])
+ dl.dTheta[pos] = 1 / (upper[pos]-Theta[pos])
+ dl.dTheta * dTheta.deta
+ }), list( .link = link, .earg = earg ))),
+ weight = eval(substitute(expression({
+ d2l.dTheta2 = 1 / ((Theta-lower)*(upper-Theta))
+ wz = dTheta.deta^2 * d2l.dTheta2
+ c(w) * wz
+ }), list( .link = link, .earg = earg ))))
}
@@ -3883,39 +4052,47 @@ loglaplace1.control <- function(maxit = 300, ...)
ilocation = NULL,
kappa = sqrt(tau/(1-tau)),
Scale.arg = 1,
- shrinkage.init = 0.95, parallelLocation = FALSE, digt = 4,
+ shrinkage.init = 0.95,
+ parallelLocation = FALSE, digt = 4,
dfmu.init = 3,
rep0 = 0.5, # 0.0001,
minquantile = 0, maxquantile = Inf,
imethod = 1, zero = NULL) {
if (length(minquantile) != 1)
- stop("bad input for argument 'minquantile'")
+ stop("bad input for argument 'minquantile'")
if (length(maxquantile) != 1)
- stop("bad input for argument 'maxquantile'")
- if (!is.Numeric(rep0, positive = TRUE, allowable.length = 1) || rep0 > 1)
- stop("bad input for argument 'rep0'")
+ stop("bad input for argument 'maxquantile'")
+ if (!is.Numeric(rep0, positive = TRUE, allowable.length = 1) ||
+ rep0 > 1)
+ stop("bad input for argument 'rep0'")
if (!is.Numeric(kappa, positive = TRUE))
- stop("bad input for argument 'kappa'")
+ 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, allowable.length = 1, integer.valued = TRUE, positive = TRUE) ||
+ if (!is.Numeric(imethod, allowable.length = 1,
+ integer.valued = TRUE, positive = TRUE) ||
imethod > 4)
stop("argument 'imethod' must be 1, 2 or ... 4")
+
if (!is.list(elocation)) elocation = list()
- if (!is.Numeric(shrinkage.init, allowable.length = 1) || shrinkage.init < 0 ||
+ if (!is.Numeric(shrinkage.init, allowable.length = 1) ||
+ shrinkage.init < 0 ||
shrinkage.init > 1)
stop("bad input for argument 'shrinkage.init'")
if (length(zero) &&
- !(is.Numeric(zero, integer.valued = TRUE, positive = TRUE) || is.character(zero )))
- stop("bad input for argument 'zero'")
+ !(is.Numeric(zero, integer.valued = TRUE, positive = TRUE) ||
+ is.character(zero )))
+ stop("bad input for argument 'zero'")
if (!is.Numeric(Scale.arg, positive = TRUE))
- stop("bad input for argument 'Scale.arg'")
- if (!is.logical(parallelLocation) || length(parallelLocation) != 1)
- stop("bad input for argument 'parallelLocation'")
+ stop("bad input for argument 'Scale.arg'")
+ if (!is.logical(parallelLocation) ||
+ length(parallelLocation) != 1)
+ stop("bad input for argument 'parallelLocation'")
fittedMean = FALSE
if (!is.logical(fittedMean) || length(fittedMean) != 1)
stop("bad input for argument 'fittedMean'")
@@ -3926,6 +4103,7 @@ loglaplace1.control <- function(maxit = 300, ...)
mychars[nchar(mystring0)] = ", inverse = TRUE)"
mystring1 = paste(mychars, collapse = "")
+
new("vglmff",
blurb = c("One-parameter ",
if (llocation == "loge") "log-Laplace" else
@@ -4103,44 +4281,53 @@ loglaplace2.control <- function(save.weight = TRUE, ...)
imethod = 1, zero = "(1 + M/2):M") {
warning("it is best to use loglaplace1()")
- if (length(nsimEIM) &&
- (!is.Numeric(nsimEIM, allowable.length = 1, integer.valued = TRUE) || nsimEIM <= 10))
- stop("argument 'nsimEIM' should be an integer greater than 10")
- if (!is.Numeric(rep0, positive = TRUE, allowable.length = 1) || rep0 > 1)
- stop("bad input for argument 'rep0'")
- if (!is.Numeric(kappa, positive = 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 (length(nsimEIM) &&
+ (!is.Numeric(nsimEIM, allowable.length = 1,
+ integer.valued = TRUE) ||
+ nsimEIM <= 10))
+ stop("argument 'nsimEIM' should be an integer greater than 10")
+ if (!is.Numeric(rep0, positive = TRUE, allowable.length = 1) ||
+ rep0 > 1)
+ stop("bad input for argument 'rep0'")
+ if (!is.Numeric(kappa, positive = 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")
- lscale = as.character(substitute(lscale))
- if (!is.Numeric(imethod, allowable.length = 1, integer.valued = TRUE, positive = TRUE) ||
- imethod > 4) stop("argument 'imethod' must be 1, 2 or ... 4")
- if (length(iscale) && !is.Numeric(iscale, positive = TRUE))
- stop("bad input for argument 'iscale'")
+ 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.list(elocation)) elocation = list()
- if (!is.list(escale)) escale = list()
+ if (!is.Numeric(imethod, allowable.length = 1,
+ integer.valued = TRUE, positive = TRUE) ||
+ imethod > 4)
+ stop("argument 'imethod' must be 1, 2 or ... 4")
+ if (length(iscale) && !is.Numeric(iscale, positive = TRUE))
+ stop("bad input for argument 'iscale'")
- if (!is.Numeric(shrinkage.init, allowable.length = 1) || shrinkage.init < 0 ||
- shrinkage.init > 1) stop("bad input for argument 'shrinkage.init'")
- if (length(zero) &&
- !(is.Numeric(zero, integer.valued = TRUE, positive = TRUE) ||
- is.character(zero )))
- stop("bad input for argument 'zero'")
- if (!is.logical(sameScale) || length(sameScale) != 1)
- stop("bad input for argument 'sameScale'")
- if (!is.logical(parallelLocation) || length(parallelLocation) != 1)
- stop("bad input for argument 'parallelLocation'")
- fittedMean = FALSE
- if (!is.logical(fittedMean) || length(fittedMean) != 1)
- stop("bad input for argument 'fittedMean'")
+ if (!is.list(elocation)) elocation = list()
+ if (!is.list(escale)) escale = list()
+
+ if (!is.Numeric(shrinkage.init, allowable.length = 1) ||
+ shrinkage.init < 0 ||
+ shrinkage.init > 1)
+ stop("bad input for argument 'shrinkage.init'")
+ if (length(zero) &&
+ !(is.Numeric(zero, integer.valued = TRUE, positive = TRUE) ||
+ is.character(zero )))
+ stop("bad input for argument 'zero'")
+ if (!is.logical(sameScale) || length(sameScale) != 1)
+ stop("bad input for argument 'sameScale'")
+ if (!is.logical(parallelLocation) || length(parallelLocation) != 1)
+ stop("bad input for argument 'parallelLocation'")
+ fittedMean = FALSE
+ if (!is.logical(fittedMean) || length(fittedMean) != 1)
+ stop("bad input for argument 'fittedMean'")
+
+ if (llocation != "loge")
+ stop("argument 'llocation' must be \"loge\"")
- if (llocation != "loge")
- stop("argument 'llocation' must be \"loge\"")
new("vglmff",
blurb = c("Two-parameter log-Laplace distribution\n\n",
@@ -4148,7 +4335,8 @@ loglaplace2.control <- function(save.weight = TRUE, ...)
namesof("location", llocation, earg = elocation), ", ",
namesof("scale", lscale, earg = escale),
"\n", "\n",
- "Mean: zz location + scale * (1/kappa - kappa) / sqrt(2)", "\n",
+ "Mean: zz location + scale * ",
+ "(1/kappa - kappa) / sqrt(2)", "\n",
"Quantiles: location", "\n",
"Variance: zz scale^2 * (1 + kappa^4) / (2 * kappa^2)"),
constraints = eval(substitute(expression({
@@ -4161,7 +4349,8 @@ loglaplace2.control <- function(save.weight = TRUE, ...)
matrix(1, M/2, 1) else diag(M/2)
mycmatrix = cbind(rbind( parelHmat, 0*parelHmat),
rbind(0*scaleHmat, scaleHmat))
- constraints=cm.vgam(mycmatrix, x, .PARALLEL, constraints, int = FALSE)
+ constraints = cm.vgam(mycmatrix, x, .PARALLEL, constraints,
+ int = FALSE)
constraints = cm.zero.vgam(constraints, x, .ZERO, M)
if ( .PARALLEL && names(constraints)[1] == "(Intercept)") {
@@ -4258,7 +4447,8 @@ loglaplace2.control <- function(save.weight = TRUE, ...)
extra$percentile = numeric(length(misc$kappa))
location = as.matrix(location.y)
for(ii in 1:length(misc$kappa))
- extra$percentile[ii] = 100 * weighted.mean(y <= location.y[,ii], w)
+ extra$percentile[ii] = 100 *
+ weighted.mean(y <= location.y[,ii], w)
}), list( .elocat = elocation, .llocat = llocation,
.escale = escale, .lscale = lscale,
.fittedMean = fittedMean,
@@ -4267,13 +4457,14 @@ loglaplace2.control <- function(save.weight = TRUE, ...)
loglikelihood = eval(substitute(
function(mu, y, w, residuals = FALSE, eta, extra = NULL) {
kappamat = matrix(extra$kappa, extra$n, extra$M/2, byrow = TRUE)
- Scale.w = eta2theta(eta[,(1+extra$M/2):extra$M], .lscale, earg = .escale)
+ Scale.w = eta2theta(eta[,(1+extra$M/2):extra$M],
+ .lscale, earg = .escale)
ymat = matrix(y, extra$n, extra$M/2)
ymat[ymat <= 0] = min(min(y[y > 0]), .rep0) # Adjust for 0s
ell.mat = matrix(c(dloglaplace(x = c(ymat),
- location.ald = c(eta[,1:(extra$M/2)]),
- scale.ald = c(Scale.w),
- kappa = c(kappamat), log = TRUE)),
+ location.ald = c(eta[,1:(extra$M/2)]),
+ scale.ald = c(Scale.w),
+ kappa = c(kappamat), log = TRUE)),
extra$n, extra$M/2)
if (residuals) {
stop("loglikelihood residuals not implemented yet")
@@ -4286,7 +4477,8 @@ loglaplace2.control <- function(save.weight = TRUE, ...)
vfamily = c("loglaplace2"),
deriv = eval(substitute(expression({
ymat = matrix(y, n, M/2)
- Scale.w = eta2theta(eta[,(1+extra$M/2):extra$M], .lscale, earg = .escale)
+ Scale.w = eta2theta(eta[,(1+extra$M/2):extra$M],
+ .lscale, earg = .escale)
location.w = eta[,1:(extra$M/2), drop = FALSE]
location.y = eta2theta(location.w, .llocat, earg = .elocat)
kappamat = matrix(extra$kappa, n, M/2, byrow = TRUE)
@@ -4327,7 +4519,7 @@ loglaplace2.control <- function(save.weight = TRUE, ...)
rm(wsim)
temp3 = cbind(dl.dlocation, dl.dscale) # n x M matrix
run.varcov = ((ii-1) * run.varcov +
- temp3[,ind1$row.index]*temp3[,ind1$col.index]) / ii
+ temp3[,ind1$row.index]*temp3[,ind1$col.index]) / ii
}
wz = if (intercept.only)
matrix(colMeans(run.varcov),
@@ -4381,35 +4573,40 @@ adjust01.logitlaplace1 = function(ymat, y, w, rep01) {
rep01 = 0.5,
imethod = 1, zero = NULL) {
- if (!is.Numeric(rep01, positive = TRUE, allowable.length = 1) || rep01 > 0.5)
- stop("bad input for argument 'rep01'")
+ if (!is.Numeric(rep01, positive = TRUE, allowable.length = 1) ||
+ rep01 > 0.5)
+ stop("bad input for argument 'rep01'")
if (!is.Numeric(kappa, positive = TRUE))
- stop("bad input for argument 'kappa'")
+ 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")
+ stop("arguments 'kappa' and 'tau' do not match")
if (mode(llocation) != "character" && mode(llocation) != "name")
- llocation = as.character(substitute(llocation))
- if (!is.Numeric(imethod, allowable.length = 1, integer.valued = TRUE, positive = TRUE) ||
+ llocation = as.character(substitute(llocation))
+ if (!is.Numeric(imethod, allowable.length = 1,
+ integer.valued = TRUE, positive = TRUE) ||
imethod > 4)
stop("argument 'imethod' must be 1, 2 or ... 4")
if (!is.list(elocation)) elocation = list()
- if (!is.Numeric(shrinkage.init, allowable.length = 1) || shrinkage.init < 0 ||
+ if (!is.Numeric(shrinkage.init, allowable.length = 1) ||
+ shrinkage.init < 0 ||
shrinkage.init > 1)
stop("bad input for argument 'shrinkage.init'")
if (length(zero) &&
!(is.Numeric(zero, integer.valued = TRUE, positive = TRUE) ||
is.character(zero )))
- stop("bad input for argument 'zero'")
+ stop("bad input for argument 'zero'")
if (!is.Numeric(Scale.arg, positive = TRUE))
- stop("bad input for argument 'Scale.arg'")
- if (!is.logical(parallelLocation) || length(parallelLocation) != 1)
- stop("bad input for argument 'parallelLocation'")
+ stop("bad input for argument 'Scale.arg'")
+ if (!is.logical(parallelLocation) ||
+ length(parallelLocation) != 1)
+ stop("bad input for argument 'parallelLocation'")
fittedMean = FALSE
- if (!is.logical(fittedMean) || length(fittedMean) != 1)
- stop("bad input for argument 'fittedMean'")
+ if (!is.logical(fittedMean) ||
+ length(fittedMean) != 1)
+ stop("bad input for argument 'fittedMean'")
mystring0 = namesof("location", llocation, earg = elocation)
@@ -4513,7 +4710,8 @@ adjust01.logitlaplace1 = function(ymat, y, w, rep01) {
location.y = eta2theta(eta, .llocat, earg = .elocat)
location.y = as.matrix(location.y)
for(ii in 1:length(misc$kappa))
- extra$percentile[ii] = 100 * weighted.mean(y <= location.y[,ii], w)
+ extra$percentile[ii] = 100 *
+ weighted.mean(y <= location.y[,ii], w)
}), list( .elocat = elocation, .llocat = llocation,
.Scale.arg = Scale.arg, .fittedMean = fittedMean,
diff --git a/R/family.rcam.R b/R/family.rcam.R
index ac7ea60..e2cc675 100644
--- a/R/family.rcam.R
+++ b/R/family.rcam.R
@@ -43,7 +43,8 @@
noroweffects = FALSE
nocoleffects = FALSE
- if (!is.Numeric(which.lp, allowable.length = 1, integer.valued = TRUE, positive = TRUE))
+ if (!is.Numeric(which.lp, allowable.length = 1,
+ integer.valued = TRUE, positive = TRUE))
stop("bad input for argument 'which.lp'")
if (!is.character(rprefix))
@@ -246,7 +247,8 @@
family = family,
constraints = Hlist,
offset = offset.matrix,
- weights = if (length(weights)) weights else rep(1, length = nrow(y)),
+ weights = if (length(weights))
+ weights else rep(1, length = nrow(y)),
...,
control = mycontrol, data = .rcam.df)
} else {
@@ -255,7 +257,8 @@
family = family,
constraints = Hlist,
offset = offset.matrix,
- weights = if (length(weights)) weights else rep(1, length = nrow(y)),
+ weights = if (length(weights))
+ weights else rep(1, length = nrow(y)),
...,
control = mycontrol, data = .rcam.df)
}
@@ -362,7 +365,7 @@ setMethod("summary", "rcam",
yswap <- rbind(mat[r.index:RRR, ],
if (r.index > 1) mat[1:(r.index - 1),] else NULL)
yswap <- cbind(yswap[, c.index:CCC],
- if (c.index > 1) yswap[, 1:(c.index - 1)] else NULL)
+ if (c.index > 1) yswap[, 1:(c.index - 1)] else NULL)
new.rnames <- rnames[c(r.index:RRR,
if (r.index > 1) 1:(r.index - 1) else NULL)]
@@ -537,22 +540,24 @@ moffset <- function (mat, roffset = 0, coffset = 0, postfix = "") {
vecmat = c(unlist(mat))
ind1 <- if (is.character(roffset))
- which(rownames(mat) == roffset) else
- if (is.numeric(roffset)) roffset + 1 else
- stop("argument 'roffset' not matched (character). ",
- "It must be numeric, ",
- "else character and match the ",
- "row names of the response")
+ which(rownames(mat) == roffset) else
+ if (is.numeric(roffset)) roffset + 1 else
+ stop("argument 'roffset' not matched (character). ",
+ "It must be numeric, ",
+ "else character and match the ",
+ "row names of the response")
ind2 <- if (is.character(coffset))
- which(colnames(mat) == coffset) else
- if (is.numeric(coffset)) coffset + 1 else
- stop("argument 'coffset' not matched (character). ",
- "It must be numeric, ",
- "else character and match the ",
- "column names of the response")
-
- if (!is.Numeric(ind1, positive = TRUE, integer.valued = TRUE, allowable.length = 1) ||
- !is.Numeric(ind2, positive = TRUE, integer.valued = TRUE, allowable.length = 1))
+ which(colnames(mat) == coffset) else
+ if (is.numeric(coffset)) coffset + 1 else
+ stop("argument 'coffset' not matched (character). ",
+ "It must be numeric, ",
+ "else character and match the ",
+ "column names of the response")
+
+ if (!is.Numeric(ind1, positive = TRUE,
+ integer.valued = TRUE, allowable.length = 1) ||
+ !is.Numeric(ind2, positive = TRUE,
+ integer.valued = TRUE, allowable.length = 1))
stop("bad input for arguments 'roffset' and/or 'coffset'")
if (ind1 > nrow(mat))
stop("too large a value for argument 'roffset'")
@@ -665,7 +670,8 @@ confint_nb1 <- function(nb1, level = 0.95) {
stop("argument 'nb1' does not appear to have parallel = TRUE")
if (!all(unlist(constraints(nb1)[1]) == c(diag(nb1 at misc$M))))
- stop("argument 'nb1' does not have parallel = FALSE for the intercept")
+ stop("argument 'nb1' does not have parallel = FALSE ",
+ "for the intercept")
if (nb1 at misc$M != 2)
stop("argument 'nb1' does not have M = 2")
@@ -674,7 +680,8 @@ confint_nb1 <- function(nb1, level = 0.95) {
stop("argument 'nb1' does not have log links for both parameters")
cnb1 <- coefficients(as(nb1, "vglm"), matrix = TRUE)
- mydiff <- (cnb1["(Intercept)", "log(size)"] - cnb1["(Intercept)", "log(mu)"])
+ mydiff <- (cnb1["(Intercept)", "log(size)"] -
+ cnb1["(Intercept)", "log(mu)"])
delta0.hat <- exp(mydiff)
(phi0.hat <- 1 + 1 / delta0.hat) # MLE of phi0
@@ -857,13 +864,15 @@ Qvar <- function(object, factor.name = NULL,
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]
+ myvcov[jlocal, ilocal] = vcov0[ilocal, ilocal] +
+ vcov0[jlocal, jlocal] -
+ vcov0[ilocal, jlocal] * 2
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 = ""),
+ if (is.matrix(object)) NULL else object.xlevels[1],
+ sep = ""),
rownames(vcov0)[-1])
colnames(allvcov) = rownames(allvcov)
@@ -919,7 +928,8 @@ Qvar <- function(object, factorname = NULL, coef.indices = NULL,
if (!is.matrix(object)) {
model <- object
if (is.null(factorname) && is.null(coef.indices)) {
- stop("arguments \"factorname\" and \"coef.indices\" are both NULL")
+ stop("arguments \"factorname\" and \"coef.indices\" are ",
+ "both NULL")
}
if (is.null(coef.indices)) {
@@ -995,7 +1005,8 @@ Qvar <- function(object, factorname = NULL, coef.indices = NULL,
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")
+ stop("This function works only for factors with 3 ",
+ "or more levels")
}
@@ -1106,7 +1117,7 @@ summary.qvar <- function(object, ...) {
structure(list(estimate = estimates,
- SE = sqrt(regularVar), # zz dispersion parameter??
+ SE = sqrt(regularVar),
minErrSimple = minErrSimple,
maxErrSimple = maxErrSimple,
quasiSE = QuasiSE,
@@ -1192,7 +1203,8 @@ plotqvar <- function(object,
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 = "")
+ names( estimates) = paste("Level", 1:length(estimates),
+ sep = "")
@@ -1201,9 +1213,11 @@ plotqvar <- function(object,
QuasiSE <- sqrt(QuasiVar)
if (!is.numeric(estimates))
- stop("Cannot plot, because there are no 'proper' parameter 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")
+ stop("Cannot plot, because there are no ",
+ "quasi standard errors")
@@ -1233,7 +1247,8 @@ plotqvar <- function(object,
if (is.null(ylim))
- ylim <- range(c(tails, tops, lsd.tails, lsd.tops), na.rm = TRUE)
+ ylim <- range(c(tails, tops, lsd.tails, lsd.tops),
+ na.rm = TRUE)
if (is.null(xlab))
xlab <- "Factor level"
diff --git a/R/family.rrr.R b/R/family.rrr.R
index 263cb13..25141b9 100644
--- a/R/family.rrr.R
+++ b/R/family.rrr.R
@@ -317,7 +317,8 @@ valt.2iter <- function(x, z, U, Blist, A, control) {
-valt.1iter = function(x, z, U, Blist, C, control, lp.names = NULL, nice31 = FALSE,
+valt.1iter = function(x, z, U, Blist, C, control,
+ lp.names = NULL, nice31 = FALSE,
MSratio = 1) {
Rank = control$Rank
@@ -346,18 +347,26 @@ valt.1iter = function(x, z, U, Blist, C, control, lp.names = NULL, nice31 = FALS
for(ii in 1:NOS) {
i5 = i5 + 1:MSratio
- tmp100 = vlm.wfit(xmat=new.lv.model.matrix, zedd[,i5,drop = FALSE],
- Blist=clist2, U = U[i5,,drop = FALSE],
- matrix.out = TRUE, is.vlmX = FALSE, rss = TRUE,
- qr = FALSE, Eta.range = control$Eta.range,
- xij = control$xij, lp.names=lp.names[i5])
+ tmp100 = vlm.wfit(xmat=new.lv.model.matrix,
+ zedd[,i5,drop = FALSE],
+ Blist=clist2,
+ U = U[i5,,drop = FALSE],
+ matrix.out = TRUE,
+ is.vlmX = FALSE, rss = TRUE,
+ qr = FALSE,
+ Eta.range = control$Eta.range,
+ xij = control$xij,
+ lp.names=lp.names[i5])
fit$rss = fit$rss + tmp100$rss
fit$mat.coef = cbind(fit$mat.coef, tmp100$mat.coef)
- fit$fitted.values = cbind(fit$fitted.values, tmp100$fitted.values)
+ fit$fitted.values = cbind(fit$fitted.values,
+ tmp100$fitted.values)
}
} else {
- fit = vlm.wfit(xmat=new.lv.model.matrix, zedd, Blist=clist2, U = U,
- matrix.out = TRUE, is.vlmX = FALSE, rss = TRUE, qr = FALSE,
+ fit = vlm.wfit(xmat=new.lv.model.matrix,
+ zedd, Blist=clist2, U = U,
+ matrix.out = TRUE,
+ is.vlmX = FALSE, rss = TRUE, qr = FALSE,
Eta.range = control$Eta.range,
xij = control$xij, lp.names=lp.names)
}
@@ -366,14 +375,17 @@ valt.1iter = function(x, z, U, Blist, C, control, lp.names = NULL, nice31 = FALS
if (Corner)
A[Index.corner,] = diag(Rank)
- B1 = if (p1) fit$mat.coef[-(1:(tmp833$Aoffset+Qoffset)),,drop = FALSE] else NULL
+ B1 = if (p1)
+ fit$mat.coef[-(1:(tmp833$Aoffset+Qoffset)),,drop = FALSE] else
+ NULL
fv = as.matrix(fit$fitted.values)
if (Corner)
fv[,Index.corner] = fv[,Index.corner] + lv.mat
Dmat = if (Quadratic) {
if (ITolerances) {
tmp800 = matrix(0, M, Rank*(Rank+1)/2)
- tmp800[if (MSratio == 2) c(TRUE,FALSE) else TRUE,1:Rank] = -0.5
+ tmp800[if (MSratio == 2) c(TRUE, FALSE) else
+ TRUE, 1:Rank] = -0.5
tmp800
} else
t(fit$mat.coef[(tmp833$Aoffset+1):
@@ -381,7 +393,8 @@ valt.1iter = function(x, z, U, Blist, C, control, lp.names = NULL, nice31 = FALS
} else
NULL
- list(Amat=A, B1=B1, Cmat=C, Dmat=Dmat, fitted = if (M == 1) c(fv) else fv,
+ list(Amat=A, B1=B1, Cmat=C, Dmat=Dmat,
+ fitted = if (M == 1) c(fv) else fv,
new.coeffs = fit$coef, constraints=clist2, rss=fit$rss,
offset = if (length(tmp833$offset)) tmp833$offset else NULL)
}
@@ -445,8 +458,8 @@ rrr.alternating.expression <- expression({
ans2 = rrr.normalize(rrcontrol = rrcontrol, A=alt$A, C=alt$C, x=x)
- Amat = ans2$A # Fed into Blist below (in rrr.end.expression)
- tmp.fitted = alt$fitted # Also fed; was alt2$fitted
+ Amat = ans2$A # Fed into Blist below (in rrr.end.expression)
+ tmp.fitted = alt$fitted # Also fed; was alt2$fitted
rrcontrol$Cinit <- ans2$C # For next valt() call
@@ -553,7 +566,9 @@ rrr.end.expression = expression({
C = Cmat, control=control)
lv.mat = tmp300$lv.mat # Needed at the top of new.s.call
- lm2vlm.model.matrix(tmp300$new.lv.model.matrix,B.list,xij = control$xij)
+ lm2vlm.model.matrix(tmp300$new.lv.model.matrix,
+ B.list,
+ xij = control$xij)
} else {
lm2vlm.model.matrix(x, Blist, xij = control$xij)
}
@@ -630,26 +645,32 @@ rrr.derivative.expression <- expression({
if (iter == 2 || quasi.newton$convergence) {
NOS = ifelse(modelno == 3 || modelno == 5, M/2, M)
- canfitok = (exists("CQO.FastAlgorithm", envir=VGAM:::VGAMenv) &&
- get("CQO.FastAlgorithm", envir = VGAM:::VGAMenv))
+ canfitok =
+ (exists("CQO.FastAlgorithm", envir=VGAM:::VGAMenv) &&
+ get("CQO.FastAlgorithm", envir = VGAM:::VGAMenv))
if (!canfitok)
- stop("cannot fit this model using fast algorithm")
+ stop("cannot fit this model using fast algorithm")
p2star = if (nice31)
- ifelse(control$IToleran, Rank, Rank+0.5*Rank*(Rank+1)) else
- (NOS*Rank + Rank*(Rank+1)/2 * ifelse(control$EqualTol,1,NOS))
- p1star = if (nice31) p1 * ifelse(modelno == 3 || modelno == 5,2,1) else
- (ncol(X_vlm_save) - p2star)
- X_vlm_1save = if (p1star > 0) X_vlm_save[,-(1:p2star)] else NULL
+ ifelse(control$IToleran, Rank, Rank+0.5*Rank*(Rank+1)) else
+ (NOS*Rank + Rank*(Rank+1)/2 * ifelse(control$EqualTol,1,NOS))
+ p1star = if (nice31) p1 *
+ ifelse(modelno == 3 || modelno == 5, 2, 1) else
+ (ncol(X_vlm_save) - p2star)
+ X_vlm_1save = if (p1star > 0)
+ X_vlm_save[,-(1:p2star)] else NULL
quasi.newton = optim(par=Cmat, fn=callcqof,
- gr = if (control$GradientFunction) calldcqo else NULL,
- method=which.optimizer,
- control=list(fnscale = 1,trace=as.integer(control$trace),
- parscale=rep(control$Parscale, length.out = length(Cmat)),
- maxit = 250),
- etamat=eta, xmat=x, ymat=y, wvec=w,
- X_vlm_1save = if (nice31) NULL else X_vlm_1save,
- modelno=modelno, Control=control,
- n = n, M = M, p1star=p1star, p2star=p2star, nice31=nice31)
+ gr = if (control$GradientFunction) calldcqo else NULL,
+ method=which.optimizer,
+ control=list(fnscale = 1,
+ trace = as.integer(control$trace),
+ parscale = rep(control$Parscale,
+ length.out = length(Cmat)),
+ maxit = 250),
+ etamat=eta, xmat=x, ymat=y, wvec=w,
+ X_vlm_1save = if (nice31) NULL else X_vlm_1save,
+ modelno=modelno, Control=control,
+ n = n, M = M, p1star=p1star,
+ p2star=p2star, nice31=nice31)
if (zthere <- exists(".VGAM.z", envir = VGAM:::VGAMenv)) {
@@ -696,8 +717,10 @@ rrr.derivative.expression <- expression({
}
- alt = valt.1iter(x=x, z=z, U = U, Blist = Blist, C = Cmat, nice31=nice31,
- control = rrcontrol, lp.names=predictors.names)
+ alt = valt.1iter(x=x, z=z, U = U, Blist = Blist,
+ C = Cmat, nice31=nice31,
+ control = rrcontrol,
+ lp.names=predictors.names)
if (length(alt$offset))
@@ -747,7 +770,8 @@ rrr.derivC.rss = function(theta, U, z, M, xmat, Blist, rrcontrol,
if (alreadyThere) {
VGAM.dot.counter = get(".VGAM.dot.counter", envir = VGAM:::VGAMenv)
VGAM.dot.counter = VGAM.dot.counter + 1
- assign(".VGAM.dot.counter", VGAM.dot.counter, envir = VGAM:::VGAMenv)
+ assign(".VGAM.dot.counter", VGAM.dot.counter,
+ envir = VGAM:::VGAMenv)
if (VGAM.dot.counter > max(50, options()$width - 5)) {
if (rrcontrol$trace) {
cat("\n")
@@ -830,13 +854,17 @@ Coef.qrrvglm <- function(object, varlvI = FALSE, reference = NULL, ...) {
if (length(varlvI) != 1 || !is.logical(varlvI))
- stop("'varlvI' must be TRUE or FALSE")
- if (length(reference) > 1) stop("'reference' must be of length 0 or 1")
- if (length(reference) && is.Numeric(reference))
- if (!is.Numeric(reference, allowable.length = 1, integer.valued = TRUE))
- stop("bad input for argument 'reference'")
+ stop("'varlvI' must be TRUE or FALSE")
+ if (length(reference) > 1)
+ stop("'reference' must be of length 0 or 1")
+ if (length(reference) &&
+ is.Numeric(reference))
+ if (!is.Numeric(reference, allowable.length = 1,
+ integer.valued = TRUE))
+ stop("bad input for argument 'reference'")
if (!is.logical(ConstrainedQO <- object at control$ConstrainedQO))
- stop("cannot determine whether the model is constrained or not")
+ stop("cannot determine whether the model is constrained or not")
+
ocontrol = object at control
coef.object = object at coefficients
Rank = ocontrol$Rank
@@ -1278,8 +1306,8 @@ predictqrrvglm <- function(object,
if (!length(newdata) && length(na.act)) {
if (se.fit) {
- pred$fitted.values = napredict(na.act[[1]], pred$fitted.values)
- pred$se.fit = napredict(na.act[[1]], pred$se.fit)
+ pred$fitted.values = napredict(na.act[[1]], pred$fitted.values)
+ pred$se.fit = napredict(na.act[[1]], pred$se.fit)
} else {
pred = napredict(na.act[[1]], pred)
}
@@ -1287,25 +1315,27 @@ predictqrrvglm <- function(object,
pred
}
+
setMethod("predict", "qrrvglm", function(object, ...)
- predictqrrvglm(object, ...))
+ predictqrrvglm(object, ...))
+
coefqrrvglm = function(object, matrix.out = FALSE,
- label = TRUE) {
- if (matrix.out)
- stop("currently cannot handle matrix.out = TRUE")
- coefvlm(object, matrix.out = matrix.out, label = label)
+ label = TRUE) {
+ if (matrix.out)
+ stop("currently cannot handle matrix.out = TRUE")
+ coefvlm(object, matrix.out = matrix.out, label = label)
}
residualsqrrvglm <- function(object,
- type = c("deviance", "pearson", "working", "response", "ldot"),
- matrix.arg= TRUE) {
- stop("this function has not been written yet")
-
+ type = c("deviance", "pearson", "working", "response", "ldot"),
+ matrix.arg= TRUE) {
+ stop("this function has not been written yet")
}
+
setMethod("residuals", "qrrvglm", function(object, ...)
residualsqrrvglm(object, ...))
@@ -1320,10 +1350,11 @@ show.rrvglm <- function(x, ...)
}
vecOfBetas <- x at coefficients
if (any(nas <- is.na(vecOfBetas))) {
- if (is.null(names(vecOfBetas)))
- names(vecOfBetas) = paste("b", 1:length(vecOfBetas), sep = "")
- cat("\nCoefficients: (", sum(nas),
- " not defined because of singularities)\n", sep = "")
+ if (is.null(names(vecOfBetas)))
+ names(vecOfBetas) = paste("b",
+ 1:length(vecOfBetas), sep = "")
+ cat("\nCoefficients: (", sum(nas),
+ " not defined because of singularities)\n", sep = "")
} else
cat("\nCoefficients:\n")
print.default(vecOfBetas, ...) # used to be print()
@@ -1335,10 +1366,10 @@ show.rrvglm <- function(x, ...)
}
if (FALSE) {
- nobs <- if (length(x at df.total)) x at df.total else length(x at residuals)
- rdf <- x at df.residual
- if (!length(rdf))
- rdf <- nobs - Rank
+ nobs <- if (length(x at df.total)) x at df.total else length(x at residuals)
+ rdf <- x at df.residual
+ if (!length(rdf))
+ rdf <- nobs - Rank
}
cat("\n")
@@ -1351,7 +1382,8 @@ show.rrvglm <- function(x, ...)
ncrit <- names(x at criterion)
for(iii in ncrit)
if (iii != "loglikelihood" && iii != "deviance")
- cat(paste(iii, ":", sep = ""), format(x at criterion[[iii]]), "\n")
+ cat(paste(iii, ":", sep = ""),
+ format(x at criterion[[iii]]), "\n")
}
invisible(x)
@@ -1381,15 +1413,17 @@ summary.rrvglm <- function(object, correlation = FALSE,
dispersion = NULL, digits = NULL,
numerical= TRUE,
h.step = 0.0001,
- kill.all = FALSE, omit13 = FALSE, fixA = FALSE, ...)
+ kill.all = FALSE, omit13 = FALSE,
+ fixA = FALSE, ...)
{
- if (!is.Numeric(h.step, allowable.length = 1) || abs(h.step)>1)
- stop("bad input for 'h.step'")
+ if (!is.Numeric(h.step, allowable.length = 1) ||
+ abs(h.step) > 1)
+ stop("bad input for 'h.step'")
if (!object at control$Corner)
stop("this function works with corner constraints only")
@@ -1416,7 +1450,7 @@ summary.rrvglm <- function(object, correlation = FALSE,
if (is.numeric(stuff at dispersion))
- slot(answer, "dispersion") = stuff at dispersion
+ slot(answer, "dispersion") = stuff at dispersion
@@ -1430,11 +1464,13 @@ summary.rrvglm <- function(object, correlation = FALSE,
answer at cov.unscaled <- tmp5$cov.unscaled
- od <- if (is.numeric(object at misc$disper)) object at misc$disper else
+ od <- if (is.numeric(object at misc$disper))
+ object at misc$disper else
object at misc$default.disper
if (is.numeric(dispersion)) {
if (is.numeric(od) && dispersion!=od)
- warning("dispersion != object at misc$dispersion; using the former")
+ warning("dispersion != object at misc$dispersion; ",
+ "using the former")
} else {
dispersion <- if (is.numeric(od)) od else 1
}
@@ -1517,14 +1553,19 @@ get.rrvglm.se1 = function(fit, omit13 = FALSE, kill.all = FALSE,
if (numerical) {
delct.da <- num.deriv.rrr(fit, M = M, r = Rank,
x1mat=x1mat, x2mat=x2mat, p2 = p2,
- Index.corner, Aimat=Amat, B1mat=B1mat, Cimat=Cmat,
- h.step = h.step, colx2.index=colx2.index,
+ Index.corner, Aimat=Amat,
+ B1mat=B1mat, Cimat=Cmat,
+ h.step = h.step,
+ colx2.index=colx2.index,
xij = fit at control$xij,
szero = szero)
} else {
- delct.da <- dctda.fast.only(theta=theta, wz = wz, U = U, zmat,
- M = M, r = Rank, x1mat=x1mat, x2mat=x2mat, p2 = p2,
- Index.corner, Aimat=Amat, B1mat=B1mat, Cimat=Cmat,
+ delct.da <- dctda.fast.only(theta=theta, wz = wz,
+ U = U, zmat,
+ M = M, r = Rank, x1mat=x1mat,
+ x2mat=x2mat, p2 = p2,
+ Index.corner, Aimat=Amat,
+ B1mat=B1mat, Cimat=Cmat,
xij = fit at control$xij,
szero = szero)
}
@@ -1598,7 +1639,8 @@ get.rrvglm.se1 = function(fit, omit13 = FALSE, kill.all = FALSE,
mytext1 = "exists(x=fit at misc$dataname, envir = VGAM:::VGAMenv)"
myexp1 = parse(text=mytext1)
is.there = eval(myexp1)
- bbdata= if (is.there) get(fit at misc$dataname, envir=VGAM:::VGAMenv) else
+ bbdata= if (is.there)
+ get(fit at misc$dataname, envir=VGAM:::VGAMenv) else
get(fit at misc$dataname)
dspec = TRUE
}
@@ -1837,7 +1879,8 @@ dcda.fast = function(theta, wz, U, z, M, r, xmat, pp, Index.corner,
if (nrow(Cimat)!=pp || ncol(Cimat)!=r)
stop("Cimat wrong shape")
- fred <- kronecker(matrix(1,1,r), if (intercept) xmat[,-1,drop = FALSE] else xmat)
+ fred <- kronecker(matrix(1,1,r),
+ if (intercept) xmat[,-1,drop = FALSE] else xmat)
fred <- kronecker(fred, matrix(1,M,1))
barney <- kronecker(Aimat, matrix(1,1,pp))
barney <- kronecker(matrix(1, nn, 1), barney)
@@ -1850,7 +1893,8 @@ dcda.fast = function(theta, wz, U, z, M, r, xmat, pp, Index.corner,
dc.da <- array(NA, c(pp,r,M,r)) # different from other functions
cbindex <- (1:M)[-Index.corner]
- resid2 <- mux22(t(wz), z - matrix(int.vec, nn, M, byrow = TRUE), M = M,
+ resid2 <- mux22(t(wz),
+ z - matrix(int.vec, nn, M, byrow = TRUE), M = M,
upper = FALSE, as.matrix = TRUE) # mat= TRUE,
for(s in 1:r)
@@ -1976,7 +2020,8 @@ rrr.deriv.gradient.fast = function(theta, wz, U, z, M, r, xmat,
if (nrow(Cimat)!=pp || ncol(Cimat)!=r)
stop("Cimat wrong shape")
- fred = kronecker(matrix(1,1,r), if (intercept) xmat[,-1,drop = FALSE] else xmat)
+ fred = kronecker(matrix(1,1,r),
+ if (intercept) xmat[,-1,drop = FALSE] else xmat)
fred = kronecker(fred, matrix(1,M,1))
barney = kronecker(Aimat, matrix(1,1,pp))
barney = kronecker(matrix(1, nn, 1), barney)
@@ -1989,8 +2034,9 @@ rrr.deriv.gradient.fast = function(theta, wz, U, z, M, r, xmat,
dc.da = array(NA,c(pp,r,r,M))
cbindex = (1:M)[-Index.corner]
- resid2 = mux22(t(wz), z - matrix(int.vec, nn, M, byrow = TRUE), M = M,
- upper = FALSE, as.matrix = TRUE)
+ resid2 = mux22(t(wz), z - matrix(int.vec, nn, M, byrow = TRUE),
+ M = M,
+ upper = FALSE, as.matrix = TRUE)
for(s in 1:r)
for(tt in cbindex) {
@@ -2033,7 +2079,7 @@ rrr.deriv.gradient.fast = function(theta, wz, U, z, M, r, xmat,
AtWi = array(t(AtWi), c(r,M,nn))
for(ss in 1:r) {
- temp90 = (m2adefault(t(colSums(etastar[,ss]*wz)), M = M))[,,1] # M x M
+ temp90 = (m2adefault(t(colSums(etastar[,ss]*wz)), M = M))[,,1]
temp92 = array(detastar.da[,,ss,],c(M,r,nn))
temp93 = mux7(temp92,AtWi)
temp91 = rowSums(temp93, dims = 2) # M x M
@@ -2041,7 +2087,8 @@ rrr.deriv.gradient.fast = function(theta, wz, U, z, M, r, xmat,
}
ans = matrix(0,M,r)
- fred = mux22(t(wz), z - eta, M = M, upper = FALSE, as.matrix = TRUE)
+ fred = mux22(t(wz), z - eta, M = M,
+ upper = FALSE, as.matrix = TRUE)
fred.array = array(t(fred %*% Aimat),c(r,1, nn))
for(s in 1:r) {
a1 = colSums(fred %*% t(deta0.da[,,s]))
@@ -2062,7 +2109,8 @@ rrr.deriv.gradient.fast = function(theta, wz, U, z, M, r, xmat,
-vellipse = function(R, ratio = 1, orientation = 0, center = c(0,0), N=300) {
+vellipse = function(R, ratio = 1, orientation = 0,
+ center = c(0,0), N=300) {
if (length(center) != 2) stop("center must be of length 2")
theta = 2*pi*(0:N)/N
x1 = R*cos(theta)
@@ -2074,14 +2122,15 @@ vellipse = function(R, ratio = 1, orientation = 0, center = c(0,0), N=300) {
biplot.qrrvglm = function(x, ...) {
- stop("biplot.qrrvglm has been replaced by the function lvplot.qrrvglm")
+ stop("biplot.qrrvglm has been replaced by the function lvplot.qrrvglm")
}
lvplot.qrrvglm = function(object, varlvI = FALSE, reference = NULL,
add= FALSE, plot.it= TRUE, rug= TRUE, y = FALSE,
type = c("fitted.values", "predictors"),
- xlab=paste("Latent Variable", if (Rank == 1) "" else " 1", sep = ""),
+ xlab=paste("Latent Variable",
+ if (Rank == 1) "" else " 1", sep = ""),
ylab= if (Rank == 1) switch(type, predictors = "Predictors",
fitted.values = "Fitted values") else "Latent Variable 2",
pcex=par()$cex, pcol=par()$col, pch=par()$pch,
@@ -2103,13 +2152,15 @@ lvplot.qrrvglm = function(object, varlvI = FALSE, reference = NULL,
type <- as.character(substitute(type))
type <- match.arg(type, c("fitted.values", "predictors"))[1]
- if (is.numeric(OriginC)) OriginC = rep(OriginC, length.out = 2) else {
+ if (is.numeric(OriginC))
+ OriginC = rep(OriginC, length.out = 2) else {
if (mode(OriginC) != "character" && mode(OriginC) != "name")
OriginC <- as.character(substitute(OriginC))
OriginC <- match.arg(OriginC, c("origin","mean"))[1]
}
- if (length(ellipse) > 1) stop("ellipse must be of length 1 or 0")
+ if (length(ellipse) > 1)
+ stop("ellipse must be of length 1 or 0")
if (is.logical(ellipse)) {ellipse = if (ellipse) 0.95 else NULL}
Rank <- object at control$Rank
@@ -2122,8 +2173,9 @@ lvplot.qrrvglm = function(object, varlvI = FALSE, reference = NULL,
colx2.index = object at control$colx2.index
cx1i = object at control$colx1.index # May be NULL
if (check.ok)
- if (!(length(cx1i) == 1 && names(cx1i) == "(Intercept)"))
- stop("latent variable plots allowable only for Norrr = ~ 1 models")
+ if (!(length(cx1i) == 1 && names(cx1i) == "(Intercept)"))
+ stop("latent variable plots allowable only for ",
+ "Norrr = ~ 1 models")
Coef.list = Coef(object, varlvI = varlvI, reference = reference)
if ( C) Cmat = Coef.list at C
@@ -2135,7 +2187,8 @@ lvplot.qrrvglm = function(object, varlvI = FALSE, reference = NULL,
if (!add) {
if (Rank == 1) {
matplot(nustar,
- if ( y && type == "fitted.values") object at y else r.curves,
+ if ( y && type == "fitted.values")
+ object at y else r.curves,
type = "n", xlab=xlab, ylab=ylab, ...)
} else { # Rank == 2
matplot(c(Coef.list at Optimum[1,], nustar[,1]),
@@ -2178,7 +2231,8 @@ lvplot.qrrvglm = function(object, varlvI = FALSE, reference = NULL,
if ( y && type == "fitted.values") {
ypts = object at y
if (ncol(as.matrix(ypts)) == ncol(r.curves))
- points(xx, ypts[o,i], col=pcol[i], cex=pcex[i], pch=pch[i])
+ points(xx, ypts[o,i], col=pcol[i],
+ cex=pcex[i], pch=pch[i])
}
}
if (rug) rug(xx)
@@ -2201,13 +2255,13 @@ lvplot.qrrvglm = function(object, varlvI = FALSE, reference = NULL,
if (length(ellipse)) {
ellipse.temp = if (ellipse > 0) ellipse else 0.95
if (ellipse < 0 && (!object at control$EqualTolerances || varlvI))
- stop("an equal-tolerances assumption and 'varlvI = FALSE' ",
- "is needed for 'ellipse' < 0")
+ stop("an equal-tolerances assumption and 'varlvI = FALSE' ",
+ "is needed for 'ellipse' < 0")
if ( check.ok ) {
colx1.index = object at control$colx1.index
if (!(length(colx1.index) == 1 &&
names(colx1.index) == "(Intercept)"))
- stop("can only plot ellipses for intercept models only")
+ stop("can only plot ellipses for intercept models only")
}
for(i in 1:ncol(r.curves)) {
cutpoint = object at family@linkfun( if (Absolute) ellipse.temp
@@ -2277,8 +2331,8 @@ lvplot.rrvglm = function(object,
gapC=sqrt(sum(par()$cxy^2)), scaleA = 1,
xlab = "Latent Variable 1",
ylab = "Latent Variable 2",
- Alabels= if (length(object at misc$predictors.names))
- object at misc$predictors.names else paste("LP", 1:M, sep = ""),
+ Alabels= if (length(object at misc$predictors.names))
+ object at misc$predictors.names else paste("LP", 1:M, sep = ""),
Aadj=par()$adj,
Acex=par()$cex,
Acol=par()$col,
@@ -2334,14 +2388,18 @@ lvplot.rrvglm = function(object,
Aadj = rep(Aadj, length.out = length(index.nosz))
Acex = rep(Acex, length.out = length(index.nosz))
Acol = rep(Acol, length.out = length(index.nosz))
- if (length(Alabels) != M) stop("'Alabels' must be of length ", M)
+ if (length(Alabels) != M)
+ stop("'Alabels' must be of length ", M)
if (length(Apch)) {
Apch = rep(Apch, length.out = length(index.nosz))
for(i in index.nosz)
- points(Amat[i,1],Amat[i,2],pch=Apch[i],cex=Acex[i],col=Acol[i])
+ points(Amat[i,1],
+ Amat[i,2],
+ pch=Apch[i],cex=Acex[i],col=Acol[i])
} else {
for(i in index.nosz)
- text(Amat[i,1], Amat[i,2], Alabels[i], cex=Acex[i],
+ text(Amat[i,1], Amat[i,2],
+ Alabels[i], cex=Acex[i],
col=Acol[i], adj=Aadj[i])
}
}
@@ -2360,7 +2418,8 @@ lvplot.rrvglm = function(object,
arrows(0, 0, Cmat[ii,1], Cmat[ii,2],
lwd=Clwd[ii], lty=Clty[ii], col=Ccol[ii])
const = 1 + gapC[ii] / sqrt(Cmat[ii,1]^2 + Cmat[ii,2]^2)
- text(const*Cmat[ii,1], const*Cmat[ii,2], Clabels[ii], cex=Ccex[ii],
+ text(const*Cmat[ii,1], const*Cmat[ii,2],
+ Clabels[ii], cex=Ccex[ii],
adj=Cadj[ii], col=Ccol[ii])
}
}
@@ -2394,7 +2453,8 @@ lvplot.rrvglm = function(object,
if (chull.arg) {
hull = chull(temp[,1],temp[,2])
hull = c(hull, hull[1])
- lines(temp[hull,1], temp[hull,2], type = "b", lty=clty[ii],
+ lines(temp[hull,1], temp[hull,2],
+ type = "b", lty=clty[ii],
col=ccol[ii], lwd=clwd[ii], pch = " ")
}
}
@@ -2593,7 +2653,8 @@ setMethod("show", "Coef.rrvglm", function(object)
y = as(y, "matrix")
}
if (length(dim(y)) != 2 || nrow(y) < 3 || ncol(y) < 3)
- stop("y must be a matrix with >= 3 rows & columns, or a rrvglm() object")
+ stop("y must be a matrix with >= 3 rows & columns, ",
+ "or a rrvglm() object")
ei = function(i, n) diag(n)[,i,drop = FALSE]
.grc.df = data.frame(Row.2 = ei(2, nrow(y)))
@@ -2617,7 +2678,8 @@ setMethod("show", "Coef.rrvglm", function(object)
.grc.df[[paste("Row.", ii, sep = "")]] = modmat.row[,ii]
}
for(ii in 2:ncol(y)) {
- cms[[paste("Col.", ii, sep = "")]] = modmat.col[,ii,drop = FALSE]
+ cms[[paste("Col.", ii, sep = "")]] =
+ modmat.col[,ii,drop = FALSE]
.grc.df[[paste("Col.", ii, sep = "")]] = rep(1, nrow(y))
}
for(ii in 2:nrow(y)) {
@@ -2625,7 +2687,8 @@ setMethod("show", "Coef.rrvglm", function(object)
.grc.df[[yn1[ii]]] = ei(ii, nrow(y))
}
- dimnames(.grc.df) = list(if (length(dimnames(y)[[1]])) dimnames(y)[[1]] else
+ dimnames(.grc.df) = list(if (length(dimnames(y)[[1]]))
+ dimnames(y)[[1]] else
as.character(1:nrow(y)),
dimnames(.grc.df)[[2]])
@@ -2673,20 +2736,20 @@ summary.grc = function(object, ...) {
trplot.qrrvglm = function(object,
- whichSpecies = NULL,
- add = FALSE, plot.it = TRUE,
- label.sites = FALSE,
- sitenames = rownames(object at y),
- axes.equal = TRUE,
- cex=par()$cex,
- col = 1:(nos*(nos-1)/2),
- log = "",
- lty = rep(par()$lty, length.out = nos*(nos-1)/2),
- lwd = rep(par()$lwd, length.out = nos*(nos-1)/2),
- tcol= rep(par()$col, length.out = nos*(nos-1)/2),
- xlab = NULL, ylab = NULL,
- main = "", # "Trajectory plot",
- type = "b", check.ok = TRUE, ...) {
+ whichSpecies = NULL,
+ add = FALSE, plot.it = TRUE,
+ label.sites = FALSE,
+ sitenames = rownames(object at y),
+ axes.equal = TRUE,
+ cex=par()$cex,
+ col = 1:(nos*(nos-1)/2),
+ log = "",
+ lty = rep(par()$lty, length.out = nos*(nos-1)/2),
+ lwd = rep(par()$lwd, length.out = nos*(nos-1)/2),
+ tcol= rep(par()$col, length.out = nos*(nos-1)/2),
+ xlab = NULL, ylab = NULL,
+ main = "", # "Trajectory plot",
+ type = "b", check.ok = TRUE, ...) {
coef.obj = Coef(object) # use defaults for those two arguments
if (coef.obj at Rank != 1) stop("object must be a rank-1 model")
fv = fitted(object)
@@ -2719,13 +2782,15 @@ trplot.qrrvglm = function(object,
second.spp = iam(1,1,M = M,both = TRUE,diag = FALSE)$col.index
myxlab = if (length(whichSpecies.numer) == 2) {
paste("Fitted value for",
- if (is.character(whichSpecies.numer)) whichSpecies.numer[1] else
+ if (is.character(whichSpecies.numer))
+ whichSpecies.numer[1] else
sppNames[whichSpecies.numer[1]])
} else "Fitted value for 'first' species"
myxlab = if (length(xlab)) xlab else myxlab
myylab = if (length(whichSpecies.numer) == 2) {
paste("Fitted value for",
- if (is.character(whichSpecies.numer)) whichSpecies.numer[2] else
+ if (is.character(whichSpecies.numer))
+ whichSpecies.numer[2] else
sppNames[whichSpecies.numer[2]])
} else "Fitted value for 'second' species"
myylab = if (length(ylab)) ylab else myylab
@@ -2770,14 +2835,16 @@ trplot.qrrvglm = function(object,
}
if (!isGeneric("trplot"))
- setGeneric("trplot", function(object, ...) standardGeneric("trplot"))
-setMethod("trplot", "qrrvglm", function(object, ...) trplot.qrrvglm(object, ...))
+ setGeneric("trplot",
+ function(object, ...) standardGeneric("trplot"))
+setMethod("trplot", "qrrvglm",
+ function(object, ...) trplot.qrrvglm(object, ...))
vcovrrvglm = function(object, ...) {
- summary.rrvglm(object, ...)@cov.unscaled
+ summary.rrvglm(object, ...)@cov.unscaled
}
@@ -2785,7 +2852,8 @@ vcovrrvglm = function(object, ...) {
vcovqrrvglm = function(object,
ITolerances = object at control$EqualTolerances,
MaxScale = c("predictors", "response"),
- dispersion = rep(if (length(sobj at dispersion)) sobj at dispersion else 1,
+ dispersion = rep(if (length(sobj at dispersion))
+ sobj at dispersion else 1,
length.out = M), ...) {
stop("this function is not yet completed")
@@ -2809,26 +2877,28 @@ vcovqrrvglm = function(object,
if ((length(object at control$colx1.index) != 1) ||
(names(object at control$colx1.index) != "(Intercept)"))
stop("Can only handle Norrr=~1 models")
- okvals = c(3*M,2*M+1) # Tries to correspond to EqualTol == c(FALSE,TRUE) resp.
+
+ okvals = c(3*M,2*M+1)
if (all(length(coef(object)) != okvals))
- stop("Can only handle intercepts-only model with EqualTolerances = FALSE")
+ stop("Can only handle intercepts-only model with ",
+ "EqualTolerances = FALSE")
answer = NULL
Cov.unscaled = array(NA, c(3,3,M), dimnames=list(
c("(Intercept)", "lv", "lv^2"),
c("(Intercept)", "lv", "lv^2"), dimnames(cobj at D)[[3]]))
- for(spp in 1:M) {
- index = c(M+ifelse(object at control$EqualTolerances, 1, M) + spp,
- spp,
- M+ifelse(object at control$EqualTolerances, 1, spp))
- vcov = Cov.unscaled[,,spp] =
- sobj at cov.unscaled[index,index] # Order is A, D, B1
- se2Max = dvecMax[spp,,drop = FALSE] %*% vcov %*% cbind(dvecMax[spp,])
- se2Tol = dvecTol[spp,,drop = FALSE] %*% vcov %*% cbind(dvecTol[spp,])
- se2Opt = dvecOpt[spp,,drop = FALSE] %*% vcov %*% cbind(dvecOpt[spp,])
- answer = rbind(answer, dispersion[spp]^0.5 *
- c(se2Opt=se2Opt, se2Tol=se2Tol, se2Max=se2Max))
- }
+ for(spp in 1:M) {
+ index = c(M+ifelse(object at control$EqualTolerances, 1, M) + spp,
+ spp,
+ M+ifelse(object at control$EqualTolerances, 1, spp))
+ vcov = Cov.unscaled[,,spp] =
+ sobj at cov.unscaled[index,index] # Order is A, D, B1
+ se2Max = dvecMax[spp,,drop = FALSE] %*% vcov %*% cbind(dvecMax[spp,])
+ se2Tol = dvecTol[spp,,drop = FALSE] %*% vcov %*% cbind(dvecTol[spp,])
+ se2Opt = dvecOpt[spp,,drop = FALSE] %*% vcov %*% cbind(dvecOpt[spp,])
+ answer = rbind(answer, dispersion[spp]^0.5 *
+ c(se2Opt=se2Opt, se2Tol=se2Tol, se2Max=se2Max))
+ }
link.function = if (MaxScale == "predictors")
remove.arg(object at misc$predictors.names[1]) else ""
@@ -2848,9 +2918,11 @@ vcovqrrvglm = function(object,
setMethod("vcov", "rrvglm", function(object, ...)
vcovrrvglm(object, ...))
+
setMethod("vcov", "qrrvglm", function(object, ...)
vcovqrrvglm(object, ...))
+
setClass(Class = "vcov.qrrvglm", representation(
Cov.unscaled = "array", # permuted cov.unscaled
dispersion = "numeric",
@@ -2858,13 +2930,14 @@ setClass(Class = "vcov.qrrvglm", representation(
-model.matrix.qrrvglm <- function(object, type = c("lv", "vlm"), ...) {
+model.matrix.qrrvglm <- function(object,
+ type = c("lv", "vlm"), ...) {
- if (mode(type) != "character" && mode(type) != "name")
- type = as.character(substitute(type))
- type = match.arg(type, c("lv","vlm"))[1]
+ if (mode(type) != "character" && mode(type) != "name")
+ type = as.character(substitute(type))
+ type = match.arg(type, c("lv","vlm"))[1]
- switch(type, lv=Coef(object, ...)@lv, vlm = object at x)
+ switch(type, lv=Coef(object, ...)@lv, vlm = object at x)
}
setMethod("model.matrix", "qrrvglm", function(object, ...)
@@ -2877,21 +2950,24 @@ setMethod("model.matrix", "qrrvglm", function(object, ...)
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),
- whichSpecies = NULL,
- 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, # For Rank == 1 only
- stretch = 1.05, # quick and dirty, Rank == 1 only
- main = "",
- ticktype = "detailed",
- col = if (Rank == 1) par()$col else "white",
- llty=par()$lty, llwd=par()$lwd,
- add1 = FALSE,
- ...) {
+ plot.it = TRUE,
+ xlim = NULL, ylim = NULL,
+ zlim = NULL, # zlim ignored if Rank == 1
+ 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",
+ zlab = "Expected value",
+ labelSpecies = FALSE, # For Rank == 1 only
+ stretch = 1.05, # quick and dirty, Rank == 1 only
+ main = "",
+ ticktype = "detailed",
+ col = if (Rank == 1) par()$col else "white",
+ llty=par()$lty, llwd=par()$lwd,
+ add1 = FALSE,
+ ...) {
oylim = ylim
object = x # don't like x as the primary argument
coef.obj = Coef(object, varlvI = varlvI, reference = reference)
@@ -2901,7 +2977,8 @@ perspqrrvglm = function(x, varlvI = FALSE, reference = NULL,
NOS = ncol(fv) # Number of species
M = object at misc$M #
- xlim = rep(if (length(xlim)) xlim else range(coef.obj at lv[,1]), length = 2)
+ xlim = rep(if (length(xlim)) xlim else
+ range(coef.obj at lv[,1]), length = 2)
if (!length(oylim)) {
ylim = if (Rank == 1) c(0, max(fv)*stretch) else
rep(range(coef.obj at lv[,2]), length = 2)
@@ -2926,7 +3003,8 @@ perspqrrvglm = function(x, varlvI = FALSE, reference = NULL,
for(jay in 1:M) {
for(ii in 1:N) {
LP[jay, ii] = LP[jay, ii] +
- mm[ii, , drop = FALSE] %*% coef.obj at D[,,jay] %*%
+ mm[ii, , drop = FALSE] %*%
+ coef.obj at D[,,jay] %*%
t(mm[ii, , drop = FALSE])
}
}
@@ -2937,18 +3015,20 @@ perspqrrvglm = function(x, varlvI = FALSE, reference = NULL,
dimnames(fitvals) = list(NULL, dimnames(fv)[[2]])
sppNames = dimnames(object at y)[[2]]
if (!length(whichSpecies)) {
- whichSpecies = sppNames[1:NOS]
- whichSpecies.numer = 1:NOS
+ whichSpecies = sppNames[1:NOS]
+ whichSpecies.numer = 1:NOS
} else
if (is.numeric(whichSpecies)) {
- whichSpecies.numer = whichSpecies
- whichSpecies = sppNames[whichSpecies.numer] # Convert to character
- } else
- whichSpecies.numer = match(whichSpecies, sppNames)
+ whichSpecies.numer = whichSpecies
+ whichSpecies = sppNames[whichSpecies.numer] # Convert to character
+ } else {
+ whichSpecies.numer = match(whichSpecies, sppNames)
+ }
if (Rank == 1) {
if (plot.it) {
if (!length(oylim))
- ylim = c(0, max(fitvals[,whichSpecies.numer])*stretch) # A revision
+ ylim = c(0, max(fitvals[,whichSpecies.numer]) *
+ stretch) # A revision
col = rep(col, length.out = length(whichSpecies.numer))
llty = rep(llty, leng=length(whichSpecies.numer))
llwd = rep(llwd, leng=length(whichSpecies.numer))
@@ -2960,7 +3040,8 @@ perspqrrvglm = function(x, varlvI = FALSE, reference = NULL,
lines(lv1, fitvals[,ptr2], col=col[j],
lty=llty[j], lwd=llwd[j], ...)
if (labelSpecies) {
- ptr1=(1:nrow(fitvals))[max(fitvals[,ptr2]) == fitvals[,ptr2]]
+ ptr1 = (1:nrow(fitvals))[max(fitvals[,ptr2]) ==
+ fitvals[,ptr2]]
ptr1 = ptr1[1]
text(lv1[ptr1], fitvals[ptr1,ptr2]+
(stretch-1)*diff(range(ylim)),
@@ -2969,7 +3050,8 @@ perspqrrvglm = function(x, varlvI = FALSE, reference = NULL,
}
}
} else {
- maxfitted = matrix(fitvals[,whichSpecies[1]], length(lv1), length(lv2))
+ maxfitted = matrix(fitvals[,whichSpecies[1]],
+ length(lv1), length(lv2))
if (length(whichSpecies) > 1)
for(j in whichSpecies[-1]) {
maxfitted = pmax(maxfitted, matrix(fitvals[,j],
@@ -2997,7 +3079,8 @@ perspqrrvglm = function(x, varlvI = FALSE, reference = NULL,
setGeneric("persp", function(x, ...) standardGeneric("persp"),
package = "VGAM")
-setMethod("persp", "qrrvglm", function(x, ...) perspqrrvglm(x=x, ...))
+setMethod("persp", "qrrvglm",
+ function(x, ...) perspqrrvglm(x=x, ...))
@@ -3006,37 +3089,49 @@ setMethod("persp", "qrrvglm", function(x, ...) perspqrrvglm(x=x, ...))
-ccoef.qrrvglm = function(object, varlvI = FALSE, reference = NULL, ...) {
+ccoef.qrrvglm = function(object, varlvI = FALSE,
+ reference = NULL, ...) {
Coef(object, varlvI = varlvI, reference = reference, ...)@C
}
+
ccoef.Coef.qrrvglm = function(object, ...) {
- if (length(list(...))) warning("Too late! Ignoring the extra arguments")
- object at C
+ if (length(list(...)))
+ warning("Too late! Ignoring the extra arguments")
+ object at C
}
-lv.qrrvglm <- function(object, varlvI = FALSE, reference = NULL, ...) {
- Coef(object, varlvI = varlvI, reference = reference, ...)@lv
+
+lv.qrrvglm <- function(object, varlvI = FALSE,
+ reference = NULL, ...) {
+ Coef(object, varlvI = varlvI, reference = reference, ...)@lv
}
+
lv.rrvglm = function(object, ...) {
- ans = lvplot(object, plot.it = FALSE)
- if (ncol(ans) == 1) dimnames(ans) = list(dimnames(ans)[[1]], "lv")
- ans
+ ans = lvplot(object, plot.it = FALSE)
+ if (ncol(ans) == 1)
+ dimnames(ans) = list(dimnames(ans)[[1]], "lv")
+ ans
}
+
lv.Coef.qrrvglm = function(object, ...) {
- if (length(list(...))) warning("Too late! Ignoring the extra arguments")
+ if (length(list(...)))
+ warning("Too late! Ignoring the extra arguments")
object at lv
}
-Max.qrrvglm = function(object, varlvI = FALSE, reference = NULL, ...) {
+Max.qrrvglm = function(object, varlvI = FALSE,
+ reference = NULL, ...) {
Coef(object, varlvI = varlvI, reference = reference, ...)@Maximum
}
Max.Coef.qrrvglm = function(object, ...) {
- if (length(list(...))) warning("Too late! Ignoring the extra arguments")
- if (any(slotNames(object) == "Maximum")) object at Maximum else
+ if (length(list(...)))
+ warning("Too late! Ignoring the extra arguments")
+ if (any(slotNames(object) == "Maximum"))
+ object at Maximum else
Max(object, ...)
}
@@ -3045,8 +3140,9 @@ Opt.qrrvglm = function(object, varlvI = FALSE, reference = NULL, ...) {
}
Opt.Coef.qrrvglm = function(object, ...) {
- if (length(list(...))) warning("Too late! Ignoring the extra arguments")
- Coef(object, ...)@Optimum
+ if (length(list(...)))
+ warning("Too late! Ignoring the extra arguments")
+ Coef(object, ...)@Optimum
}
Tol.qrrvglm = function(object, varlvI = FALSE, reference = NULL, ...) {
@@ -3054,52 +3150,77 @@ Tol.qrrvglm = function(object, varlvI = FALSE, reference = NULL, ...) {
}
Tol.Coef.qrrvglm = function(object, ...) {
- if (length(list(...))) warning("Too late! Ignoring the extra arguments")
- if (any(slotNames(object) == "Tolerance")) object at Tolerance else
- Tol(object, ...)
+ if (length(list(...)))
+ warning("Too late! Ignoring the extra arguments")
+ if (any(slotNames(object) == "Tolerance"))
+ object at Tolerance else Tol(object, ...)
}
if (!isGeneric("ccoef"))
- setGeneric("ccoef", function(object, ...) standardGeneric("ccoef"))
-setMethod("ccoef", "rrvglm", function(object, ...) ccoef.qrrvglm(object, ...))
-setMethod("ccoef", "qrrvglm", function(object, ...) ccoef.qrrvglm(object, ...))
-setMethod("ccoef", "Coef.rrvglm", function(object, ...) ccoef.Coef.qrrvglm(object, ...))
-setMethod("ccoef", "Coef.qrrvglm", function(object, ...) ccoef.Coef.qrrvglm(object, ...))
-
-setMethod("coef", "qrrvglm", function(object, ...) Coef.qrrvglm(object, ...))
-setMethod("coefficients", "qrrvglm", function(object, ...) Coef.qrrvglm(object, ...))
+ setGeneric("ccoef", function(object, ...)
+ standardGeneric("ccoef"))
+
+setMethod("ccoef", "rrvglm",
+ function(object, ...) ccoef.qrrvglm(object, ...))
+setMethod("ccoef", "qrrvglm",
+ function(object, ...) ccoef.qrrvglm(object, ...))
+setMethod("ccoef", "Coef.rrvglm",
+ function(object, ...) ccoef.Coef.qrrvglm(object, ...))
+setMethod("ccoef", "Coef.qrrvglm",
+ function(object, ...) ccoef.Coef.qrrvglm(object, ...))
+
+setMethod("coef", "qrrvglm",
+ function(object, ...) Coef.qrrvglm(object, ...))
+setMethod("coefficients", "qrrvglm",
+ function(object, ...) Coef.qrrvglm(object, ...))
if (!isGeneric("lv"))
- setGeneric("lv", function(object, ...) standardGeneric("lv"))
-setMethod("lv", "rrvglm", function(object, ...) lv.rrvglm(object, ...))
-setMethod("lv", "qrrvglm", function(object, ...) lv.qrrvglm(object, ...))
-setMethod("lv", "Coef.rrvglm", function(object, ...) lv.Coef.qrrvglm(object, ...))
-setMethod("lv", "Coef.qrrvglm", function(object, ...) lv.Coef.qrrvglm(object, ...))
+ setGeneric("lv",
+ function(object, ...) standardGeneric("lv"))
+setMethod("lv", "rrvglm",
+ function(object, ...) lv.rrvglm(object, ...))
+setMethod("lv", "qrrvglm",
+ function(object, ...) lv.qrrvglm(object, ...))
+setMethod("lv", "Coef.rrvglm",
+ function(object, ...) lv.Coef.qrrvglm(object, ...))
+setMethod("lv", "Coef.qrrvglm",
+ function(object, ...) lv.Coef.qrrvglm(object, ...))
if (!isGeneric("Max"))
- setGeneric("Max", function(object, ...) standardGeneric("Max"))
-setMethod("Max", "qrrvglm", function(object, ...) Max.qrrvglm(object, ...))
-setMethod("Max", "Coef.qrrvglm", function(object, ...) Max.Coef.qrrvglm(object, ...))
+ setGeneric("Max",
+ function(object, ...) standardGeneric("Max"))
+setMethod("Max", "qrrvglm",
+ function(object, ...) Max.qrrvglm(object, ...))
+setMethod("Max", "Coef.qrrvglm",
+ function(object, ...) Max.Coef.qrrvglm(object, ...))
if (!isGeneric("Opt"))
- setGeneric("Opt", function(object, ...) standardGeneric("Opt"))
-setMethod("Opt", "qrrvglm", function(object, ...) Opt.qrrvglm(object, ...))
-setMethod("Opt", "Coef.qrrvglm", function(object, ...) Opt.Coef.qrrvglm(object, ...))
+ setGeneric("Opt",
+ function(object, ...) standardGeneric("Opt"))
+setMethod("Opt", "qrrvglm",
+ function(object, ...) Opt.qrrvglm(object, ...))
+setMethod("Opt", "Coef.qrrvglm",
+ function(object, ...) Opt.Coef.qrrvglm(object, ...))
if (!isGeneric("Tol"))
- setGeneric("Tol", function(object, ...) standardGeneric("Tol"))
-setMethod("Tol", "qrrvglm", function(object, ...) Tol.qrrvglm(object, ...))
-setMethod("Tol", "Coef.qrrvglm", function(object, ...) Tol.Coef.qrrvglm(object, ...))
+ setGeneric("Tol",
+ function(object, ...) standardGeneric("Tol"))
+setMethod("Tol", "qrrvglm",
+ function(object, ...) Tol.qrrvglm(object, ...))
+setMethod("Tol", "Coef.qrrvglm",
+ function(object, ...) Tol.Coef.qrrvglm(object, ...))
cgo <- function(...) {
- stop("The function 'cgo' has been renamed 'cqo'. Ouch! Sorry!")
+ stop("The function 'cgo' has been renamed 'cqo'. ",
+ "Ouch! Sorry!")
}
clo <- function(...) {
- stop("Constrained linear ordination is fitted with the function 'rrvglm'")
+ stop("Constrained linear ordination is fitted with ",
+ "the function 'rrvglm'")
}
@@ -3107,16 +3228,16 @@ clo <- function(...) {
is.bell.vlm <-
is.bell.rrvglm <- function(object, ...) {
- M = object at misc$M
- ynames = object at misc$ynames
- ans = rep(FALSE, length.out = M)
- if (length(ynames)) names(ans) = ynames
- ans
+ M = object at misc$M
+ ynames = object at misc$ynames
+ ans = rep(FALSE, length.out = M)
+ if (length(ynames)) names(ans) = ynames
+ ans
}
is.bell.uqo <-
is.bell.qrrvglm <- function(object, ...) {
- is.finite(Max(object, ...))
+ is.finite(Max(object, ...))
}
is.bell.cao <- function(object, ...) {
@@ -3124,13 +3245,20 @@ is.bell.cao <- function(object, ...) {
}
if (!isGeneric("is.bell"))
- setGeneric("is.bell", function(object, ...) standardGeneric("is.bell"))
-setMethod("is.bell","uqo", function(object, ...) is.bell.uqo(object, ...))
-setMethod("is.bell","qrrvglm", function(object,...) is.bell.qrrvglm(object,...))
-setMethod("is.bell","rrvglm", function(object, ...) is.bell.rrvglm(object, ...))
-setMethod("is.bell","vlm", function(object, ...) is.bell.vlm(object, ...))
-setMethod("is.bell","cao", function(object, ...) is.bell.cao(object, ...))
-setMethod("is.bell","Coef.qrrvglm", function(object,...) is.bell.qrrvglm(object,...))
+ setGeneric("is.bell",
+ function(object, ...) standardGeneric("is.bell"))
+setMethod("is.bell","uqo",
+ function(object, ...) is.bell.uqo(object, ...))
+setMethod("is.bell","qrrvglm",
+ function(object,...) is.bell.qrrvglm(object,...))
+setMethod("is.bell","rrvglm",
+ function(object, ...) is.bell.rrvglm(object, ...))
+setMethod("is.bell","vlm",
+ function(object, ...) is.bell.vlm(object, ...))
+setMethod("is.bell","cao",
+ function(object, ...) is.bell.cao(object, ...))
+setMethod("is.bell","Coef.qrrvglm",
+ function(object,...) is.bell.qrrvglm(object,...))
diff --git a/R/family.univariate.R b/R/family.univariate.R
index 400590d..50e6085 100644
--- a/R/family.univariate.R
+++ b/R/family.univariate.R
@@ -82,7 +82,8 @@ getMaxMin = function(vov, objfun, y, x, w, extraargs = NULL, maximize = TRUE,
c(namesof("theta", .ltheta, earg = .etheta, tag = FALSE),
namesof("nu", .lnu, earg = .enu, tag = FALSE))
if (!length(etastart)) {
- theta.init = if (length( .itheta)) rep( .itheta, length = n) else {
+ theta.init = if (length( .itheta))
+ rep( .itheta, length = n) else {
mccullagh89.aux = function(thetaval, y, x, w, extraargs)
mean((y-thetaval)*(thetaval^2-1)/(1-2*thetaval*y+thetaval^2))
theta.grid = seq(-0.9, 0.9, by=0.05)
@@ -153,7 +154,8 @@ hzeta.control <- function(save.weight = TRUE, ...)
- hzeta = function(link = "loglog", earg = list(), ialpha = NULL, nsimEIM = 100)
+ hzeta = function(link = "loglog", earg = list(),
+ ialpha = NULL, nsimEIM = 100)
{
stopifnot(ialpha > 0)
@@ -199,7 +201,7 @@ hzeta.control <- function(save.weight = TRUE, ...)
}, list( .link = link, .earg = earg ))),
last = eval(substitute(expression({
misc$link = c(alpha = .link)
- misc$earg = list(alpha = .earg)
+ misc$earg = list(alpha = .earg )
misc$nsimEIM = .nsimEIM
}), list( .link = link, .earg = earg, .nsimEIM = nsimEIM ))),
loglikelihood = eval(substitute(
@@ -253,7 +255,8 @@ dhzeta = function(x, alpha, log = FALSE)
if (!is.Numeric(alpha, positive = TRUE))
stop("'alpha' must be numeric and have positive values")
nn = max(length(x), length(alpha))
- x = rep(x, length.out = nn); alpha = rep(alpha, length.out = nn)
+ x = rep(x, length.out = nn);
+ alpha = rep(alpha, length.out = nn)
ox = !is.finite(x)
zero = ox | round(x) != x | x < 1
ans = rep(0, length.out = nn)
@@ -625,11 +628,11 @@ dirmul.old = function(link = "loge", earg = list(), init.alpha = 0.01,
yy = if (is.numeric( .init.alpha))
matrix( .init.alpha, n, M, byrow= TRUE) else
matrix(runif(n*M), n, M)
- etastart = theta2eta(yy, .link, earg = .earg)
+ etastart = theta2eta(yy, .link, earg = .earg )
}
}), list( .link = link, .earg = earg, .init.alpha=init.alpha ))),
linkinv = eval(substitute(function(eta, extra = NULL) {
- shape = eta2theta(eta, .link, earg = .earg)
+ shape = eta2theta(eta, .link, earg = .earg )
M = if (is.matrix(eta)) ncol(eta) else 1
sumshape = as.vector(shape %*% rep(1, length.out = M))
(extra$y + shape) / (extra$n2 + sumshape)
@@ -644,7 +647,7 @@ dirmul.old = function(link = "loge", earg = list(), init.alpha = 0.01,
}), list( .link = link, .earg = earg ))),
loglikelihood = eval(substitute(
function(mu, y, w, residuals = FALSE, eta, extra = NULL) {
- shape = eta2theta(eta, .link, earg = .earg)
+ shape = eta2theta(eta, .link, earg = .earg )
M = if (is.matrix(eta)) ncol(eta) else 1
sumshape = as.vector(shape %*% rep(1, length.out = M))
if (residuals) stop("loglikelihood residuals not ",
@@ -654,11 +657,11 @@ dirmul.old = function(link = "loge", earg = list(), init.alpha = 0.01,
}, list( .link = link, .earg = earg ))),
vfamily = c("dirmul.old"),
deriv = eval(substitute(expression({
- shape = eta2theta(eta, .link, earg = .earg)
+ shape = eta2theta(eta, .link, earg = .earg )
sumshape = as.vector(shape %*% rep(1, length.out = M))
dl.dsh = digamma(sumshape) - digamma(extra$n2 + sumshape) +
digamma(y + shape) - digamma(shape)
- dsh.deta = dtheta.deta(shape, .link, earg = .earg)
+ dsh.deta = dtheta.deta(shape, .link, earg = .earg )
c(w) * dl.dsh * dsh.deta
}), list( .link = link, .earg = earg ))),
weight = eval(substitute(expression({
@@ -690,14 +693,16 @@ dirmul.old = function(link = "loge", earg = list(), init.alpha = 0.01,
rdiric = function(n, shape, dimension = NULL) {
use.n = if ((length.n <- length(n)) > 1) length.n else
- if (!is.Numeric(n, integer.valued = TRUE, allowable.length = 1, positive = TRUE))
+ if (!is.Numeric(n, integer.valued = TRUE,
+ allowable.length = 1, positive = TRUE))
stop("bad input for argument 'n'") else n
if (!is.numeric(dimension))
dimension = length(shape)
shape = rep(shape, length.out = dimension)
- ans = rgamma(use.n * dimension, rep(shape, rep(use.n, dimension)))
+ ans = rgamma(use.n * dimension,
+ rep(shape, rep(use.n, dimension)))
dim(ans) = c(use.n, dimension)
@@ -735,7 +740,8 @@ rdiric = function(n, shape, dimension = NULL) {
predictors.names = namesof(paste("shape", 1:M, sep = ""), .link,
earg = .earg, short = TRUE)
if (!length(etastart)) {
- yy = matrix(t(y) %*% rep(1/nrow(y), nrow(y)), nrow(y), M, byrow= TRUE)
+ yy = matrix(t(y) %*% rep(1/nrow(y), nrow(y)), nrow(y), M,
+ byrow= TRUE)
etastart = theta2eta(yy, .link, earg = .earg )
}
}), list( .link = link, .earg = earg ))),
@@ -793,7 +799,8 @@ rdiric = function(n, shape, dimension = NULL) {
deriv.arg = deriv
rm(deriv)
- if (!is.Numeric(deriv.arg, allowable.length = 1, integer.valued = TRUE))
+ if (!is.Numeric(deriv.arg, allowable.length = 1,
+ integer.valued = TRUE))
stop("'deriv' must be a single non-negative integer")
if (deriv.arg < 0 || deriv.arg > 2)
stop("'deriv' must be 0, 1, or 2")
@@ -851,7 +858,8 @@ rdiric = function(n, shape, dimension = NULL) {
{
- if (!is.Numeric(deriv.arg, allowable.length = 1, integer.valued = TRUE))
+ if (!is.Numeric(deriv.arg, allowable.length = 1,
+ integer.valued = TRUE))
stop("'deriv.arg' must be a single non-negative integer")
if (deriv.arg < 0 || deriv.arg > 2)
stop("'deriv.arg' must be 0, 1, or 2")
@@ -887,7 +895,8 @@ dzeta = function(x, p, log = FALSE)
if (!is.Numeric(p, positive = TRUE)) # || min(p) <= 1
stop("'p' must be numeric and > 0")
LLL = max(length(p), length(x))
- x = rep(x, length.out = LLL); p = rep(p, length.out = LLL)
+ x = rep(x, length.out = LLL);
+ p = rep(p, length.out = LLL)
ox = !is.finite(x)
zero = ox | round(x) != x | x < 1
@@ -943,22 +952,22 @@ dzeta = function(x, p, log = FALSE)
y = y, x = x, w = w)
pp.init = rep(pp.init, length = length(y))
if ( .link == "loglog") pp.init[pp.init <= 1] = 1.2
- etastart = theta2eta(pp.init, .link, earg = .earg)
+ etastart = theta2eta(pp.init, .link, earg = .earg )
}
}), 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 <- eta2theta(eta, .link, earg = .earg )
ans[pp > 1] <- zeta(pp[pp > 1]) / zeta(pp[pp > 1] + 1)
ans[pp <= 1] <- NA
ans
}, list( .link = link, .earg = earg ))),
last = eval(substitute(expression({
misc$link <- c(pp = .link)
- misc$earg <- list(pp = .earg)
+ misc$earg <- list(pp = .earg )
}), list( .link = link, .earg = earg ))),
loglikelihood = eval(substitute(
function(mu, y, w, residuals = FALSE, eta, extra = NULL) {
- pp = eta2theta(eta, .link, earg = .earg)
+ pp = eta2theta(eta, .link, earg = .earg )
if (residuals) stop("loglikelihood residuals not ",
"implemented yet") else {
sum(w * dzeta(x = y, p = pp, log = TRUE))
@@ -966,11 +975,11 @@ dzeta = function(x, p, log = FALSE)
}, list( .link = link, .earg = earg ))),
vfamily = c("zetaff"),
deriv = eval(substitute(expression({
- pp = eta2theta(eta, .link, earg = .earg)
+ pp = eta2theta(eta, .link, earg = .earg )
fred1 = zeta(pp+1)
fred2 = zeta(pp+1, deriv=1)
dl.dpp = -log(y) - fred2 / fred1
- dpp.deta = dtheta.deta(pp, .link, earg = .earg)
+ dpp.deta = dtheta.deta(pp, .link, earg = .earg )
c(w) * dl.dpp * dpp.deta
}), list( .link = link, .earg = earg ))),
weight = expression({
@@ -1018,16 +1027,18 @@ dzipf = function(x, N, s, log = FALSE)
if (!is.Numeric(s, positive = TRUE))
stop("bad input for argument 's'")
nn = max(length(x), length(N), length(s))
- x = rep(x, length.out = nn); N = rep(N, length.out = nn); s = rep(s, length.out = nn);
+ x = rep(x, length.out = nn);
+ N = rep(N, length.out = nn);
+ s = rep(s, length.out = nn);
ox = !is.finite(x)
zero = ox | round(x) != x | x < 1 | x > N
ans = (if (log.arg) log(0) else 0) * x
if (any(!zero))
if (log.arg) {
- ans[!zero] = (-s[!zero]) * log(x[!zero]) -
- log(gharmonic(N[!zero], s[!zero]))
+ ans[!zero] = (-s[!zero]) * log(x[!zero]) -
+ log(gharmonic(N[!zero], s[!zero]))
} else {
- ans[!zero] = x[!zero]^(-s[!zero]) / gharmonic(N[!zero], s[!zero])
+ ans[!zero] = x[!zero]^(-s[!zero]) / gharmonic(N[!zero], s[!zero])
}
ans
}
@@ -1043,7 +1054,9 @@ pzipf = function(q, N, s) {
stop("bad input for argument 's'")
nn = max(length(q), length(N), length(s))
- q = rep(q, length.out = nn); N = rep(N, length.out = nn); s = rep(s, length.out = nn);
+ q = rep(q, length.out = nn);
+ N = rep(N, length.out = nn);
+ s = rep(s, length.out = nn);
oq = !is.finite(q)
zeroOR1 = oq | q < 1 | q >= N
floorq = floor(q)
@@ -1059,8 +1072,10 @@ pzipf = function(q, N, s) {
zipf = function(N = NULL, link = "loge", earg = list(), init.s = NULL)
{
if (length(N) &&
- (!is.Numeric(N, positive = TRUE, integer.valued = TRUE, allowable.length = 1) || N <= 1))
- stop("bad input for argument 'N'")
+ (!is.Numeric(N, positive = TRUE,
+ integer.valued = TRUE, allowable.length = 1) ||
+ N <= 1))
+ stop("bad input for argument 'N'")
enteredN = length(N)
if (length(init.s) && !is.Numeric(init.s, positive = TRUE))
stop("argument 'init.s' must be > 0")
@@ -1071,7 +1086,8 @@ pzipf = function(q, N, s) {
new("vglmff",
blurb = c("Zipf distribution f(y;s) = y^(-s) / sum((1:N)^(-s)),",
- " s>0, y = 1,2,...,N", ifelse(enteredN, paste(" = ",N,sep = ""), ""),
+ " s > 0, y = 1,2,...,N",
+ ifelse(enteredN, paste(" = ",N,sep = ""), ""),
"\n\n",
"Link: ",
namesof("s", link, earg = earg),
@@ -1085,7 +1101,8 @@ pzipf = function(q, N, s) {
stop("y must be integer-valued")
predictors.names = namesof("s", .link, earg = .earg, tag = FALSE)
NN = .N
- if (!is.Numeric(NN, allowable.length = 1, positive = TRUE, integer.valued = TRUE))
+ if (!is.Numeric(NN, allowable.length = 1,
+ positive = TRUE, integer.valued = TRUE))
NN = max(y)
if (max(y) > NN)
stop("maximum of the response is greater than argument 'N'")
@@ -1100,13 +1117,13 @@ pzipf = function(q, N, s) {
getInitVals(gvals = seq(0.1, 3.0, length.out = 19),
llfun=llfun,
y = y, N=extra$N, w = w)
- ss.init = rep(ss.init, length=length(y))
+ ss.init = rep(ss.init, length = length(y))
if ( .link == "loglog") ss.init[ss.init <= 1] = 1.2
- etastart = theta2eta(ss.init, .link, earg = .earg)
+ etastart = theta2eta(ss.init, .link, earg = .earg )
}
}), list( .link = link, .earg = earg, .init.s = init.s, .N = N ))),
linkinv = eval(substitute(function(eta, extra = NULL) {
- ss = eta2theta(eta, .link, earg = .earg)
+ ss = eta2theta(eta, .link, earg = .earg )
gharmonic(extra$N, s=ss - 1) / gharmonic(extra$N, s=ss)
}, list( .link = link, .earg = earg ))),
last = eval(substitute(expression({
@@ -1117,7 +1134,7 @@ pzipf = function(q, N, s) {
}), list( .link = link, .earg = earg ))),
loglikelihood = eval(substitute(
function(mu, y, w, residuals = FALSE, eta, extra = NULL) {
- ss = eta2theta(eta, .link, earg = .earg)
+ ss = eta2theta(eta, .link, earg = .earg )
if (residuals) stop("loglikelihood residuals not ",
"implemented yet") else {
sum(w * dzipf(x = y, N=extra$N, s=ss, log = TRUE))
@@ -1125,12 +1142,12 @@ pzipf = function(q, N, s) {
}, list( .link = link, .earg = earg ))),
vfamily = c("zipf"),
deriv = eval(substitute(expression({
- ss = eta2theta(eta, .link, earg = .earg)
+ ss = eta2theta(eta, .link, earg = .earg )
fred1 = gharmonic(extra$N, ss)
fred2 = gharmonic(extra$N, ss, lognexp=1)
dl.dss = -log(y) + fred2 / fred1
- dss.deta = dtheta.deta(ss, .link, earg = .earg)
- d2ss.deta2 = d2theta.deta2(ss, .link, earg = .earg)
+ dss.deta = dtheta.deta(ss, .link, earg = .earg )
+ d2ss.deta2 = d2theta.deta2(ss, .link, earg = .earg )
c(w) * dl.dss * dss.deta
}), list( .link = link, .earg = earg ))),
weight = expression({
@@ -1176,7 +1193,8 @@ cauchy.control <- function(save.weight = TRUE, ...)
stop("bad input for argument 'iprobs'")
new("vglmff",
- blurb = c("Two parameter Cauchy distribution (location & scale unknown)\n\n",
+ blurb = c("Two parameter Cauchy distribution ",
+ "(location & scale unknown)\n\n",
"Link: ",
namesof("location", llocation, earg = elocation), "\n",
namesof("scale", lscale, earg = escale), "\n\n",
@@ -1230,7 +1248,8 @@ cauchy.control <- function(save.weight = TRUE, ...)
etastart = cbind(theta2eta(loc.init, .llocation, earg = .elocation),
theta2eta(sca.init, .lscale, earg = .escale))
}
- }), list( .ilocation = ilocation, .elocation = elocation, .llocation = llocation,
+ }), list( .ilocation = ilocation,
+ .elocation = elocation, .llocation = llocation,
.iscale = iscale, .escale = escale, .lscale = lscale,
.iprobs=iprobs, .imethod = imethod ))),
linkinv = eval(substitute(function(eta, extra = NULL) {
@@ -1312,10 +1331,12 @@ cauchy.control <- function(save.weight = TRUE, ...)
{
if (mode(llocation) != "character" && mode(llocation) != "name")
llocation = as.character(substitute(llocation))
- if (!is.Numeric(scale.arg, positive = TRUE)) stop("bad input for 'scale.arg'")
- if (!is.Numeric(imethod, allowable.length = 1, integer.valued = TRUE, positive = TRUE) ||
+ if (!is.Numeric(scale.arg, positive = TRUE))
+ stop("bad input for 'scale.arg'")
+ if (!is.Numeric(imethod, allowable.length = 1,
+ integer.valued = TRUE, positive = TRUE) ||
imethod > 3)
- stop("argument 'imethod' must be 1 or 2 or 3")
+ stop("argument 'imethod' must be 1 or 2 or 3")
if (!is.list(elocation)) elocation = list()
new("vglmff",
@@ -1403,12 +1424,13 @@ cauchy.control <- function(save.weight = TRUE, ...)
scale.arg = 1, imethod = 1)
{
if (mode(llocation) != "character" && mode(llocation) != "name")
- llocation = as.character(substitute(llocation))
+ llocation = as.character(substitute(llocation))
if (!is.Numeric(scale.arg, allowable.length = 1, positive = TRUE))
- stop("'scale.arg' must be a single positive number")
- if (!is.Numeric(imethod, allowable.length = 1, integer.valued = TRUE, positive = TRUE) ||
+ stop("'scale.arg' must be a single positive number")
+ if (!is.Numeric(imethod, allowable.length = 1,
+ integer.valued = TRUE, positive = TRUE) ||
imethod > 2)
- stop("argument 'imethod' must be 1 or 2")
+ stop("argument 'imethod' must be 1 or 2")
if (!is.list(elocation)) elocation = list()
new("vglmff",
@@ -1424,7 +1446,8 @@ cauchy.control <- function(save.weight = TRUE, ...)
if (!length(etastart)) {
location.init = if ( .imethod == 1) y else median(rep(y, w))
location.init = rep(location.init, length.out = n)
- if ( .llocation == "loge") location.init = abs(location.init) + 0.001
+ if ( .llocation == "loge")
+ location.init = abs(location.init) + 0.001
etastart = theta2eta(location.init, .llocation, earg = .elocation)
}
}), list( .imethod = imethod, .llocation = llocation,
@@ -1505,12 +1528,12 @@ cauchy.control <- function(save.weight = TRUE, ...)
sc.init = median(y) / .shape.arg
sc.init = rep(sc.init, length = n)
}
- etastart = theta2eta(sc.init, .link, earg = .earg)
+ etastart = theta2eta(sc.init, .link, earg = .earg )
}
}), list( .link = link, .earg = earg,
.shape.arg=shape.arg, .imethod = imethod ))),
linkinv = eval(substitute(function(eta, extra = NULL) {
- sc = eta2theta(eta, .link, earg = .earg)
+ sc = eta2theta(eta, .link, earg = .earg )
.shape.arg * sc
}, list( .link = link, .earg = earg, .shape.arg=shape.arg ))),
last = eval(substitute(expression({
@@ -1521,7 +1544,7 @@ cauchy.control <- function(save.weight = TRUE, ...)
}), list( .link = link, .earg = earg, .shape.arg=shape.arg ))),
loglikelihood = eval(substitute(
function(mu, y, w, residuals = FALSE, eta, extra = NULL) {
- sc = eta2theta(eta, .link, earg = .earg)
+ sc = eta2theta(eta, .link, earg = .earg )
if (residuals) stop("loglikelihood residuals not ",
"implemented yet") else {
sum(w * (( .shape.arg - 1) * log(y) - y / sc - .shape.arg * log(sc) -
@@ -1530,9 +1553,9 @@ cauchy.control <- function(save.weight = TRUE, ...)
}, list( .link = link, .earg = earg, .shape.arg=shape.arg ))),
vfamily = c("erlang"),
deriv = eval(substitute(expression({
- sc = eta2theta(eta, .link, earg = .earg)
+ sc = eta2theta(eta, .link, earg = .earg )
dl.dsc = (y / sc - .shape.arg) / sc
- dsc.deta = dtheta.deta(sc, .link, earg = .earg)
+ dsc.deta = dtheta.deta(sc, .link, earg = .earg )
c(w) * dl.dsc * dsc.deta
}), list( .link = link, .earg = earg, .shape.arg=shape.arg ))),
weight = eval(substitute(expression({
@@ -1551,13 +1574,17 @@ dbort = function(x, Qsize = 1, a=0.5, log = FALSE) {
stop("bad input for argument 'log'")
rm(log)
- if (!is.Numeric(x)) stop("bad input for argument 'x'")
- if (!is.Numeric(Qsize, allowable.length = 1, integer.valued = TRUE, positive = TRUE))
- stop("bad input for argument 'Qsize'")
+ if (!is.Numeric(x))
+ stop("bad input for argument 'x'")
+ if (!is.Numeric(Qsize, allowable.length = 1,
+ integer.valued = TRUE, positive = TRUE))
+ stop("bad input for argument 'Qsize'")
if (!is.Numeric(a, positive = TRUE) || max(a) >= 1)
- stop("bad input for argument 'a'")
+ stop("bad input for argument 'a'")
N = max(length(x), length(Qsize), length(a))
- x = rep(x, length.out = N); Qsize = rep(Qsize, length.out = N); a = rep(a, length.out = N);
+ x = rep(x, length.out = N);
+ Qsize = rep(Qsize, length.out = N);
+ a = rep(a, length.out = N);
xok = (x >= Qsize) & (x == round(x)) & (a > 0) & (a < 1)
ans = rep(if (log.arg) log(0) else 0, length.out = N) # loglikelihood
@@ -1574,16 +1601,19 @@ dbort = function(x, Qsize = 1, a=0.5, log = FALSE) {
rbort = function(n, Qsize = 1, a = 0.5) {
use.n = if ((length.n <- length(n)) > 1) length.n else
- if (!is.Numeric(n, integer.valued = TRUE, allowable.length = 1, positive = TRUE))
+ if (!is.Numeric(n, integer.valued = TRUE,
+ allowable.length = 1, positive = TRUE))
stop("bad input for argument 'n'") else n
- if (!is.Numeric(Qsize, allowable.length = 1, integer.valued = TRUE, positive = TRUE))
+ if (!is.Numeric(Qsize, allowable.length = 1,
+ integer.valued = TRUE, positive = TRUE))
stop("bad input for argument 'Qsize'")
if (!is.Numeric(a, positive = TRUE) ||
max(a) >= 1)
stop("bad input for argument 'a'")
N = use.n
- qsize = rep(Qsize, length.out = N); a = rep(a, length.out = N)
+ qsize = rep(Qsize, length.out = N);
+ a = rep(a, length.out = N)
totqsize = qsize
fini = (qsize < 1)
while(any(!fini)) {
@@ -1597,16 +1627,19 @@ rbort = function(n, Qsize = 1, a = 0.5) {
}
- borel.tanner = function(Qsize = 1, link = "logit", earg = list(), imethod = 1)
+ borel.tanner = function(Qsize = 1, link = "logit",
+ earg = list(), imethod = 1)
{
- if (!is.Numeric(Qsize, allowable.length = 1, integer.valued = TRUE, positive = TRUE))
- stop("bad input for argument 'Qsize'")
+ if (!is.Numeric(Qsize, allowable.length = 1,
+ integer.valued = TRUE, positive = TRUE))
+ stop("bad input for argument 'Qsize'")
if (mode(link) != "character" && mode(link) != "name")
- link = as.character(substitute(link))
+ link = as.character(substitute(link))
if (!is.list(earg)) earg = list()
- if (!is.Numeric(imethod, allowable.length = 1, integer.valued = TRUE, positive = TRUE) ||
- imethod > 4)
- stop("argument 'imethod' must be 1 or 2, 3 or 4")
+ if (!is.Numeric(imethod, allowable.length = 1,
+ integer.valued = TRUE, positive = TRUE) ||
+ imethod > 4)
+ stop("argument 'imethod' must be 1 or 2, 3 or 4")
new("vglmff",
blurb = c("Borel-Tanner distribution\n\n",
@@ -1631,12 +1664,12 @@ rbort = function(n, Qsize = 1, a = 0.5) {
"2" = rep(1 - .Qsize / weighted.mean(y, w), length.out = n),
"3" = rep(1 - .Qsize / median(y), length.out = n),
"4" = rep(0.5, length.out = n))
- etastart = theta2eta(a.init, .link, earg = .earg)
+ etastart = theta2eta(a.init, .link, earg = .earg )
}
}), list( .link = link, .earg = earg, .Qsize=Qsize,
.imethod = imethod ))),
linkinv = eval(substitute(function(eta, extra = NULL) {
- a = eta2theta(eta, .link, earg = .earg)
+ a = eta2theta(eta, .link, earg = .earg )
.Qsize / (1 - a)
}, list( .link = link, .earg = earg, .Qsize=Qsize ))),
last = eval(substitute(expression({
@@ -1647,7 +1680,7 @@ rbort = function(n, Qsize = 1, a = 0.5) {
}), list( .link = link, .earg = earg, .Qsize=Qsize ))),
loglikelihood = eval(substitute(
function(mu, y, w, residuals = FALSE, eta, extra = NULL) {
- aa = eta2theta(eta, .link, earg = .earg)
+ aa = eta2theta(eta, .link, earg = .earg )
if (residuals) stop("loglikelihood residuals not ",
"implemented yet") else {
sum(w * dbort(x = y, Qsize= .Qsize, a=aa, log = TRUE))
@@ -1655,9 +1688,9 @@ rbort = function(n, Qsize = 1, a = 0.5) {
}, list( .link = link, .earg = earg, .Qsize=Qsize ))),
vfamily = c("borel.tanner"),
deriv = eval(substitute(expression({
- a = eta2theta(eta, .link, earg = .earg)
+ a = eta2theta(eta, .link, earg = .earg )
dl.da = (y- .Qsize)/a - y
- da.deta = dtheta.deta(a, .link, earg = .earg)
+ da.deta = dtheta.deta(a, .link, earg = .earg )
c(w) * dl.da * da.deta
}), list( .link = link, .earg = earg, .Qsize=Qsize ))),
weight = eval(substitute(expression({
@@ -1674,10 +1707,13 @@ dfelix = function(x, a = 0.25, log = FALSE) {
stop("bad input for argument 'log'")
rm(log)
- if (!is.Numeric(x)) stop("bad input for argument 'x'")
- if (!is.Numeric(a, positive = TRUE)) stop("bad input for argument 'a'")
+ if (!is.Numeric(x))
+ stop("bad input for argument 'x'")
+ if (!is.Numeric(a, positive = TRUE))
+ stop("bad input for argument 'a'")
N = max(length(x), length(a))
- x = rep(x, length.out = N); a = rep(a, length.out = N);
+ x = rep(x, length.out = N);
+ a = rep(a, length.out = N);
xok = (x %% 2 == 1) & (x == round(x)) & (x >= 1) & (a > 0) & (a < 0.5)
ans = rep(if (log.arg) log(0) else 0, length.out = N) # loglikelihood
@@ -1698,7 +1734,8 @@ dfelix = function(x, a = 0.25, log = FALSE) {
if (mode(link) != "character" && mode(link) != "name")
link = as.character(substitute(link))
if (!is.list(earg)) earg = list()
- if (!is.Numeric(imethod, allowable.length = 1, integer.valued = TRUE, positive = TRUE) ||
+ if (!is.Numeric(imethod, allowable.length = 1,
+ integer.valued = TRUE, positive = TRUE) ||
imethod > 4)
stop("argument 'imethod' must be 1 or 2, 3 or 4")
@@ -1719,15 +1756,18 @@ dfelix = function(x, a = 0.25, log = FALSE) {
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), length.out = n),
- "3" = rep((median(y)-1+1/8) / (2*(median(y)+1/8)+1/8), length.out = n),
- "4" = rep(0.25, length.out = n))
- etastart = theta2eta(a.init, .link, earg = .earg)
+ "2" = rep((wymean-1+1/8) / (2*(wymean+1/8)+1/8),
+ length.out = n),
+ "3" = rep((median(y)-1+1/8) / (2*(median(y)+1/8)+1/8),
+ length.out = n),
+ "4" = rep(0.25,
+ length.out = n))
+ etastart = theta2eta(a.init, .link, earg = .earg )
}
}), list( .link = link, .earg = earg,
.imethod = imethod ))),
linkinv = eval(substitute(function(eta, extra = NULL) {
- a = eta2theta(eta, .link, earg = .earg)
+ a = eta2theta(eta, .link, earg = .earg )
1 / (1 - 2*a)
}, list( .link = link, .earg = earg ))),
last = eval(substitute(expression({
@@ -1737,7 +1777,7 @@ dfelix = function(x, a = 0.25, log = FALSE) {
}), list( .link = link, .earg = earg ))),
loglikelihood = eval(substitute(
function(mu, y, w, residuals = FALSE, eta, extra = NULL) {
- aa = eta2theta(eta, .link, earg = .earg)
+ aa = eta2theta(eta, .link, earg = .earg )
if (residuals) stop("loglikelihood residuals not ",
"implemented yet") else {
sum(w * dfelix(x = y, a=aa, log = TRUE))
@@ -1745,9 +1785,9 @@ dfelix = function(x, a = 0.25, log = FALSE) {
}, list( .link = link, .earg = earg ))),
vfamily = c("felix"),
deriv = eval(substitute(expression({
- a = eta2theta(eta, .link, earg = .earg)
+ a = eta2theta(eta, .link, earg = .earg )
dl.da = (y- 1)/(2*a) - y
- da.deta = dtheta.deta(a, .link, earg = .earg)
+ da.deta = dtheta.deta(a, .link, earg = .earg )
c(w) * dl.da * da.deta
}), list( .link = link, .earg = earg ))),
weight = eval(substitute(expression({
@@ -1767,8 +1807,9 @@ dfelix = function(x, a = 0.25, log = FALSE) {
ephi = list(),
imu = NULL, iphi = NULL, imethod = 1, zero = NULL)
{
- if (!is.Numeric(A, allowable.length = 1) || !is.Numeric(B, allowable.length = 1) || A >= B)
- stop("A must be < B, and both must be of length one")
+ if (!is.Numeric(A, allowable.length = 1) ||
+ !is.Numeric(B, allowable.length = 1) || A >= B)
+ stop("A must be < B, and both must be of length one")
stdbeta = (A == 0 && B == 1)
if (mode(lmu) != "character" && mode(lmu) != "name")
@@ -1792,7 +1833,8 @@ dfelix = function(x, a = 0.25, log = FALSE) {
if (!is.list(ephi)) ephi = list()
new("vglmff",
- blurb = c("Beta distribution parameterized by mu and a precision parameter\n",
+ blurb = c("Beta distribution parameterized by mu and a ",
+ "precision parameter\n",
if (stdbeta) paste("f(y) = y^(mu*phi-1) * (1-y)^((1-mu)*phi-1)",
"/ beta(mu*phi,(1-mu)*phi), 0<y<1, 0<mu<1, phi>0\n\n") else
paste("f(y) = (y-",A,")^(mu1*phi-1) * (",B,
@@ -2052,12 +2094,15 @@ dfelix = function(x, a = 0.25, log = FALSE) {
if (!length(etastart)) {
etastart = cbind(shape1= rep( .i1, length.out = length(y)),
shape2= .i2,
- A = if (length( .iA)) .iA else min(y)-my.range/70,
- B = if (length( .iB)) .iB else max(y)+my.range/70)
+ A = if (length( .iA)) .iA else
+ min(y)-my.range/70,
+ B = if (length( .iB)) .iB else
+ max(y)+my.range/70)
}
- }), list( .i1=i1, .i2=i2, .iA=iA, .iB=iB, .link = link, .earg = earg ))),
+ }), list( .i1=i1, .i2=i2, .iA=iA, .iB=iB,
+ .link = link, .earg = earg ))),
linkinv = eval(substitute(function(eta, extra = NULL) {
- shapes = eta2theta(eta[, 1:2], .link, earg = .earg)
+ shapes = eta2theta(eta[, 1:2], .link, earg = .earg )
.A = eta[, 3]
.B = eta[, 4]
.A + ( .B-.A) * shapes[, 1] / (shapes[, 1] + shapes[, 2])
@@ -2070,7 +2115,7 @@ dfelix = function(x, a = 0.25, log = FALSE) {
}), list( .link = link, .earg = earg ))),
loglikelihood = eval(substitute(
function(mu, y, w, residuals = FALSE, eta, extra = NULL) {
- shapes = eta2theta(eta[, 1:2], .link, earg = .earg)
+ shapes = eta2theta(eta[, 1:2], .link, earg = .earg )
.A = eta[, 3]
.B = eta[, 4]
temp = lbeta(shapes[, 1], shapes[, 2])
@@ -2081,10 +2126,10 @@ dfelix = function(x, a = 0.25, log = FALSE) {
}, list( .link = link, .earg = earg ))),
vfamily = "beta4",
deriv = eval(substitute(expression({
- shapes = eta2theta(eta[, 1:2], .link, earg = .earg)
+ shapes = eta2theta(eta[, 1:2], .link, earg = .earg )
.A = eta[, 3]
.B = eta[, 4]
- dshapes.deta = dtheta.deta(shapes, .link, earg = .earg)
+ dshapes.deta = dtheta.deta(shapes, .link, earg = .earg )
rr1 = ( .B - .A)
temp3 = (shapes[, 1] + shapes[, 2] - 1)
temp1 = temp3 / rr1
@@ -2212,32 +2257,32 @@ dfelix = function(x, a = 0.25, log = FALSE) {
mustart <- y + (y == extra$loc) / 8
if (!length(etastart))
etastart <- theta2eta(1 / (mustart - extra$loc),
- .link, earg = .earg)
+ .link, earg = .earg )
}), list( .location = location, .link = link, .earg = earg ))),
linkinv = eval(substitute(function(eta, extra = NULL)
- extra$loc + 1 / eta2theta(eta, .link, earg = .earg),
+ extra$loc + 1 / eta2theta(eta, .link, earg = .earg ),
list( .link = link, .earg = earg ))),
last = eval(substitute(expression({
misc$location <- extra$loc
misc$link <- c(rate = .link)
- misc$earg <- list(rate = .earg)
+ misc$earg <- list(rate = .earg )
misc$expected <- .expected
}), list( .link = link, .earg = earg, .expected = expected ))),
linkfun = eval(substitute(function(mu, extra = NULL)
- theta2eta(1 / (mu - extra$loc), .link, earg = .earg),
+ theta2eta(1 / (mu - extra$loc), .link, earg = .earg ),
list( .link = link, .earg = earg ))),
vfamily = c("exponential"),
deriv = eval(substitute(expression({
rate <- 1 / (mu - extra$loc)
dl.drate <- mu - y
- drate.deta <- dtheta.deta(rate, .link, earg = .earg)
+ drate.deta <- dtheta.deta(rate, .link, earg = .earg )
c(w) * dl.drate * drate.deta
}), list( .link = link, .earg = earg ))),
weight = eval(substitute(expression({
d2l.drate2 <- -((mu-extra$loc)^2)
wz <- -(drate.deta^2) * d2l.drate2
if (! .expected) {
- d2rate.deta2 <- d2theta.deta2(rate, .link, earg = .earg)
+ d2rate.deta2 <- d2theta.deta2(rate, .link, earg = .earg )
wz <- wz - dl.drate * d2rate.deta2
}
c(w) * wz
@@ -2270,7 +2315,7 @@ dfelix = function(x, a = 0.25, log = FALSE) {
etastart = cbind(theta2eta(y + 1/8, .link, earg = .earg ))
}), list( .link = link, .earg = earg ))),
linkinv = eval(substitute(function(eta, extra = NULL)
- eta2theta(eta, .link, earg = .earg)),
+ eta2theta(eta, .link, earg = .earg )),
list( .link = link, .earg = earg )),
last = eval(substitute(expression({
temp.names = if (M == 1) "shape" else paste("shape", 1:M, sep = "")
@@ -2282,7 +2327,7 @@ dfelix = function(x, a = 0.25, log = FALSE) {
misc$expected = TRUE
}), list( .link = link, .earg = earg ))),
linkfun = eval(substitute(function(mu, extra = NULL)
- theta2eta(mu, .link, earg = .earg)),
+ theta2eta(mu, .link, earg = .earg )),
list( .link = link, .earg = earg )),
loglikelihood= function(mu, y, w, residuals = FALSE, eta, extra = NULL)
if (residuals) stop("loglikelihood residuals not ",
@@ -2293,7 +2338,7 @@ dfelix = function(x, a = 0.25, log = FALSE) {
deriv = eval(substitute(expression({
shape = mu
dl.dshape = log(y) - digamma(shape)
- dshape.deta = dtheta.deta(shape, .link, earg = .earg)
+ dshape.deta = dtheta.deta(shape, .link, earg = .earg )
c(w) * dl.dshape * dshape.deta
}), list( .link = link, .earg = earg ))),
weight = expression({
@@ -2599,7 +2644,8 @@ dfelix = function(x, a = 0.25, log = FALSE) {
if (!is.list(earg)) earg = list()
- if (!is.Numeric(imethod, allowable.length = 1, integer.valued = TRUE, positive = TRUE) ||
+ if (!is.Numeric(imethod, allowable.length = 1,
+ integer.valued = TRUE, positive = TRUE) ||
imethod > 3)
stop("argument 'imethod' must be 1 or 2 or 3")
@@ -2632,12 +2678,12 @@ dfelix = function(x, a = 0.25, log = FALSE) {
prob.init = 0 * prob.init + .iprob
- etastart = theta2eta(prob.init, .link, earg = .earg)
+ etastart = theta2eta(prob.init, .link, earg = .earg )
}
}), list( .link = link, .earg = earg, .imethod = imethod,
.iprob = iprob ))),
linkinv = eval(substitute(function(eta, extra = NULL) {
- prob = eta2theta(eta, .link, earg = .earg)
+ prob = eta2theta(eta, .link, earg = .earg )
(1 - prob) / prob
}, list( .link = link, .earg = earg ))),
last = eval(substitute(expression({
@@ -2651,7 +2697,7 @@ dfelix = function(x, a = 0.25, log = FALSE) {
.expected = expected, .imethod = imethod ))),
loglikelihood = eval(substitute(
function(mu, y, w, residuals = FALSE, eta, extra = NULL) {
- prob = eta2theta(eta, .link, earg = .earg)
+ prob = eta2theta(eta, .link, earg = .earg )
if (residuals) stop("loglikelihood residuals not ",
"implemented yet") else {
sum(w * dgeom(x = y, prob = prob, log = TRUE))
@@ -2659,9 +2705,9 @@ dfelix = function(x, a = 0.25, log = FALSE) {
}, list( .link = link, .earg = earg ))),
vfamily = c("geometric"),
deriv = eval(substitute(expression({
- prob = eta2theta(eta, .link, earg = .earg)
+ prob = eta2theta(eta, .link, earg = .earg )
dl.dprob = -y / (1-prob) + 1/prob
- dprobdeta = dtheta.deta(prob, .link, earg = .earg)
+ dprobdeta = dtheta.deta(prob, .link, earg = .earg )
c(w) * cbind(dl.dprob * dprobdeta)
}), list( .link = link, .earg = earg, .expected = expected ))),
weight = eval(substitute(expression({
@@ -2672,7 +2718,7 @@ dfelix = function(x, a = 0.25, log = FALSE) {
}
wz = ed2l.dprob2 * dprobdeta^2
if ( !( .expected ))
- wz = wz - dl.dprob * d2theta.deta2(prob, .link, earg = .earg)
+ wz = wz - dl.dprob * d2theta.deta2(prob, .link, earg = .earg )
c(w) * wz
}), list( .link = link, .earg = earg,
.expected = expected ))))
@@ -2693,7 +2739,9 @@ dbetageom = function(x, shape1, shape2, log = FALSE) {
if (!is.Numeric(shape2, positive = TRUE))
stop("bad input for argument 'shape2'")
N = max(length(x), length(shape1), length(shape2))
- x = rep(x, length.out = N); shape1 = rep(shape1, length.out = N); shape2 = rep(shape2, length.out = N)
+ x = rep(x, length.out = N);
+ shape1 = rep(shape1, length.out = N);
+ shape2 = rep(shape2, length.out = N)
loglik = lbeta(1+shape1, shape2+abs(x)) - lbeta(shape1, shape2)
xok = (x == round(x) & x >= 0)
loglik[!xok] = log(0)
@@ -2713,7 +2761,9 @@ pbetageom = function(q, shape1, shape2, log.p = FALSE) {
if (!is.Numeric(shape2, positive = TRUE))
stop("bad input for argument 'shape2'")
N = max(length(q), length(shape1), length(shape2))
- q = rep(q, length.out = N); shape1 = rep(shape1, length.out = N); shape2 = rep(shape2, length.out = N)
+ q = rep(q, length.out = N);
+ shape1 = rep(shape1, length.out = N);
+ shape2 = rep(shape2, length.out = N)
ans = q * 0 # Retains names(q)
if (max(abs(shape1-shape1[1])) < 1.0e-08 &&
max(abs(shape2-shape2[1])) < 1.0e-08) {
@@ -3716,7 +3766,8 @@ polya.control <- function(save.weight = TRUE, ...)
- if (!is.Numeric(imethod, allowable.length = 1, integer.valued = TRUE, positive = TRUE) ||
+ if (!is.Numeric(imethod, allowable.length = 1,
+ integer.valued = TRUE, positive = TRUE) ||
imethod > 3)
stop("argument 'imethod' must be 1 or 2 or 3")
@@ -3780,12 +3831,16 @@ polya.control <- function(save.weight = TRUE, ...)
init.sca <- if (length( .isca )) .isca else
sdvec / 2.3
- sdvec <- rep(sdvec, length.out = max(length(sdvec), length(init.sca)))
- init.sca <- rep(init.sca, length.out = max(length(sdvec), length(init.sca)))
+ sdvec <- rep(sdvec,
+ length.out = max(length(sdvec),
+ length(init.sca)))
+ init.sca <- rep(init.sca,
+ length.out = max(length(sdvec),
+ length(init.sca)))
ind9 <- (sdvec / init.sca <= (1 + 0.12))
sdvec[ind9] <- sqrt(1.12) * init.sca[ind9]
init.dof <- if (length( .idof )) .idof else
- (2 * (sdvec / init.sca)^2) / ((sdvec / init.sca)^2 - 1)
+ (2 * (sdvec / init.sca)^2) / ((sdvec / init.sca)^2 - 1)
if (!is.Numeric(init.dof) || init.dof <= 1)
init.dof <- rep(3, length.out = ncoly)
@@ -3960,7 +4015,8 @@ polya.control <- function(save.weight = TRUE, ...)
if (!is.Numeric(doff, positive = TRUE))
stop("argument 'df' must be positive")
- if (!is.Numeric(imethod, allowable.length = 1, integer.valued = TRUE, positive = TRUE) ||
+ if (!is.Numeric(imethod, allowable.length = 1,
+ integer.valued = TRUE, positive = TRUE) ||
imethod > 3)
stop("argument 'imethod' must be 1 or 2 or 3")
@@ -4153,27 +4209,27 @@ polya.control <- function(save.weight = TRUE, ...)
mustart <- y + (1 / 8) * (y == 0)
}), list( .link = link, .earg = earg ))),
linkinv = eval(substitute(function(eta, extra = NULL) {
- eta2theta(eta, .link, earg = .earg)
+ 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 ))),
linkfun = eval(substitute(function(mu, extra = NULL) {
- theta2eta(mu, .link, earg = .earg)
+ theta2eta(mu, .link, earg = .earg )
}, list( .link = link, .earg = earg ))),
loglikelihood = eval(substitute(
function(mu, y, w, residuals = FALSE, eta, extra = NULL) {
- mydf <- eta2theta(eta, .link, earg = .earg)
+ mydf <- eta2theta(eta, .link, earg = .earg )
if (residuals) stop("loglikelihood residuals not ",
"implemented yet") else
sum(w * dchisq(x = y, df = mydf, ncp = 0, log = TRUE))
}, list( .link = link, .earg = earg ))),
vfamily = "chisq",
deriv = eval(substitute(expression({
- mydf <- eta2theta(eta, .link, earg = .earg)
+ mydf <- eta2theta(eta, .link, earg = .earg )
dl.dv <- (log(y / 2) - digamma(mydf / 2)) / 2
- dv.deta <- dtheta.deta(mydf, .link, earg = .earg)
+ dv.deta <- dtheta.deta(mydf, .link, earg = .earg )
c(w) * dl.dv * dv.deta
}), list( .link = link, .earg = earg ))),
weight = eval(substitute(expression({
@@ -4210,12 +4266,14 @@ dsimplex = function(x, mu = 0.5, dispersion = 1, log = FALSE) {
rsimplex = function(n, mu = 0.5, dispersion = 1) {
use.n = if ((length.n <- length(n)) > 1) length.n else
- if (!is.Numeric(n, integer.valued = TRUE, allowable.length = 1, positive = TRUE))
+ if (!is.Numeric(n, integer.valued = TRUE,
+ allowable.length = 1, positive = TRUE))
stop("bad input for argument 'n'") else n
oneval <- (length(mu) == 1 && length(dispersion) == 1)
answer = rep(0.0, length.out = use.n)
- mu = rep(mu, length.out = use.n); dispersion = rep(dispersion, length.out = use.n)
+ mu = rep(mu, length.out = use.n);
+ dispersion = rep(dispersion, length.out = use.n)
Kay1 = 3 * (dispersion * mu * (1-mu))^2
if (oneval) {
@@ -4528,12 +4586,12 @@ rsimplex = function(n, mu = 0.5, dispersion = 1) {
if (!length(etastart)) {
theta.init = rep(if (length( .init.theta)) .init.theta else
median(y), length = n)
- etastart = theta2eta(theta.init, .link.theta, earg = .earg)
+ etastart = theta2eta(theta.init, .link.theta, earg = .earg )
}
}), list( .link.theta = link.theta, .earg = earg,
.init.theta=init.theta ))),
linkinv = eval(substitute(function(eta, extra = NULL) {
- theta = eta2theta(eta, .link.theta, earg = .earg)
+ theta = eta2theta(eta, .link.theta, earg = .earg )
tan(theta)
}, list( .link.theta = link.theta, .earg = earg ))),
last = eval(substitute(expression({
@@ -4542,16 +4600,16 @@ rsimplex = function(n, mu = 0.5, dispersion = 1) {
misc$expected = TRUE
}), list( .link.theta = link.theta, .earg = earg ))),
loglikelihood = eval(substitute(function(mu, y, w, residuals = FALSE, eta, extra = NULL) {
- theta = eta2theta(eta, .link.theta, earg = .earg)
+ theta = eta2theta(eta, .link.theta, earg = .earg )
if (residuals) stop("loglikelihood residuals not ",
"implemented yet") else
sum(w * (theta*y + log(cos(theta)) - log(cosh(pi*y/2 ))))
}, list( .link.theta = link.theta, .earg = earg ))),
vfamily = c("hypersecant"),
deriv = eval(substitute(expression({
- theta = eta2theta(eta, .link.theta, earg = .earg)
+ theta = eta2theta(eta, .link.theta, earg = .earg )
dl.dthetas = y - tan(theta)
- dparam.deta = dtheta.deta(theta, .link.theta, earg = .earg)
+ dparam.deta = dtheta.deta(theta, .link.theta, earg = .earg )
c(w) * dl.dthetas * dparam.deta
}), list( .link.theta = link.theta, .earg = earg ))),
weight = expression({
@@ -4593,12 +4651,12 @@ rsimplex = function(n, mu = 0.5, dispersion = 1) {
theta.init = rep(if (length( .init.theta)) .init.theta else
median(y), length = n)
- etastart = theta2eta(theta.init, .link.theta, earg = .earg)
+ etastart = theta2eta(theta.init, .link.theta, earg = .earg )
}
}), list( .link.theta = link.theta, .earg = earg,
.init.theta=init.theta ))),
linkinv = eval(substitute(function(eta, extra = NULL) {
- theta = eta2theta(eta, .link.theta, earg = .earg)
+ theta = eta2theta(eta, .link.theta, earg = .earg )
0.5 + theta/pi
}, list( .link.theta = link.theta, .earg = earg ))),
last = eval(substitute(expression({
@@ -4607,7 +4665,7 @@ rsimplex = function(n, mu = 0.5, dispersion = 1) {
misc$expected = TRUE
}), list( .link.theta = link.theta, .earg = earg ))),
loglikelihood = eval(substitute(function(mu, y, w, residuals = FALSE, eta, extra = NULL) {
- theta = eta2theta(eta, .link.theta, earg = .earg)
+ theta = eta2theta(eta, .link.theta, earg = .earg )
if (residuals) stop("loglikelihood residuals not ",
"implemented yet") else
sum(w * (log(cos(theta)) + (-0.5+theta/pi)*log(y) +
@@ -4615,9 +4673,9 @@ rsimplex = function(n, mu = 0.5, dispersion = 1) {
}, list( .link.theta = link.theta, .earg = earg ))),
vfamily = c("hypersecant.1"),
deriv = eval(substitute(expression({
- theta = eta2theta(eta, .link.theta, earg = .earg)
+ theta = eta2theta(eta, .link.theta, earg = .earg )
dl.dthetas = -tan(theta) + log(y/(1-y)) / pi
- dparam.deta = dtheta.deta(theta, .link.theta, earg = .earg)
+ dparam.deta = dtheta.deta(theta, .link.theta, earg = .earg )
c(w) * dl.dthetas * dparam.deta
}), list( .link.theta = link.theta, .earg = earg ))),
weight = expression({
@@ -5086,15 +5144,16 @@ rlgamma = function(n, location = 0, scale = 1, k = 1) {
stop("response must be a vector or a one-column matrix")
predictors.names = namesof("k", .link, earg = .earg, tag = FALSE)
if (!length(etastart)) {
- k.init = if (length( .init.k)) rep( .init.k, length.out = length(y)) else {
+ k.init = if (length( .init.k))
+ rep( .init.k, length.out = length(y)) else {
medy = median(y)
if (medy < 2) 5 else if (medy < 4) 20 else exp(0.7 * medy)
}
- etastart = theta2eta(k.init, .link, earg = .earg)
+ etastart = theta2eta(k.init, .link, earg = .earg )
}
}), list( .link = link, .earg = earg, .init.k=init.k ))),
linkinv = eval(substitute(function(eta, extra = NULL) {
- k = eta2theta(eta, .link, earg = .earg)
+ k = eta2theta(eta, .link, earg = .earg )
digamma(k)
}, list( .link = link, .earg = earg ))),
last = eval(substitute(expression({
@@ -5104,7 +5163,7 @@ rlgamma = function(n, location = 0, scale = 1, k = 1) {
}), list( .link = link, .earg = earg ))),
loglikelihood = eval(substitute(
function(mu, y, w, residuals = FALSE, eta, extra = NULL) {
- kk = eta2theta(eta, .link, earg = .earg)
+ kk = eta2theta(eta, .link, earg = .earg )
if (residuals) stop("loglikelihood residuals not ",
"implemented yet") else {
sum(w * dlgamma(x = y, location = 0, scale = 1, k=kk, log = TRUE))
@@ -5112,9 +5171,9 @@ rlgamma = function(n, location = 0, scale = 1, k = 1) {
}, list( .link = link, .earg = earg ))),
vfamily = c("lgammaff"),
deriv = eval(substitute(expression({
- k = eta2theta(eta, .link, earg = .earg)
+ k = eta2theta(eta, .link, earg = .earg )
dl.dk = y - digamma(k)
- dk.deta = dtheta.deta(k, .link, earg = .earg)
+ dk.deta = dtheta.deta(k, .link, earg = .earg )
c(w) * dl.dk * dk.deta
}), list( .link = link, .earg = earg ))),
weight = eval(substitute(expression({
@@ -5173,18 +5232,23 @@ rlgamma = function(n, location = 0, scale = 1, k = 1) {
namesof("scale", .lscale, earg = .escale, tag = FALSE),
namesof("shape", .lshape, earg = .eshape, tag = FALSE))
if (!length(etastart)) {
- k.init = if (length( .ishape)) rep( .ishape, length.out = length(y)) else {
+ k.init = if (length( .ishape))
+ rep( .ishape, length.out = length(y)) else {
rep(exp(median(y)), length.out = length(y))
}
- scale.init = if (length( .iscale)) rep( .iscale, length.out = length(y)) else {
+ scale.init = if (length( .iscale))
+ rep( .iscale, length.out = length(y)) else {
rep(sqrt(var(y) / trigamma(k.init)), length.out = length(y))
}
- loc.init = if (length( .iloc)) rep( .iloc, length.out = length(y)) else {
- rep(median(y) - scale.init * digamma(k.init), length.out = length(y))
+ loc.init = if (length( .iloc))
+ rep( .iloc, length.out = length(y)) else {
+ rep(median(y) - scale.init * digamma(k.init),
+ length.out = length(y))
}
- etastart = cbind(theta2eta(loc.init, .llocation, earg = .elocation),
- theta2eta(scale.init, .lscale, earg = .escale),
- theta2eta(k.init, .lshape, earg = .eshape))
+ etastart =
+ cbind(theta2eta(loc.init, .llocation, earg = .elocation),
+ theta2eta(scale.init, .lscale, earg = .escale),
+ theta2eta(k.init, .lshape, earg = .eshape))
}
}), list( .llocation = llocation, .lscale = lscale, .lshape = lshape,
.elocation = elocation, .escale = escale, .eshape = eshape,
@@ -5294,11 +5358,13 @@ rlgamma = function(n, location = 0, scale = 1, k = 1) {
namesof("shape", .lshape, earg = .eshape, tag = FALSE))
if (!length(etastart)) {
sdy = sqrt(var(y))
- k.init = if (length( .ishape)) rep( .ishape, length.out = length(y)) else {
+ k.init = if (length( .ishape))
+ rep( .ishape, length.out = length(y)) else {
skewness = mean((y-mean(y))^3) / sdy^3 # <0 Left Skewed
rep(-skewness, length.out = length(y))
}
- scale.init = if (length( .iscale)) rep( .iscale, length.out = length(y)) else {
+ scale.init = if (length( .iscale))
+ rep( .iscale, length.out = length(y)) else {
rep(sdy, length.out = length(y))
}
loc.init = if (length( .iloc)) rep( .iloc, length.out = length(y)) else {
@@ -5389,8 +5455,10 @@ dgengamma = function(x, scale = 1, d = 1, k = 1, log = FALSE) {
stop("bad input for argument 'k'")
N = max(length(x), length(scale), length(d), length(k))
- x = rep(x, length.out = N); scale = rep(scale, length.out = N);
- d = rep(d, length.out = N); k = rep(k, length.out = N);
+ x = rep(x, length.out = N);
+ scale = rep(scale, length.out = N);
+ d = rep(d, length.out = N);
+ k = rep(k, length.out = N);
Loglik = rep(log(0), length.out = N)
xok = x > 0
@@ -5478,14 +5546,18 @@ rgengamma = function(n, scale = 1, d = 1, k = 1) {
namesof("d", .ld, earg = .ed, tag = FALSE),
namesof("k", .lk, earg = .ek, tag = FALSE))
if (!length(etastart)) {
- b.init = if (length( .iscale)) rep( .iscale, length.out = length(y)) else {
+ b.init = if (length( .iscale))
+ rep( .iscale, length.out = length(y)) else {
rep(mean(y^2) / mean(y), length.out = length(y))
}
- k.init = if (length( .ik)) rep( .ik, length.out = length(y)) else {
+ k.init = if (length( .ik))
+ rep( .ik, length.out = length(y)) else {
rep(mean(y) / b.init, length.out = length(y))
}
- d.init = if (length( .id)) rep( .id, length.out = length(y)) else {
- rep(digamma(k.init) / mean(log(y/b.init)), length.out = length(y))
+ d.init = if (length( .id))
+ rep( .id, length.out = length(y)) else {
+ rep(digamma(k.init) / mean(log(y/b.init)),
+ length.out = length(y))
}
etastart = cbind(theta2eta(b.init, .lscale, earg = .escale),
theta2eta(d.init, .ld, earg = .ed),
@@ -5590,7 +5662,8 @@ plog = function(q, prob, log.p = FALSE) {
if (!is.Numeric(prob, positive = TRUE) || max(prob) >= 1)
stop("bad input for argument 'prob'")
N = max(length(q), length(prob))
- q = rep(q, length.out = N); prob = rep(prob, length.out = N);
+ q = rep(q, length.out = N);
+ prob = rep(prob, length.out = N);
bigno = 10
owen1965 = (q * (1 - prob) > bigno)
@@ -5707,66 +5780,70 @@ rlog = function(n, prob, Smallno=1.0e-6) {
logff = function(link = "logit", earg = list(), init.c = NULL)
{
- if (length(init.c) &&
- (!is.Numeric(init.c, positive = TRUE) || max(init.c) >= 1))
- stop("init.c must be in (0,1)")
- if (mode(link) != "character" && mode(link) != "name")
- link = as.character(substitute(link))
- if (!is.list(earg)) earg = list()
+ if (length(init.c) &&
+ (!is.Numeric(init.c, positive = TRUE) || max(init.c) >= 1))
+ stop("init.c must be in (0,1)")
+ if (mode(link) != "character" && mode(link) != "name")
+ link = as.character(substitute(link))
+ if (!is.list(earg))
+ earg = list()
- new("vglmff",
- blurb = c("Logarithmic distribution f(y) = a * c^y / y, y = 1,2,3,...,\n",
- " 0 < c < 1, a = -1 / log(1-c) \n\n",
- "Link: ", namesof("c", link, earg = earg), "\n", "\n",
- "Mean: a * c / (1 - c)", "\n"),
- initialize = eval(substitute(expression({
- if (ncol(cbind(y)) != 1)
- stop("response must be a vector or a one-column matrix")
- predictors.names = namesof("c", .link, earg = .earg, tag = FALSE)
- if (!length(etastart)) {
- llfun = function(cc, y, w) {
- a = -1 / log1p(-cc)
- sum(w * (log(a) + y * log(cc) - log(y)))
- }
- c.init = if (length( .init.c )) .init.c else
- getInitVals(gvals = seq(0.05, 0.95, length.out = 9),
- llfun = llfun, y = y, w = w)
- c.init = rep(c.init, length=length(y))
- etastart = theta2eta(c.init, .link, earg = .earg)
- }
- }), list( .link = link, .earg = earg, .init.c=init.c ))),
- linkinv = eval(substitute(function(eta, extra = NULL) {
- cc = eta2theta(eta, .link, earg = .earg)
- a = -1 / log1p(-cc)
- a * cc / (1-cc)
- }, list( .link = link, .earg = earg ))),
- last = eval(substitute(expression({
- misc$link = c(c= .link)
- misc$earg = list(c= .earg)
- misc$expected = TRUE
- }), list( .link = link, .earg = earg ))),
- loglikelihood = eval(substitute(
- function(mu, y, w, residuals = FALSE, eta, extra = NULL) {
- cc = eta2theta(eta, .link, earg = .earg)
- a = -1 / log1p(-cc)
- if (residuals) stop("loglikelihood residuals ",
- "not implemented yet") else {
- sum(w * dlog(x = y, prob=-expm1(-1/a), log = TRUE))
- }
- }, list( .link = link, .earg = earg ))),
- vfamily = c("logff"),
- deriv = eval(substitute(expression({
- cc = eta2theta(eta, .link, earg = .earg)
+ new("vglmff",
+ blurb = c("Logarithmic distribution f(y) = a * c^y / y, ",
+ "y = 1,2,3,...,\n",
+ " 0 < c < 1, a = -1 / log(1-c) \n\n",
+ "Link: ", namesof("c", link, earg = earg), "\n", "\n",
+ "Mean: a * c / (1 - c)", "\n"),
+ initialize = eval(substitute(expression({
+ if (ncol(cbind(y)) != 1)
+ stop("response must be a vector or a one-column matrix")
+
+ predictors.names = namesof("c", .link, earg = .earg, tag = FALSE)
+
+ if (!length(etastart)) {
+ llfun = function(cc, y, w) {
a = -1 / log1p(-cc)
- dl.dc = 1 / ((1-cc) * log1p(-cc)) + y / cc
- dc.deta = dtheta.deta(cc, .link, earg = .earg)
- c(w) * dl.dc * dc.deta
- }), list( .link = link, .earg = earg ))),
- weight = eval(substitute(expression({
- ed2l.dc2 = a * (1 - a * cc) / (cc * (1-cc)^2)
- wz = c(w) * dc.deta^2 * ed2l.dc2
- wz
- }), list( .link = link, .earg = earg ))))
+ sum(w * (log(a) + y * log(cc) - log(y)))
+ }
+ c.init = if (length( .init.c )) .init.c else
+ getInitVals(gvals = seq(0.05, 0.95, length.out = 9),
+ llfun = llfun, y = y, w = w)
+ c.init = rep(c.init, length = length(y))
+ etastart = theta2eta(c.init, .link, earg = .earg )
+ }
+ }), list( .link = link, .earg = earg, .init.c = init.c ))),
+ linkinv = eval(substitute(function(eta, extra = NULL) {
+ cc = eta2theta(eta, .link, earg = .earg )
+ a = -1 / log1p(-cc)
+ a * cc / (1-cc)
+ }, list( .link = link, .earg = earg ))),
+ last = eval(substitute(expression({
+ misc$link = c(c = .link )
+ misc$earg = list(c = .earg )
+ misc$expected = TRUE
+ }), list( .link = link, .earg = earg ))),
+ loglikelihood = eval(substitute(
+ function(mu, y, w, residuals = FALSE, eta, extra = NULL) {
+ cc = eta2theta(eta, .link, earg = .earg )
+ a = -1 / log1p(-cc)
+ if (residuals) stop("loglikelihood residuals ",
+ "not implemented yet") else {
+ sum(w * dlog(x = y, prob = -expm1(-1/a), log = TRUE))
+ }
+ }, list( .link = link, .earg = earg ))),
+ vfamily = c("logff"),
+ deriv = eval(substitute(expression({
+ cc = eta2theta(eta, .link, earg = .earg )
+ a = -1 / log1p(-cc)
+ dl.dc = 1 / ((1 - cc) * log1p(-cc)) + y / cc
+ dc.deta = dtheta.deta(cc, .link, earg = .earg )
+ c(w) * dl.dc * dc.deta
+ }), list( .link = link, .earg = earg ))),
+ weight = eval(substitute(expression({
+ ed2l.dc2 = a * (1 - a * cc) / (cc * (1-cc)^2)
+ wz = c(w) * dc.deta^2 * ed2l.dc2
+ wz
+ }), list( .link = link, .earg = earg ))))
}
@@ -5818,19 +5895,19 @@ rlog = function(n, prob, Smallno=1.0e-6) {
}
gamma.init = if (length( .igamma)) .igamma else
median(y - delta.init) # = 1/median(1/(y-delta.init))
- gamma.init = rep(gamma.init, length=length(y))
- etastart = cbind(theta2eta(gamma.init, .link.gamma, earg = .earg),
+ gamma.init = rep(gamma.init, length = length(y))
+ etastart = cbind(theta2eta(gamma.init, .link.gamma, earg = .earg ),
if ( .delta.known) NULL else delta.init)
}
}), list( .link.gamma = link.gamma, .earg = earg,
- .delta.known=delta.known,
- .delta=delta,
- .idelta=idelta,
- .igamma=igamma ))),
+ .delta.known = delta.known,
+ .delta = delta,
+ .idelta = idelta,
+ .igamma = igamma ))),
linkinv = eval(substitute(function(eta, extra = NULL) {
eta = as.matrix(eta)
- mygamma = eta2theta(eta[, 1], .link.gamma, earg = .earg)
+ mygamma = eta2theta(eta[, 1], .link.gamma, earg = .earg )
delta = if ( .delta.known) .delta else eta[, 2]
@@ -5841,7 +5918,7 @@ rlog = function(n, prob, Smallno=1.0e-6) {
last = eval(substitute(expression({
misc$link = if ( .delta.known) NULL else c(delta = "identity")
misc$link = c(gamma = .link.gamma, misc$link)
- misc$earg = if ( .delta.known) list(gamma = .earg) else
+ misc$earg = if ( .delta.known) list(gamma = .earg ) else
list(gamma = .earg, delta = list())
if ( .delta.known)
misc$delta = .delta
@@ -5851,7 +5928,7 @@ rlog = function(n, prob, Smallno=1.0e-6) {
loglikelihood = eval(substitute(
function(mu, y, w, residuals = FALSE, eta, extra = NULL) {
eta = as.matrix(eta)
- mygamma = eta2theta(eta[, 1], .link.gamma, earg = .earg)
+ mygamma = eta2theta(eta[, 1], .link.gamma, earg = .earg )
delta = if ( .delta.known) .delta else eta[, 2]
if (residuals) stop("loglikelihood residuals ",
"not implemented yet") else
@@ -5862,12 +5939,12 @@ rlog = function(n, prob, Smallno=1.0e-6) {
vfamily = c("levy"),
deriv = eval(substitute(expression({
eta = as.matrix(eta)
- mygamma = eta2theta(eta[, 1], .link.gamma, earg = .earg)
+ mygamma = eta2theta(eta[, 1], .link.gamma, earg = .earg )
delta = if ( .delta.known) .delta else eta[, 2]
if (! .delta.known)
dl.ddelta = (3 - mygamma / (y-delta)) / (2 * (y-delta))
dl.dgamma = 0.5 * (1 / mygamma - 1 / (y-delta))
- dgamma.deta = dtheta.deta(mygamma, .link.gamma, earg = .earg)
+ dgamma.deta = dtheta.deta(mygamma, .link.gamma, earg = .earg )
c(w) * cbind(dl.dgamma * dgamma.deta,
if ( .delta.known) NULL else dl.ddelta)
}), list( .link.gamma = link.gamma, .earg = earg,
@@ -6116,16 +6193,27 @@ rlino = function(n, shape1, shape2, lambda = 1) {
qvec = c( .25, .5, .75) # Arbitrary; could be made an argument
ishape3.q = if (length( .ishape3.q)) .ishape3.q else 1
xvec = log( (1-qvec)^(-1/ ishape3.q ) - 1 )
- fit0 = lsfit(x = xvec, y=log(quantile(y, qvec )))
+ fit0 = lsfit(x = xvec, y = log(quantile(y, qvec )))
}
if (!length(etastart)) {
- aa = rep(if (length( .ishape1.a)) .ishape1.a else 1/fit0$coef[2],
- length = n)
- scale = rep(if (length( .iscale )) .iscale else
- exp(fit0$coef[1]), length = n)
- qq = rep(if (length( .ishape3.q )) .ishape3.q else 1.0, leng = n)
- parg = rep(if (length( .ishape2.p )) .ishape2.p else 1.0, leng = n)
+ aa = rep(if (length( .ishape1.a )) .ishape1.a else
+ abs(1 / fit0$coef[2]),
+ length.out = n)
+ scale = rep(if (length( .iscale )) .iscale else
+ exp(fit0$coef[1]), length = n)
+ qq = rep(if (length( .ishape3.q )) .ishape3.q else 1.0,
+ length.out = n)
+ parg = rep(if (length( .ishape2.p )) .ishape2.p else 1.0,
+ length.out = n)
+
+
+ outOfRange = (qq - 1/aa <= 0)
+ qq[outOfRange] = 1 / aa[outOfRange] + 1
+ outOfRange = (parg + 1/aa <= 0)
+ parg[outOfRange] = 1 / aa[outOfRange] + 1
+
+
etastart = cbind(theta2eta(aa, .lshape1.a, earg = .eshape1.a),
theta2eta(scale, .lscale, earg = .escale),
theta2eta(parg, .lshape2.p, earg = .eshape2.p),
@@ -6284,11 +6372,22 @@ rinvparalogistic <- function(n, shape1.a, scale = 1)
qsinmad <- function(p, shape1.a, scale = 1, shape3.q) {
bad = (p < 0) | (p > 1)
ans = NA * p
- shape1.a = rep(shape1.a, length.out = length(p))[!bad]
- scale = rep(scale, length.out = length(p))[!bad]
- q = rep(shape3.q, length.out = length(p))[!bad]
- xx = p[!bad]
- ans[!bad] = scale * ((1 - xx)^(-1/q) - 1)^(1/shape1.a)
+
+ LLL = max(length(p), length(shape1.a), length(scale), length(shape3.q))
+ if (length(p) != LLL)
+ p <- rep(p, length.out = LLL)
+ if (length(shape1.a) != LLL)
+ shape1.a <- rep(shape1.a, length.out = LLL)
+ if (length(scale) != LLL)
+ scale <- rep(scale, length.out = LLL)
+ if (length(shape3.q) != LLL)
+ shape3.q <- rep(shape3.q, length.out = LLL)
+
+ Shape1.a = shape1.a[!bad]
+ Scale = scale[!bad]
+ Shape3.q = shape3.q[!bad]
+ QQ = p[!bad]
+ ans[!bad] = Scale * ((1 - QQ)^(-1/Shape3.q) - 1)^(1/Shape1.a)
ans
}
@@ -6397,6 +6496,9 @@ pdagum <- function(q, shape1.a, scale = 1, shape2.p) {
ans <- 0 * q
ans[!notpos] <- (1 + (QQ/Scale)^(-Shape1.a))^(-Shape2.p)
+
+ ans[q == -Inf] <- 0
+
ans
}
@@ -6434,15 +6536,15 @@ dsinmad <- function(x, shape1.a, scale = 1, shape3.q, log = FALSE) {
dlomax <- function(x, scale = 1, shape3.q, log = FALSE)
- dsinmad(x, shape1.a = 1, scale, shape3.q, log = log)
+ dsinmad(x, shape1.a = 1, scale, shape3.q, log = log)
dfisk <- function(x, shape1.a, scale = 1, log = FALSE)
- dsinmad(x, shape1.a, scale, shape3.q = 1, log = log)
+ dsinmad(x, shape1.a, scale, shape3.q = 1, log = log)
dparalogistic <- function(x, shape1.a, scale = 1, log = FALSE)
- dsinmad(x, shape1.a, scale, shape1.a, log = log)
+ dsinmad(x, shape1.a, scale, shape1.a, log = log)
@@ -6528,7 +6630,7 @@ dinvparalogistic <- function(x, shape1.a, scale = 1, log = FALSE)
qvec = c( .25, .5, .75) # Arbitrary; could be made an argument
ishape3.q = if (length( .ishape3.q)) .ishape3.q else 1
xvec = log( (1-qvec)^(-1/ ishape3.q ) - 1 )
- fit0 = lsfit(x = xvec, y=log(quantile(y, qvec )))
+ fit0 = lsfit(x = xvec, y = log(quantile(y, qvec )))
}
@@ -6591,7 +6693,7 @@ dinvparalogistic <- function(x, shape1.a, scale = 1, log = FALSE)
aa = eta2theta(eta[, 1], .lshape1.a, earg = .eshape1.a)
scale = eta2theta(eta[, 2], .lscale, earg = .escale)
parg = 1
- qq = eta2theta(eta[, 3], .lshape3.q, earg = .earg)
+ qq = eta2theta(eta[, 3], .lshape3.q, earg = .earg )
if (residuals) stop("loglikelihood residuals ",
"not implemented yet") else {
sum(w * dsinmad(x = y, shape1.a = aa, scale = scale,
@@ -6705,18 +6807,30 @@ dinvparalogistic <- function(x, shape1.a, scale = 1, log = FALSE)
qvec = c( .25, .5, .75) # Arbitrary; could be made an argument
ishape2.p = if (length( .ishape2.p)) .ishape2.p else 1
xvec = log( qvec^(-1/ ishape2.p ) - 1 )
- fit0 = lsfit(x = xvec, y=log(quantile(y, qvec )))
+ fit0 = lsfit(x = xvec, y = log(quantile(y, qvec )))
}
if (!length(etastart)) {
- parg = rep(if (length( .ishape2.p)) .ishape2.p else 1.0, length = n)
- aa = rep(if (length( .ishape1.a)) .ishape1.a else -1/fit0$coef[2],
- length = n)
- scale = rep(if (length( .iscale )) .iscale else
- exp(fit0$coef[1]), length = n)
- etastart = cbind(theta2eta(aa, .lshape1.a, earg = .eshape1.a),
- theta2eta(scale, .lscale, earg = .escale),
- theta2eta(parg, .lshape2.p, earg = .eshape2.p))
+ parg = rep(if (length( .ishape2.p )) .ishape2.p else 1.0,
+ length.out = n)
+ aa = rep(if (length( .ishape1.a )) .ishape1.a else
+ -1/fit0$coef[2],
+ length.out = n)
+ scale = rep(if (length( .iscale )) .iscale else
+ exp(fit0$coef[1]),
+ length.out = n)
+
+
+ outOfRange = (parg + 1/aa <= 0)
+ parg[outOfRange] = 1 / aa[outOfRange] + 1
+
+
+
+
+
+ etastart = cbind(theta2eta(aa, .lshape1.a, earg = .eshape1.a),
+ theta2eta(scale, .lscale, earg = .escale),
+ theta2eta(parg, .lshape2.p, earg = .eshape2.p))
}
}), list( .lshape1.a = lshape1.a, .lscale = lscale,
.lshape2.p = lshape2.p,
@@ -6747,67 +6861,69 @@ dinvparalogistic <- function(x, shape1.a, scale = 1, log = FALSE)
misc$earg = list(shape1.a = .eshape1.a, scale = .escale, p = .eshape2.p )
}), list( .lshape1.a = lshape1.a, .lscale = lscale, .lshape2.p = lshape2.p,
.eshape1.a = eshape1.a, .escale = escale, .eshape2.p = eshape2.p ))),
- loglikelihood = eval(substitute(
- function(mu, y, w, residuals = FALSE, eta, extra = NULL) {
- aa = eta2theta(eta[, 1], .lshape1.a, earg = .eshape1.a)
- scale = eta2theta(eta[, 2], .lscale, earg = .escale)
- parg = eta2theta(eta[, 3], .lshape2.p, earg = .eshape2.p)
- qq = 1
- if (residuals) stop("loglikelihood residuals ",
- "not implemented yet") else {
- sum(w * ddagum(x = y, shape1.a = aa, scale = scale,
- shape2.p = parg, log = TRUE))
- }
- }, list( .lshape1.a = lshape1.a, .lscale = lscale, .lshape2.p = lshape2.p,
- .eshape1.a = eshape1.a, .escale = escale, .eshape2.p = eshape2.p ))),
- vfamily = c("dagum"),
- deriv = eval(substitute(expression({
- aa = eta2theta(eta[, 1], .lshape1.a, earg = .eshape1.a)
- scale = eta2theta(eta[, 2], .lscale, earg = .escale)
- parg = eta2theta(eta[, 3], .lshape2.p, earg = .eshape2.p)
- qq = 1
+ loglikelihood = eval(substitute(
+ function(mu, y, w, residuals = FALSE, eta, extra = NULL) {
+ aa = eta2theta(eta[, 1], .lshape1.a, earg = .eshape1.a)
+ Scale = eta2theta(eta[, 2], .lscale, earg = .escale)
+ parg = eta2theta(eta[, 3], .lshape2.p, earg = .eshape2.p)
+ qq = 1
+ if (residuals) stop("loglikelihood residuals ",
+ "not implemented yet") else {
+ sum(w * ddagum(x = y, shape1.a = aa, scale = Scale,
+ shape2.p = parg, log = TRUE))
+ }
+ }, list( .lshape1.a = lshape1.a, .lscale = lscale, .lshape2.p = lshape2.p,
+ .eshape1.a = eshape1.a, .escale = escale, .eshape2.p = eshape2.p ))),
+ vfamily = c("dagum"),
+ deriv = eval(substitute(expression({
+ aa = eta2theta(eta[, 1], .lshape1.a, earg = .eshape1.a)
+ Scale = eta2theta(eta[, 2], .lscale, earg = .escale)
+ parg = eta2theta(eta[, 3], .lshape2.p, earg = .eshape2.p)
+ qq = 1
- temp1 = log(y/scale)
- temp2 = (y/scale)^aa
- temp3a = digamma(parg)
- temp3b = digamma(qq)
+ temp1 = log(y / Scale)
+ temp2 = (y / Scale)^aa
+ temp3a = digamma(parg)
+ temp3b = digamma(qq)
- 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, .lshape1.a, earg = .eshape1.a)
- dscale.deta = dtheta.deta(scale, .lscale, earg = .escale)
- dp.deta = dtheta.deta(parg, .lshape2.p, earg = .eshape2.p)
- c(w) * cbind( dl.da * da.deta,
- dl.dscale * dscale.deta,
- dl.dp * dp.deta )
- }), list( .lshape1.a = lshape1.a, .lscale = lscale,
- .eshape1.a = eshape1.a, .escale = escale,
- .eshape2.p = eshape2.p,
- .lshape2.p = lshape2.p ))),
- weight = eval(substitute(expression({
- 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.dap= -(qq * (temp3a -temp3b) -1) / (aa*(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(2,2,M)] = ed2l.dscale * dscale.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
- wz = c(w) * wz
- wz
- }), list( .lshape1.a = lshape1.a, .lscale = lscale,
- .eshape1.a = eshape1.a, .escale = escale,
- .eshape2.p = eshape2.p,
- .lshape2.p = lshape2.p ))))
+ 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, .lshape1.a, earg = .eshape1.a)
+ dscale.deta = dtheta.deta(Scale, .lscale, earg = .escale)
+ dp.deta = dtheta.deta(parg, .lshape2.p, earg = .eshape2.p)
+
+ c(w) * cbind( dl.da * da.deta,
+ dl.dscale * dscale.deta,
+ dl.dp * dp.deta )
+ }), list( .lshape1.a = lshape1.a, .lscale = lscale,
+ .eshape1.a = eshape1.a, .escale = escale,
+ .eshape2.p = eshape2.p,
+ .lshape2.p = lshape2.p ))),
+ weight = eval(substitute(expression({
+ 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.dap= -(qq * (temp3a -temp3b) -1) / (aa*(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(2,2,M)] = ed2l.dscale * dscale.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
+ wz = c(w) * wz
+ wz
+ }), list( .lshape1.a = lshape1.a, .lscale = lscale,
+ .eshape1.a = eshape1.a, .escale = escale,
+ .eshape2.p = eshape2.p,
+ .lshape2.p = lshape2.p ))))
}
@@ -6856,17 +6972,31 @@ dinvparalogistic <- function(x, shape1.a, scale = 1, log = FALSE)
qvec = c( .25, .5, .75) # Arbitrary; could be made an argument
ishape3.q = if (length( .ishape3.q)) .ishape3.q else 1
xvec = log( (1-qvec)^(-1/ ishape3.q ) - 1 )
- fit0 = lsfit(x = xvec, y=log(quantile(y, qvec )))
+ fit0 = lsfit(x = xvec, y = log(quantile(y, qvec )))
}
if (!length(etastart)) {
scale = rep(if (length( .iscale )) .iscale else
- exp(fit0$coef[1]), length = n)
- qq = rep(if (length( .ishape3.q)) .ishape3.q else 1.0, length = n)
- parg = rep(if (length( .ishape2.p)) .ishape2.p else 1.0, length = n)
- etastart = cbind(theta2eta(scale, .lscale, earg = .escale),
- theta2eta(parg, .lshape2.p, earg = .eshape2.p),
- theta2eta(qq, .lshape3.q, earg = .eshape3.q))
+ exp(fit0$coef[1]),
+ length.out = n)
+ qq = rep(if (length( .ishape3.q)) .ishape3.q else 1.0,
+ length.out = n)
+ parg = rep(if (length( .ishape2.p)) .ishape2.p else 1.0,
+ length.out = n)
+
+
+
+ aa = 1
+ outOfRange = (parg + 1/aa <= 0)
+ parg[outOfRange] = 1 / aa[outOfRange] + 1
+ outOfRange = (qq - 1/aa <= 0)
+ qq[outOfRange] = 1 / aa + 1
+
+
+ etastart =
+ cbind(theta2eta(scale, .lscale, earg = .escale),
+ theta2eta(parg, .lshape2.p, earg = .eshape2.p),
+ theta2eta(qq, .lshape3.q, earg = .eshape3.q))
}
}), list( .lscale = lscale,
.escale = escale,
@@ -7008,13 +7138,23 @@ dinvparalogistic <- function(x, shape1.a, scale = 1, log = FALSE)
qvec = c( .25, .5, .75) # Arbitrary; could be made an argument
ishape3.q = if (length( .ishape3.q)) .ishape3.q else 1
xvec = log( (1-qvec)^(-1/ ishape3.q ) - 1 )
- fit0 = lsfit(x = xvec, y=log(quantile(y, qvec )))
+ fit0 = lsfit(x = xvec, y = log(quantile(y, qvec )))
}
if (!length(etastart)) {
- qq = rep(if (length( .ishape3.q)) .ishape3.q else 1.0, length = n)
+ qq = rep(if (length( .ishape3.q)) .ishape3.q else 1.0,
+ length.out = n)
scale = rep(if (length( .iscale )) .iscale else
- exp(fit0$coef[1]), length = n)
+ exp(fit0$coef[1]),
+ length.out = n)
+
+
+ aa = 1
+ outOfRange = (qq - 1/aa <= 0)
+ qq[outOfRange] = 1 / aa + 1
+
+
+
etastart = cbind(theta2eta(scale, .lscale, earg = .escale),
theta2eta(qq, .lshape3.q, earg = .eshape3.q))
}
@@ -7089,6 +7229,7 @@ dinvparalogistic <- function(x, shape1.a, scale = 1, log = FALSE)
}
+
fisk = function(lshape1.a = "loge",
lscale = "loge",
eshape1.a = list(), escale = list(),
@@ -7128,16 +7269,29 @@ dinvparalogistic <- function(x, shape1.a, scale = 1, log = FALSE)
if (!length( .iscale )) {
qvec = c( .25, .5, .75) # Arbitrary; could be made an argument
xvec = log( 1/qvec - 1 )
- fit0 = lsfit(x = xvec, y=log(quantile(y, qvec )))
+ fit0 = lsfit(x = xvec, y = log(quantile(y, qvec )))
}
if (!length(etastart)) {
- aa = rep(if (length( .ishape1.a)) .ishape1.a else -1/fit0$coef[2],
- length = n)
+ aa = rep(if (length( .ishape1.a)) .ishape1.a else
+ abs(-1 / fit0$coef[2]),
+ length.out = n)
scale = rep(if (length( .iscale )) .iscale else
- exp(fit0$coef[1]), length = n)
- etastart = cbind(theta2eta(aa, .lshape1.a, earg = .eshape1.a),
- theta2eta(scale, .lscale, earg = .escale))
+ exp(fit0$coef[1]),
+ length.out = n)
+
+
+ parg = 1
+ qq = 1
+ outOfRange = (parg + 1/aa <= 0)
+ parg[outOfRange] = 1 / aa[outOfRange] + 1
+ outOfRange = (qq - 1/aa <= 0)
+ qq[outOfRange] = 1 / aa + 1
+
+
+
+ etastart = cbind(theta2eta(aa, .lshape1.a, earg = .eshape1.a),
+ theta2eta(scale, .lscale, earg = .escale))
}
}), list( .lshape1.a = lshape1.a, .lscale = lscale,
.eshape1.a = eshape1.a, .escale = escale,
@@ -7164,7 +7318,7 @@ dinvparalogistic <- function(x, shape1.a, scale = 1, log = FALSE)
.eshape1.a = eshape1.a, .escale = escale ))),
loglikelihood = eval(substitute(
function(mu, y, w, residuals = FALSE, eta, extra = NULL) {
- aa = eta2theta(eta[, 1], .lshape1.a, earg = .earg)
+ aa = eta2theta(eta[, 1], .lshape1.a, earg = .earg )
scale = eta2theta(eta[, 2], .lscale, earg = .escale)
parg = qq = 1
if (residuals) stop("loglikelihood residuals ",
@@ -7251,21 +7405,25 @@ dinvparalogistic <- function(x, shape1.a, scale = 1, log = FALSE)
qvec = c( .25, .5, .75) # Arbitrary; could be made an argument
ishape2.p = if (length( .ishape2.p)) .ishape2.p else 1
xvec = log( qvec^(-1/ ishape2.p ) - 1 )
- fit0 = lsfit(x = xvec, y=log(quantile(y, qvec )))
+ fit0 = lsfit(x = xvec, y = log(quantile(y, qvec )))
}
if (!length(etastart)) {
scale = rep(if (length( .iscale )) .iscale else
- exp(fit0$coef[1]), length = n)
- parg = rep(if (length( .ishape2.p)) .ishape2.p else 1.0, length = n)
- etastart = cbind(theta2eta(scale, .lscale, earg = .escale),
- theta2eta(parg, .lshape2.p, earg = .eshape2.p))
+ exp(fit0$coef[1]),
+ length.out = n)
+ parg = rep(if (length( .ishape2.p)) .ishape2.p else 1.0,
+ length.out = n)
+
+
+
+
+ etastart =
+ cbind(theta2eta(scale, .lscale, earg = .escale),
+ theta2eta(parg, .lshape2.p, earg = .eshape2.p))
}
- }), list( .lscale = lscale,
- .lshape2.p = lshape2.p,
- .escale = escale,
- .eshape2.p = eshape2.p,
- .iscale = iscale,
- .ishape2.p = ishape2.p ))),
+ }), list( .lscale = lscale, .lshape2.p = lshape2.p,
+ .escale = escale, .eshape2.p = eshape2.p,
+ .iscale = iscale, .ishape2.p = ishape2.p ))),
linkinv = eval(substitute(function(eta, extra = NULL) {
Scale = eta2theta(eta[, 1], .lscale, earg = .escale)
parg = eta2theta(eta[, 2], .lshape2.p, earg = .eshape2.p)
@@ -7306,8 +7464,10 @@ dinvparalogistic <- function(x, shape1.a, scale = 1, log = FALSE)
dl.dscale = (aa/scale) * (-parg + (parg+qq) / (1+1/temp2))
dl.dp = aa * temp1 + digamma(parg + qq) - digamma(parg) - log1p(temp2)
+
dscale.deta = dtheta.deta(scale, .lscale, earg = .escale)
dp.deta = dtheta.deta(parg, .lshape2.p, earg = .eshape2.p)
+
c(w) * cbind( dl.dscale * dscale.deta,
dl.dp * dp.deta )
}), list( .lscale = lscale, .lshape2.p = lshape2.p,
@@ -7373,12 +7533,27 @@ dinvparalogistic <- function(x, shape1.a, scale = 1, log = FALSE)
}
if (!length(etastart)) {
- aa = rep(if (length( .ishape1.a)) .ishape1.a else 1/fit0$coef[2],
- length = n)
+ aa = rep(if (length( .ishape1.a)) .ishape1.a else
+ abs(1/fit0$coef[2]),
+ length.out = n)
scale = rep(if (length( .iscale )) .iscale else
- exp(fit0$coef[1]), length = n)
- etastart = cbind(theta2eta(aa, .lshape1.a, earg = .eshape1.a),
- theta2eta(scale, .lscale, earg = .escale))
+ exp(fit0$coef[1]),
+ length.out = n)
+
+
+
+
+ parg = 1
+ qq = aa
+ outOfRange = (parg + 1/aa <= 0)
+ parg[outOfRange] = 1 / aa[outOfRange] + 1
+ outOfRange = (qq - 1/aa <= 0)
+ aa[outOfRange] =
+ qq[outOfRange] = 2 # Need aa > 1, where aa == qq
+
+
+ etastart = cbind(theta2eta(aa, .lshape1.a, earg = .eshape1.a),
+ theta2eta(scale, .lscale, earg = .escale))
}
}), list( .lshape1.a = lshape1.a, .lscale = lscale,
.eshape1.a = eshape1.a, .escale = escale,
@@ -7431,8 +7606,10 @@ dinvparalogistic <- function(x, shape1.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))
+
da.deta = dtheta.deta(aa, .lshape1.a, earg = .eshape1.a)
dscale.deta = dtheta.deta(scale, .lscale, earg = .escale)
+
c(w) * cbind( dl.da * da.deta,
dl.dscale * dscale.deta)
}), list( .lshape1.a = lshape1.a, .lscale = lscale,
@@ -7504,6 +7681,21 @@ dinvparalogistic <- function(x, shape1.a, scale = 1, log = FALSE)
length = n)
scale = rep(if (length( .iscale )) .iscale else
exp(fit0$coef[1]), length = n)
+
+
+
+
+
+ parg = aa
+ qq = 1
+ outOfRange = (parg + 1/aa <= 0)
+ parg[outOfRange] =
+ aa[outOfRange] = 2
+ outOfRange = (qq - 1/aa <= 0)
+ qq[outOfRange] = 1 / aa[outOfRange] + 1
+
+
+
etastart = cbind(theta2eta(aa, .lshape1.a, earg = .eshape1.a),
theta2eta(scale, .lscale, earg = .escale))
}
@@ -7557,9 +7749,11 @@ dinvparalogistic <- function(x, shape1.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))
- da.deta = dtheta.deta(aa, .lshape1.a, earg = .eshape1.a)
+
+ da.deta = dtheta.deta(aa, .lshape1.a, earg = .eshape1.a)
dscale.deta = dtheta.deta(scale, .lscale, earg = .escale)
- c(w) * cbind( dl.da * da.deta,
+
+ c(w) * cbind( dl.da * da.deta,
dl.dscale * dscale.deta )
}), list( .lshape1.a = lshape1.a, .lscale = lscale,
.eshape1.a = eshape1.a, .escale = escale ))),
@@ -7570,8 +7764,8 @@ dinvparalogistic <- function(x, shape1.a, scale = 1, log = FALSE)
(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.dascale = (parg - qq - parg*qq*(temp3a -temp3b)) /
- (scale*(1 + parg+qq))
+ ed2l.dascale = (parg - qq -
+ parg*qq*(temp3a -temp3b)) / (scale*(1 + 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
@@ -7745,8 +7939,8 @@ warning("2/4/04; doesn't work, possibly because first derivs are ",
namesof("shape2", .link, earg = .earg, short = TRUE))
if (is.numeric( .i1) && is.numeric( .i2)) {
vec = c( .i1, .i2)
- vec = c(theta2eta(vec[1], .link, earg = .earg),
- theta2eta(vec[2], .link, earg = .earg))
+ vec = c(theta2eta(vec[1], .link, earg = .earg ),
+ theta2eta(vec[2], .link, earg = .earg ))
etastart = matrix(vec, n, 2, byrow= TRUE)
}
if (!length(etastart)) {
@@ -7754,22 +7948,22 @@ warning("2/4/04; doesn't work, possibly because first derivs are ",
rep( .i1, length.out = n) else rep(1, length.out = n)
init2 = if (length( .i2))
rep( .i2, length.out = n) else 1 + init1 / (y + 0.1)
- etastart = matrix(theta2eta(c(init1, init2), .link, earg = .earg),
+ etastart = matrix(theta2eta(c(init1, init2), .link, earg = .earg ),
n, 2, byrow = TRUE)
}
}), list( .link = link, .earg = earg, .i1=i1, .i2=i2 ))),
linkinv = eval(substitute(function(eta, extra = NULL) {
- shapes = eta2theta(eta, .link, earg = .earg)
+ shapes = eta2theta(eta, .link, earg = .earg )
ifelse(shapes[, 2] > 1, shapes[, 1] / (shapes[, 2]-1), NA)
}, list( .link = link, .earg = earg ))),
last = eval(substitute(expression({
misc$link = c(shape1 = .link, shape2 = .link)
- misc$earg = list(shape1 = .earg, shape2 = .earg)
+ misc$earg = list(shape1 = .earg, shape2 = .earg )
}), list( .link = link, .earg = earg ))),
loglikelihood = eval(substitute(
function(mu, y, w, residuals = FALSE, eta, extra = NULL){
- shapes = eta2theta(eta, .link, earg = .earg)
+ shapes = eta2theta(eta, .link, earg = .earg )
if (residuals) stop("loglikelihood residuals ",
"not implemented yet") else {
sum(w *((shapes[, 1]-1) * log(y) -
@@ -7779,8 +7973,8 @@ warning("2/4/04; doesn't work, possibly because first derivs are ",
}, list( .link = link, .earg = earg ))),
vfamily = "betaprime",
deriv = eval(substitute(expression({
- shapes = eta2theta(eta, .link, earg = .earg)
- dshapes.deta = dtheta.deta(shapes, .link, earg = .earg)
+ shapes = eta2theta(eta, .link, earg = .earg )
+ dshapes.deta = dtheta.deta(shapes, .link, earg = .earg )
dl.dshapes = cbind(log(y) - log1p(y) - digamma(shapes[, 1]) +
digamma(shapes[, 1]+shapes[, 2]),
- log1p(y) - digamma(shapes[, 2]) +
@@ -7842,7 +8036,9 @@ qmaxwell = function(p, a) {
if (!is.Numeric(p, positive = 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, length.out = N); a = rep(a, length.out = N)
+ N = max(length(p), length(a));
+ p = rep(p, length.out = N);
+ a = rep(a, length.out = N)
sqrt(2 * qgamma(p = p, 1.5) / a)
}
@@ -7865,29 +8061,29 @@ qmaxwell = function(p, a) {
predictors.names = namesof("a", .link, earg = .earg, tag = FALSE)
if (!length(etastart)) {
a.init = rep(8 / (pi*(y+0.1)^2), length = length(y))
- etastart = theta2eta(a.init, .link, earg = .earg)
+ etastart = theta2eta(a.init, .link, earg = .earg )
}
}), list( .link = link, .earg = earg ))),
linkinv = eval(substitute(function(eta, extra = NULL) {
- a = eta2theta(eta, .link, earg = .earg)
+ 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$earg = list(a = .earg)
+ misc$earg = list(a = .earg )
}), list( .link = link, .earg = earg ))),
loglikelihood = eval(substitute(
function(mu, y, w, residuals = FALSE, eta, extra = NULL) {
- aa = eta2theta(eta, .link, earg = .earg)
+ aa = eta2theta(eta, .link, earg = .earg )
if (residuals) stop("loglikelihood residuals ",
"not implemented yet") else
sum(w * dmaxwell(x = y, a = aa, log = TRUE))
}, list( .link = link, .earg = earg ))),
vfamily = c("maxwell"),
deriv = eval(substitute(expression({
- a = eta2theta(eta, .link, earg = .earg)
+ a = eta2theta(eta, .link, earg = .earg )
dl.da = 1.5 / a - 0.5 * y^2
- da.deta = dtheta.deta(a, .link, earg = .earg)
+ da.deta = dtheta.deta(a, .link, earg = .earg )
c(w) * dl.da * da.deta
}), list( .link = link, .earg = earg ))),
weight = eval(substitute(expression({
@@ -7965,7 +8161,8 @@ qnaka = function(p, shape, scale = 1, ...) {
rnaka = function(n, shape, scale = 1, Smallno=1.0e-6) {
use.n = if ((length.n <- length(n)) > 1) length.n else
- if (!is.Numeric(n, integer.valued = TRUE, allowable.length = 1, positive = TRUE))
+ if (!is.Numeric(n, integer.valued = TRUE,
+ allowable.length = 1, positive = TRUE))
stop("bad input for argument 'n'") else n
if (!is.Numeric(scale, positive = TRUE, allowable.length = 1))
@@ -8032,11 +8229,13 @@ rnaka = function(n, shape, scale = 1, Smallno=1.0e-6) {
initialize = eval(substitute(expression({
if (ncol(cbind(y)) != 1)
stop("response must be a vector or a one-column matrix")
- predictors.names = c(namesof("shape", .lshape, earg = .eshape, tag = FALSE),
- namesof("scale", .lscale, earg = .escale, tag = FALSE))
+ predictors.names =
+ c(namesof("shape", .lshape, earg = .eshape, tag = FALSE),
+ namesof("scale", .lscale, earg = .escale, tag = FALSE))
if (!length(etastart)) {
init2 = if (is.Numeric( .iscale, positive = TRUE))
- rep( .iscale, length.out = n) else rep(1, length.out = n)
+ rep( .iscale, length.out = n) else
+ rep(1, length.out = n)
init1 = if (is.Numeric( .ishape, positive = TRUE))
rep( .ishape, length.out = n) else
rep(init2 / (y+1/8)^2, length.out = n)
@@ -8134,14 +8333,17 @@ rrayleigh = function(n, scale = 1) {
- rayleigh = function(lscale = "loge", escale = list(), nrfs = 1 / 3 + 0.01) {
+ rayleigh = function(lscale = "loge",
+ escale = list(), nrfs = 1 / 3 + 0.01) {
if (mode(lscale) != "character" && mode(lscale) != "name")
lscale = as.character(substitute(lscale))
if (!is.list(escale)) escale = list()
- if (!is.Numeric(nrfs, allowable.length = 1) || nrfs<0 || nrfs > 1)
- stop("bad input for 'nrfs'")
+ if (!is.Numeric(nrfs, allowable.length = 1) ||
+ nrfs < 0 ||
+ nrfs > 1)
+ stop("bad input for 'nrfs'")
new("vglmff",
blurb = c("Rayleigh distribution\n\n",
@@ -8205,19 +8407,23 @@ 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, length.out = N); location = rep(location, length.out = N)
- scale = rep(scale, length.out = N); inequality = rep(inequality, length.out = N)
+ x = rep(x, length.out = N);
+ location = rep(location, length.out = N)
+ scale = rep(scale, length.out = N);
+ inequality = rep(inequality, length.out = N)
shape = rep(shape, length.out = N)
logdensity = rep(log(0), length.out = N)
xok = (x > location)
zedd = (x - location) / scale
- logdensity[xok] = log(shape[xok]) - log(scale[xok]) - log(inequality[xok])+
+ logdensity[xok] = log(shape[xok]) -
+ log(scale[xok]) - log(inequality[xok]) +
(1/inequality[xok]-1) * log(zedd[xok]) -
(shape[xok]+1) * log1p(zedd[xok]^(1/inequality[xok]))
if (log.arg) logdensity else exp(logdensity)
}
+
pparetoIV =
function(q, location = 0, scale = 1, inequality = 1, shape = 1) {
if (!is.Numeric(q))
@@ -8231,8 +8437,10 @@ pparetoIV =
N = max(length(q), length(location), length(scale),
length(inequality), length(shape))
- q = rep(q, length.out = N); location = rep(location, length.out = N)
- scale = rep(scale, length.out = N); inequality = rep(inequality, length.out = N)
+ q = rep(q, length.out = N);
+ location = rep(location, length.out = N)
+ scale = rep(scale, length.out = N);
+ inequality = rep(inequality, length.out = N)
shape = rep(shape, length.out = N)
answer = q * 0
ii = q > location
@@ -8345,11 +8553,14 @@ rparetoI = function(n, scale = 1, shape = 1)
stop("argument 'iinequality' must be positive")
if (is.Numeric(ishape) && any(ishape <= 0))
stop("argument 'ishape' must be positive")
- if (!is.Numeric(imethod, allowable.length = 1, integer.valued = TRUE) || imethod>2)
- stop("bad input for argument 'imethod'")
+ if (!is.Numeric(imethod, allowable.length = 1,
+ integer.valued = TRUE) ||
+ imethod > 2)
+ stop("bad input for argument 'imethod'")
if (linequality == "nloge" && location != 0)
- warning("The Burr distribution has 'location = 0' and 'linequality=nloge'")
+ warning("The Burr distribution has 'location = 0' and ",
+ "'linequality = nloge'")
if (!is.list(escale)) escale = list()
if (!is.list(einequality)) einequality = list()
@@ -8390,14 +8601,17 @@ rparetoI = function(n, scale = 1, shape = 1)
shape.init = max(0.01, (2*A2-A1)/(A1-A2))
}
etastart=cbind(
- theta2eta(rep(scale.init, length.out = n), .lscale, earg = .escale),
- theta2eta(rep(inequality.init, length.out = n), .linequality, earg = .einequality),
- theta2eta(rep(shape.init, length.out = n), .lshape, earg = .eshape))
+ theta2eta(rep(scale.init, length.out = n),
+ .lscale, earg = .escale),
+ theta2eta(rep(inequality.init, length.out = n),
+ .linequality, earg = .einequality),
+ theta2eta(rep(shape.init, length.out = n),
+ .lshape, earg = .eshape))
}
}), list( .location = location, .lscale = lscale,
- .linequality = linequality, .lshape = lshape, .imethod = imethod,
- .escale = escale, .einequality = einequality, .eshape = eshape,
- .iscale = iscale, .iinequality=iinequality, .ishape = ishape ))),
+ .linequality = linequality, .lshape = lshape, .imethod = imethod,
+ .escale = escale, .einequality = einequality, .eshape = eshape,
+ .iscale = iscale, .iinequality=iinequality, .ishape = ishape ))),
linkinv = eval(substitute(function(eta, extra = NULL) {
location = extra$location
Scale = eta2theta(eta[, 1], .lscale, earg = .escale)
@@ -8523,8 +8737,10 @@ rparetoI = function(n, scale = 1, shape = 1)
scale.init = exp(fittemp$coef["Intercept"])
}
etastart=cbind(
- theta2eta(rep(scale.init, length.out = n), .lscale, earg = .escale),
- theta2eta(rep(inequality.init, length.out = n), .linequality,
+ theta2eta(rep(scale.init, length.out = n),
+ .lscale, earg = .escale),
+ theta2eta(rep(inequality.init, length.out = n),
+ .linequality,
earg = .einequality))
}
}), list( .location = location, .lscale = lscale, .linequality = linequality,
@@ -8639,8 +8855,10 @@ rparetoI = function(n, scale = 1, shape = 1)
scale.init = exp(fittemp$coef["Intercept"])
}
etastart=cbind(
- theta2eta(rep(scale.init, length.out = n), .lscale, earg = .escale),
- theta2eta(rep(shape.init, length.out = n), .lshape, earg = .eshape))
+ theta2eta(rep(scale.init, length.out = n),
+ .lscale, earg = .escale),
+ theta2eta(rep(shape.init, length.out = n),
+ .lshape, earg = .eshape))
}
}), list( .location = location, .lscale = lscale,
.escale = escale, .eshape = eshape,
@@ -8709,7 +8927,9 @@ dpareto = function(x, location, shape, log = FALSE) {
rm(log)
L = max(length(x), length(location), length(shape))
- x = rep(x, length.out = L); location = rep(location, length.out = L); shape = rep(shape, length.out = L)
+ x = rep(x, length.out = L);
+ location = rep(location, length.out = L);
+ shape = rep(shape, length.out = L)
logdensity = rep(log(0), length.out = L)
xok = (x > location)
@@ -8722,7 +8942,8 @@ dpareto = function(x, location, shape, log = FALSE) {
ppareto = function(q, location, shape) {
L = max(length(q), length(location), length(shape))
- q = rep(q, length.out = L); location = rep(location, length.out = L);
+ q = rep(q, length.out = L);
+ location = rep(location, length.out = L);
shape = rep(shape, length.out = L)
ans = ifelse(q > location, 1 - (location/q)^shape, 0)
@@ -8781,23 +9002,23 @@ rpareto = function(n, location, shape) {
extra$locationEstimated = locationEstimated
if (!length(etastart)) {
k.init = (y + 1/8) / (y - locationhat + 1/8)
- etastart = theta2eta(k.init, .lshape, earg = .earg)
+ etastart = theta2eta(k.init, .lshape, earg = .earg )
}
}), list( .lshape = lshape, .earg = earg,
.location = location ))),
linkinv = eval(substitute(function(eta, extra = NULL) {
- k = eta2theta(eta, .lshape, earg = .earg)
+ k = eta2theta(eta, .lshape, earg = .earg )
location = extra$location
ifelse(k > 1, k * location / (k-1), NA)
}, list( .lshape = lshape, .earg = earg ))),
last = eval(substitute(expression({
misc$link = c(k = .lshape)
- misc$earg = list(k = .earg)
+ misc$earg = list(k = .earg )
misc$location = extra$location # Use this for prediction
}), list( .lshape = lshape, .earg = earg ))),
loglikelihood = eval(substitute(
function(mu, y, w, residuals = FALSE, eta, extra = NULL) {
- k = eta2theta(eta, .lshape, earg = .earg)
+ k = eta2theta(eta, .lshape, earg = .earg )
location = extra$location
if (residuals) stop("loglikelihood residuals ",
"not implemented yet") else {
@@ -8809,9 +9030,9 @@ rpareto = function(n, location, shape) {
vfamily = c("pareto1"),
deriv = eval(substitute(expression({
location = extra$location
- k = eta2theta(eta, .lshape, earg = .earg)
+ k = eta2theta(eta, .lshape, earg = .earg )
dl.dk = 1/k + log(location/y)
- dk.deta = dtheta.deta(k, .lshape, earg = .earg)
+ dk.deta = dtheta.deta(k, .lshape, earg = .earg )
c(w) * dl.dk * dk.deta
}), list( .lshape = lshape, .earg = earg ))),
weight = eval(substitute(expression({
@@ -8841,8 +9062,10 @@ dtpareto = function(x, lower, upper, shape, log = FALSE) {
stop("argument 'shape' must be positive")
L = max(length(x), length(lower), length(upper), length(shape))
- x = rep(x, length.out = L); shape = rep(shape, length.out = L)
- lower = rep(lower, length.out = L); upper = rep(upper, length.out = L);
+ x = rep(x, length.out = L);
+ shape = rep(shape, length.out = L)
+ lower = rep(lower, length.out = L);
+ upper = rep(upper, length.out = L);
logdensity <- rep(log(0), length.out = L)
@@ -8864,8 +9087,10 @@ ptpareto = function(q, lower, upper, shape) {
stop("bad input for argument 'q'")
L = max(length(q), length(lower), length(upper), length(shape))
- q = rep(q, length.out = L); lower = rep(lower, length.out = L);
- upper = rep(upper, length.out = L); shape = rep(shape, length.out = L)
+ q = rep(q, length.out = L);
+ lower = rep(lower, length.out = L);
+ upper = rep(upper, length.out = L);
+ shape = rep(shape, length.out = L)
ans = q * 0
xok <- (0 < lower) & (lower < q) & (q < upper) & (shape > 0)
@@ -8924,7 +9149,8 @@ rtpareto = function(n, lower, upper, shape) {
if (length(ishape) && !is.Numeric(ishape, positive = TRUE))
stop("bad input for argument 'ishape'")
if (!is.list(earg)) earg = list()
- if (!is.Numeric(imethod, allowable.length = 1, integer.valued = TRUE, positive = TRUE) ||
+ if (!is.Numeric(imethod, allowable.length = 1,
+ integer.valued = TRUE, positive = TRUE) ||
imethod > 2)
stop("argument 'imethod' must be 1 or 2")
@@ -8967,14 +9193,14 @@ rtpareto = function(n, lower, upper, shape) {
try.this = rep(try.this, length.out = n)
try.this
}
- etastart = theta2eta(shape.init, .lshape, earg = .earg)
+ etastart = theta2eta(shape.init, .lshape, earg = .earg )
}
}), list( .lshape = lshape, .earg = earg,
.ishape = ishape,
.imethod = imethod,
.lower = lower, .upper = upper ))),
linkinv = eval(substitute(function(eta, extra = NULL) {
- shape = eta2theta(eta, .lshape, earg = .earg)
+ shape = eta2theta(eta, .lshape, earg = .earg )
myratio = .lower / .upper
constprop = shape * .lower^shape / (1 - myratio^shape)
constprop * ( .upper^(1-shape) - .lower^(1-shape)) / (1-shape)
@@ -8982,7 +9208,7 @@ rtpareto = function(n, lower, upper, shape) {
.lower = lower, .upper = upper ))),
last = eval(substitute(expression({
misc$link = c(shape = .lshape)
- misc$earg = list(shape = .earg)
+ misc$earg = list(shape = .earg )
misc$lower = extra$lower
misc$upper = extra$upper
misc$expected = TRUE
@@ -8990,7 +9216,7 @@ rtpareto = function(n, lower, upper, shape) {
.lower = lower, .upper = upper ))),
loglikelihood = eval(substitute(
function(mu, y, w, residuals = FALSE, eta, extra = NULL) {
- shape = eta2theta(eta, .lshape, earg = .earg)
+ shape = eta2theta(eta, .lshape, earg = .earg )
if (residuals) stop("loglikelihood residuals ",
"not implemented yet") else {
ans = sum(w * dtpareto(x = y, lower = .lower , upper = .upper ,
@@ -9001,12 +9227,12 @@ rtpareto = function(n, lower, upper, shape) {
.lower = lower, .upper = upper ))),
vfamily = c("tpareto1"),
deriv = eval(substitute(expression({
- shape = eta2theta(eta, .lshape, earg = .earg)
+ shape = eta2theta(eta, .lshape, earg = .earg )
myratio = .lower / .upper
myratio2 = myratio^shape
tmp330 = myratio2 * log(myratio) / (1 - myratio2)
dl.dshape = 1 / shape + log( .lower) - log(y) + tmp330
- dshape.deta = dtheta.deta(shape, .lshape, earg = .earg)
+ dshape.deta = dtheta.deta(shape, .lshape, earg = .earg )
c(w) * dl.dshape * dshape.deta
}), list( .lshape = lshape, .earg = earg,
.lower = lower, .upper = upper ))),
@@ -9053,7 +9279,9 @@ erfc = function(x)
initlambda = if (length( .init.lambda)) .init.lambda else
1 / (0.01 + (y-1)^2)
initlambda = rep(initlambda, length.out = n)
- etastart = cbind(theta2eta(initlambda, link=.link.lambda, earg = .earg))
+ etastart =
+ cbind(theta2eta(initlambda,
+ link = .link.lambda , earg = .earg ))
}
}), list( .link.lambda = link.lambda, .earg = earg,
.init.lambda=init.lambda ))),
@@ -9066,16 +9294,16 @@ erfc = function(x)
}), list( .link.lambda = link.lambda, .earg = earg ))),
loglikelihood = eval(substitute(
function(mu, y, w, residuals = FALSE, eta, extra = NULL) {
- lambda = eta2theta(eta, link=.link.lambda, earg = .earg)
+ lambda = eta2theta(eta, link=.link.lambda, earg = .earg )
if (residuals) stop("loglikelihood residuals ",
"not implemented yet") else
sum(w * (0.5 * log(lambda/(2*pi*y^3)) - lambda * (y-1)^2 / (2*y)))
}, list( .link.lambda = link.lambda, .earg = earg ))),
vfamily = "wald",
deriv = eval(substitute(expression({
- lambda = eta2theta(eta, link=.link.lambda, earg = .earg)
+ lambda = eta2theta(eta, link=.link.lambda, earg = .earg )
dl.dlambda = 0.5 / lambda + 1 - 0.5 * (y + 1/y)
- dlambda.deta = dtheta.deta(theta=lambda, link=.link.lambda, earg = .earg)
+ dlambda.deta = dtheta.deta(theta=lambda, link=.link.lambda, earg = .earg )
c(w) * cbind(dl.dlambda * dlambda.deta)
}), list( .link.lambda = link.lambda, .earg = earg ))),
weight = eval(substitute(expression({
@@ -9133,9 +9361,11 @@ erfc = function(x)
shape.init = if (!is.Numeric( .ishape, positive = TRUE))
stop("argument 'ishape' must be positive") else
rep( .ishape, length.out = n)
- scale.init = if (length( .iscale)) rep( .iscale, length.out = n) else
+ scale.init = if (length( .iscale))
+ rep( .iscale, length.out = n) else
(digamma(shape.init+1) - digamma(1)) / (y+1/8)
- scale.init = rep(weighted.mean(scale.init, w = w), length.out = n)
+ scale.init = rep(weighted.mean(scale.init, w = w),
+ length.out = n)
etastart = cbind(theta2eta(shape.init, .lshape, earg = .eshape),
theta2eta(scale.init, .lscale, earg = .escale))
}
@@ -9239,7 +9469,8 @@ erfc = function(x)
initialize = eval(substitute(expression({
if (ncol(cbind(y)) != 1)
stop("response must be a vector or a one-column matrix")
- predictors.names = namesof("scale", .lscale, earg = .escale, short = TRUE)
+ predictors.names =
+ namesof("scale", .lscale, earg = .escale, short = TRUE)
if (length(w) != n ||
!is.Numeric(w, integer.valued = TRUE, positive = TRUE))
@@ -9256,7 +9487,8 @@ erfc = function(x)
shape.init = if (!is.Numeric( .ishape, positive = TRUE))
stop("argument 'ishape' must be positive") else
rep( .ishape, length.out = n)
- scaleinit = if (length( .iscale)) rep( .iscale, length.out = n) else
+ scaleinit = if (length( .iscale))
+ rep( .iscale, length.out = n) else
(digamma(shape.init+1) - digamma(1)) / (y+1/8)
etastart = cbind(theta2eta(scaleinit, .lscale, earg = .escale))
}
@@ -9331,7 +9563,9 @@ betaffqn.control <- function(save.weight = TRUE, ...)
if (mode(link) != "character" && mode(link) != "name")
link = as.character(substitute(link))
- if (!is.Numeric(A, allowable.length = 1) || !is.Numeric(B, allowable.length = 1) || A >= B)
+ if (!is.Numeric(A, allowable.length = 1) ||
+ !is.Numeric(B, allowable.length = 1) ||
+ A >= B)
stop("A must be < B, and both must be of length one")
stdbeta = (A == 0 && B == 1) # stdbeta==T iff standard beta distribution
if (!is.list(earg)) earg = list()
@@ -9341,8 +9575,9 @@ betaffqn.control <- function(save.weight = TRUE, ...)
if (stdbeta)
"y^(shape1-1) * (1-y)^(shape2-1), 0<=y <= 1, shape1>0, shape2>0\n\n"
else
- paste("(y-",A,")^(shape1-1) * (",B,
- "-y)^(shape2-1), ",A,"<=y <= ",B," shape1>0, shape2>0\n\n", sep = ""),
+ paste("(y-",A,")^(shape1-1) * (", B,
+ "-y)^(shape2-1), ",A,"<=y <= ", B,
+ " shape1>0, shape2>0\n\n", sep = ""),
"Links: ",
namesof("shape1", link, earg = earg), ", ",
namesof("shape2", link, earg = earg)),
@@ -9351,12 +9586,13 @@ betaffqn.control <- function(save.weight = TRUE, ...)
stop("response must be a vector or a one-column matrix")
if (min(y) <= .A || max(y) >= .B)
stop("data not within (A, B)")
- predictors.names = c(namesof("shape1", .link, earg = .earg, short = TRUE),
- namesof("shape2", .link, earg = .earg, short = TRUE))
+ predictors.names =
+ c(namesof("shape1", .link, earg = .earg, short = TRUE),
+ namesof("shape2", .link, earg = .earg, short = TRUE))
if (is.numeric( .i1) && is.numeric( .i2)) {
vec = c( .i1, .i2)
- vec = c(theta2eta(vec[1], .link, earg = .earg),
- theta2eta(vec[2], .link, earg = .earg))
+ vec = c(theta2eta(vec[1], .link, earg = .earg ),
+ theta2eta(vec[2], .link, earg = .earg ))
etastart = matrix(vec, n, 2, byrow= TRUE)
}
@@ -9368,40 +9604,42 @@ betaffqn.control <- function(save.weight = TRUE, ...)
mu1d = mean(y, trim=.trim)
uu = (mu1d-.A) / ( .B - .A)
DD = ( .B - .A)^2
- pinit = uu^2 * (1-uu)*DD/var(y) - uu # But var(y) is not robust
+ pinit = uu^2 * (1-uu)*DD/var(y) - uu # But var(y) is not robust
qinit = pinit * (1-uu) / uu
- etastart = matrix(theta2eta(c(pinit,qinit), .link, earg = .earg),
+ etastart = matrix(theta2eta(c(pinit,qinit), .link, earg = .earg ),
n,2,byrow = TRUE)
}
- }), list( .link = link, .earg = earg, .i1=i1, .i2=i2, .trim=trim, .A = A, .B = B ))),
+ }), list( .link = link, .earg = earg,
+ .i1 = i1, .i2 = i2, .trim = trim, .A = A, .B = B ))),
linkinv = eval(substitute(function(eta, extra = NULL) {
- shapes = eta2theta(eta, .link, earg = .earg)
+ shapes = eta2theta(eta, .link, earg = .earg )
.A + ( .B-.A) * shapes[, 1] / (shapes[, 1] + shapes[, 2])
}, list( .link = link, .earg = earg, .A = A, .B = B ))),
last = eval(substitute(expression({
misc$link = c(shape1 = .link, shape2 = .link)
- misc$earg = list(shape1 = .earg, shape2 = .earg)
+ misc$earg = list(shape1 = .earg, shape2 = .earg )
misc$limits = c( .A, .B)
misc$expected = FALSE
misc$BFGS = TRUE
}), list( .link = link, .earg = earg, .A = A, .B = B ))),
loglikelihood = eval(substitute(
function(mu, y, w, residuals = FALSE, eta, extra = NULL){
- shapes = eta2theta(eta, .link, earg = .earg)
+ shapes = eta2theta(eta, .link, earg = .earg )
temp = lbeta(shapes[, 1], shapes[, 2])
if (residuals) stop("loglikelihood residuals ",
"not implemented yet") else {
- sum(w * ((shapes[, 1]-1)*log(y-.A) + (shapes[, 2]-1)*log( .B-y) - temp -
+ sum(w * ((shapes[, 1]-1)*log(y-.A) +
+ (shapes[, 2]-1)*log( .B-y) - temp -
(shapes[, 1]+shapes[, 2]-1)*log( .B-.A )))
}
}, list( .link = link, .earg = earg, .A = A, .B = B ))),
vfamily = "betaffqn",
deriv = eval(substitute(expression({
- shapes = eta2theta(eta, .link, earg = .earg)
- dshapes.deta = dtheta.deta(shapes, .link, earg = .earg)
+ shapes = eta2theta(eta, .link, earg = .earg )
+ dshapes.deta = dtheta.deta(shapes, .link, earg = .earg )
dl.dshapes = cbind(log(y-.A), log( .B-y)) - digamma(shapes) +
digamma(shapes[, 1] + shapes[, 2]) - log( .B - .A)
if (iter == 1) {
@@ -9416,12 +9654,13 @@ betaffqn.control <- function(save.weight = TRUE, ...)
}), list( .link = link, .earg = earg, .A = A, .B = B ))),
weight = expression({
if (iter == 1) {
- wznew = cbind(matrix(w, n, M), matrix(0, n, dimm(M)-M))
+ 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,
- trace=trace) # weights incorporated in args
+ wzold = wznew
+ wznew = qnupdate(w = w, wzold=wzold,
+ dderiv=(derivold - derivnew),
+ deta=etanew-etaold, M = M,
+ trace=trace) # weights incorporated in args
}
wznew
}))
@@ -9481,12 +9720,16 @@ betaffqn.control <- function(save.weight = TRUE, ...)
scale.init = sqrt(3) * sd(y) / pi
} else {
location.init = median(rep(y, w))
- scale.init = sqrt(3) * sum(w*(y-location.init)^2) / (sum(w)*pi)
+ scale.init = sqrt(3) *
+ sum(w*(y-location.init)^2) / (sum(w)*pi)
}
- location.init = if (length( .ilocation)) rep( .ilocation, length.out = n) else
+ location.init = if (length( .ilocation))
+ rep( .ilocation, length.out = n) else
rep(location.init, length.out = n)
- if ( .llocation == "loge") location.init = abs(location.init) + 0.001
- scale.init = if (length( .iscale)) rep( .iscale, length.out = n) else
+ if ( .llocation == "loge")
+ location.init = abs(location.init) + 0.001
+ scale.init = if (length( .iscale))
+ rep( .iscale, length.out = n) else
rep(1, length.out = n)
etastart = cbind(
theta2eta(location.init, .llocation, earg = .elocation),
@@ -9572,10 +9815,12 @@ betaffqn.control <- function(save.weight = TRUE, ...)
if (length(imu) && !is.Numeric(imu, positive = TRUE))
stop("bad input for argument 'imu'")
- if (!is.Numeric(imethod, allowable.length = 1, integer.valued = TRUE, positive = TRUE) ||
+ if (!is.Numeric(imethod, allowable.length = 1,
+ integer.valued = TRUE, positive = TRUE) ||
imethod > 3)
stop("argument 'imethod' must be 1 or 2 or 3")
- if (!is.Numeric(shrinkage.init, allowable.length = 1) || shrinkage.init < 0 ||
+ if (!is.Numeric(shrinkage.init, allowable.length = 1) ||
+ shrinkage.init < 0 ||
shrinkage.init > 1)
stop("bad input for argument 'shrinkage.init'")
@@ -9778,3 +10023,5 @@ betaffqn.control <- function(save.weight = TRUE, ...)
+
+
diff --git a/R/family.zeroinf.R b/R/family.zeroinf.R
index e3ac25b..9ee9fc6 100644
--- a/R/family.zeroinf.R
+++ b/R/family.zeroinf.R
@@ -62,10 +62,10 @@ pzanegbin = function(q, size, prob = NULL, munb = NULL, pobs0 = 0) {
}
LLL = max(length(q), length(pobs0), length(prob), length(size))
- if (length(q) != LLL) q = rep(q, len = LLL);
- if (length(pobs0) != LLL) pobs0 = rep(pobs0, len = LLL);
- if (length(prob) != LLL) prob = rep(prob, len = LLL);
- if (length(size) != LLL) size = rep(size, len = LLL);
+ if (length(q) != LLL) q = rep(q, len = LLL);
+ if (length(pobs0) != LLL) pobs0 = rep(pobs0, len = LLL);
+ if (length(prob) != LLL) prob = rep(prob, len = LLL);
+ if (length(size) != LLL) size = rep(size, len = LLL);
ans = rep(0.0, len = LLL)
if (!is.Numeric(pobs0) || any(pobs0 < 0) || any(pobs0 > 1))
@@ -73,7 +73,7 @@ pzanegbin = function(q, size, prob = NULL, munb = NULL, pobs0 = 0) {
qindex = (q > 0)
ans[ qindex] = pobs0[qindex] + (1 - pobs0[qindex]) *
pposnegbin(q[qindex], size = size[qindex],
- prob = prob[qindex])
+ prob = prob[qindex])
ans[q < 0] = 0
ans[q == 0] = pobs0[q == 0]
ans
@@ -2790,9 +2790,9 @@ dzageom = function(x, prob, pobs0 = 0, log = FALSE) {
rm(log)
LLL = max(length(x), length(prob), length(pobs0))
- if (length(x) != LLL) x = rep(x, len = LLL);
- if (length(prob) != LLL) prob = rep(prob, len = LLL);
- if (length(pobs0) != LLL) pobs0 = rep(pobs0, len = LLL);
+ if (length(x) != LLL) x = rep(x, len = LLL);
+ if (length(prob) != LLL) prob = rep(prob, len = LLL);
+ if (length(pobs0) != LLL) pobs0 = rep(pobs0, len = LLL);
ans = rep(0.0, len = LLL)
if (!is.Numeric(pobs0) || any(pobs0 < 0) || any(pobs0 > 1))
stop("argument 'pobs0' must be in [0,1]")
@@ -2819,7 +2819,7 @@ pzageom = function(q, prob, pobs0 = 0) {
LLL = max(length(q), length(prob), length(pobs0))
if (length(q) != LLL) q = rep(q, len = LLL);
if (length(prob) != LLL) prob = rep(prob, len = LLL);
- if (length(pobs0) != LLL) pobs0 = rep(pobs0, len = LLL);
+ if (length(pobs0) != LLL) pobs0 = rep(pobs0, len = LLL);
ans = rep(0.0, len = LLL)
if (!is.Numeric(pobs0) || any(pobs0 < 0) || any(pobs0 > 1))
stop("argument 'pobs0' must be in [0,1]")
@@ -2854,7 +2854,8 @@ qzageom = function(p, prob, pobs0 = 0) {
rzageom = function(n, prob, pobs0 = 0) {
use.n = if ((length.n <- length(n)) > 1) length.n else
- if (!is.Numeric(n, integer.valued = TRUE, allowable.length = 1, positive = TRUE))
+ if (!is.Numeric(n, integer.valued = TRUE,
+ allowable.length = 1, positive = TRUE))
stop("bad input for argument 'n'") else n
ans = rposgeom(use.n, prob)
@@ -2882,7 +2883,7 @@ dzabinom = function(x, size, prob, pobs0 = 0, log = FALSE) {
if (length(x) != LLL) x = rep(x, len = LLL);
if (length(size) != LLL) size = rep(size, len = LLL);
if (length(prob) != LLL) prob = rep(prob, len = LLL);
- if (length(pobs0) != LLL) pobs0 = rep(pobs0, len = LLL);
+ if (length(pobs0) != LLL) pobs0 = rep(pobs0, len = LLL);
ans = rep(0.0, len = LLL)
if (!is.Numeric(pobs0) || any(pobs0 < 0) || any(pobs0 > 1))
stop("argument 'pobs0' must be in [0,1]")
@@ -2910,9 +2911,10 @@ pzabinom = function(q, size, prob, pobs0 = 0) {
if (length(q) != LLL) q = rep(q, len = LLL);
if (length(size) != LLL) size = rep(size, len = LLL);
if (length(prob) != LLL) prob = rep(prob, len = LLL);
- if (length(pobs0) != LLL) pobs0 = rep(pobs0, len = LLL);
+ if (length(pobs0) != LLL) pobs0 = rep(pobs0, len = LLL);
ans = rep(0.0, len = LLL)
- if (!is.Numeric(pobs0) || any(pobs0 < 0) || any(pobs0 > 1))
+ if (!is.Numeric(pobs0) ||
+ any(pobs0 < 0) || any(pobs0 > 1))
stop("argument 'pobs0' must be in [0,1]")
ans[q > 0] = pobs0[q > 0] +
diff --git a/R/links.q b/R/links.q
index 44c2b31..fabed11 100644
--- a/R/links.q
+++ b/R/links.q
@@ -22,8 +22,9 @@
shrinkage.init = 0.95,
nointercept = NULL, imethod = 1,
prob.x = c(0.15, 0.85),
- mv = FALSE, oim = FALSE,
- nsimEIM = 100, zero = NULL) {
+ mv = FALSE, whitespace = FALSE,
+ oim = FALSE, nsimEIM = 100,
+ zero = NULL) {
NULL
}
diff --git a/R/model.matrix.vglm.q b/R/model.matrix.vglm.q
index 4554b36..2cc75f4 100644
--- a/R/model.matrix.vglm.q
+++ b/R/model.matrix.vglm.q
@@ -31,7 +31,7 @@
- vlabel = function(xn, ncolBlist, M, separator=":") {
+ vlabel = function(xn, ncolBlist, M, separator = ":") {
if (length(xn) != length(ncolBlist))
stop("length of first two arguments not equal")
@@ -43,16 +43,16 @@
n2 = lapply(n2, seq)
n2 = unlist(n2)
n2 = as.character(n2)
- n2 = paste(separator, n2, sep="")
+ n2 = paste(separator, n2, sep = "")
n3 = rep(ncolBlist, ncolBlist)
- n2[n3==1] = ""
- n1n2 = paste(n1, n2, sep="")
+ n2[n3 == 1] = ""
+ n1n2 = paste(n1, n2, sep = "")
n1n2
}
- lm2vlm.model.matrix = function(x, Blist=NULL, assign.attributes=TRUE,
- M=NULL, xij=NULL, Xm2=NULL) {
+ lm2vlm.model.matrix = function(x, Blist = NULL, assign.attributes = TRUE,
+ M = NULL, xij = NULL, Xm2 = NULL) {
@@ -75,7 +75,7 @@
X_vlm = if (M > 1) kronecker(x, diag(M)) else x
ncolBlist = rep(M, ncol(x))
} else {
- allB = matrix(unlist(Blist), nrow=M)
+ allB = matrix(unlist(Blist), nrow = M)
ncolBlist = unlist(lapply(Blist, ncol))
Rsum = sum(ncolBlist)
@@ -116,7 +116,7 @@
vasgn = vector("list", sum(fred))
kk = 0
for(ii in 1:length(oasgn)) {
- temp = matrix(nasgn[[ii]], ncol=length(oasgn[[ii]]))
+ temp = matrix(nasgn[[ii]], ncol = length(oasgn[[ii]]))
for(jloc in 1:nrow(temp)) {
kk = kk + 1
vasgn[[kk]] = temp[jloc,]
@@ -192,56 +192,93 @@
- model.matrixvlm = function(object, type=c("vlm","lm","lm2","bothlmlm2"),
+ model.matrixvlm = function(object,
+ type = c("vlm", "lm", "lm2", "bothlmlm2"),
+ lapred.index = NULL,
...) {
if (mode(type) != "character" && mode(type) != "name")
type = as.character(substitute(type))
- type = match.arg(type, c("vlm","lm","lm2","bothlmlm2"))[1]
+ type = match.arg(type, c("vlm", "lm", "lm2", "bothlmlm2"))[1]
+ if (length(lapred.index) &&
+ type != "lm")
+ stop("Must set 'type = \"lm\"' when 'lapred.index' is ",
+ "assigned a value")
+ if (length(lapred.index) &&
+ length(object at control$xij))
+ stop("Currently cannot handle 'xij' models when 'lapred.index' is ",
+ "assigned a value")
- x = slot(object, "x")
+ x = slot(object, "x")
Xm2 = slot(object, "Xm2")
if (!length(x)) {
- data = model.frame(object, xlev=object at xlevels, ...)
+ data = model.frame(object, xlev = object at xlevels, ...)
kill.con = if (length(object at contrasts)) object at contrasts else NULL
- x = vmodel.matrix.default(object, data=data,
+ x = vmodel.matrix.default(object, data = data,
contrasts.arg = kill.con)
tt = terms(object)
attr(x, "assign") = attrassigndefault(x, tt)
}
- if ((type == "lm2" || type == "bothlmlm2") && !length(Xm2)) {
- object.copy2 = object
- data = model.frame(object.copy2, xlev=object.copy2 at xlevels, ...)
+ if ((type == "lm2" || type == "bothlmlm2") &&
+ !length(Xm2)) {
+ object.copy2 = object
+ data = model.frame(object.copy2, xlev = object.copy2 at xlevels, ...)
- kill.con = if (length(object.copy2 at contrasts))
- object.copy2 at contrasts else NULL
+ kill.con = if (length(object.copy2 at contrasts))
+ object.copy2 at contrasts else NULL
- Xm2 = vmodel.matrix.default(object.copy2, data=data,
- contrasts.arg = kill.con)
- ttXm2 = terms(object.copy2 at misc$form2)
- attr(Xm2, "assign") = attrassigndefault(Xm2, ttXm2)
+ Xm2 = vmodel.matrix.default(object.copy2, data = data,
+ contrasts.arg = kill.con)
+ ttXm2 = terms(object.copy2 at misc$form2)
+ attr(Xm2, "assign") = attrassigndefault(Xm2, ttXm2)
}
- if (type == "lm") {
- return(x)
+
+
+ if (type == "lm" && is.null(lapred.index)) {
+ return(x)
} else if (type == "lm2") {
- return(Xm2)
+ return(Xm2)
} else if (type == "bothlmlm2") {
- return(list(X=x, Xm2=Xm2))
+ return(list(X = x, Xm2 = Xm2))
+ }
+
+
+ M = object at misc$M
+ Blist = object at constraints # == constraints(object, type = "vlm")
+ X_vlm <- lm2vlm.model.matrix(x = x, Blist = Blist,
+ xij = object at control$xij, Xm2 = Xm2)
+
+ if (type == "vlm") {
+ return(X_vlm)
+ } else if (type == "lm" && length(lapred.index)) {
+ if (!is.Numeric(lapred.index, integer.valued = TRUE, positive = TRUE,
+ allowable.length = 1))
+ stop("bad input for argument 'lapred.index'")
+ if (!length(intersect(lapred.index, 1:M)))
+ stop("argument 'lapred.index' should have ",
+ "a single value from the set 1:", M)
+
+ Hlist = Blist
+ n_lm = nobs(object) # Number of rows of the LM matrix
+ M = object at misc$M # Number of linear/additive predictors
+ Hmatrices = matrix(c(unlist(Hlist)), nrow = M)
+ jay = lapred.index
+ index0 = Hmatrices[jay, ] != 0
+ X_lm_jay = X_vlm[(0:(n_lm - 1)) * M + jay, index0, drop = FALSE]
+ X_lm_jay
} else {
- M = object at misc$M
- Blist = object at constraints # Is NULL if there were no constraints?
- lm2vlm.model.matrix(x=x, Blist=Blist, xij=object at control$xij, Xm2=Xm2)
+ stop("am confused. Don't know what to return")
}
}
@@ -258,31 +295,31 @@ setMethod("model.matrix", "vlm", function(object, ...)
model.framevlm = function(object,
- setupsmart=TRUE, wrapupsmart=TRUE, ...) {
-
- dots = list(...)
- nargs = dots[match(c("data", "na.action", "subset"), names(dots), 0)]
- if (length(nargs) || !length(object at model)) {
- fcall = object at call
- fcall$method = "model.frame"
- fcall[[1]] = as.name("vlm")
-
- fcall$smart = FALSE
- if (setupsmart && length(object at smart.prediction)) {
- setup.smart("read", smart.prediction=object at smart.prediction)
- }
+ setupsmart = TRUE, wrapupsmart = TRUE, ...) {
+
+ dots = list(...)
+ nargs = dots[match(c("data", "na.action", "subset"), names(dots), 0)]
+ if (length(nargs) || !length(object at model)) {
+ fcall = object at call
+ fcall$method = "model.frame"
+ fcall[[1]] = as.name("vlm")
+
+ fcall$smart = FALSE
+ if (setupsmart && length(object at smart.prediction)) {
+ setup.smart("read", smart.prediction=object at smart.prediction)
+ }
- fcall[names(nargs)] = nargs
- env = environment(object at terms$terms) # @terms or @terms$terms ??
- if (is.null(env))
- env = parent.frame()
- ans = eval(fcall, env, parent.frame())
+ fcall[names(nargs)] = nargs
+ env = environment(object at terms$terms) # @terms or @terms$terms ??
+ if (is.null(env))
+ env = parent.frame()
+ ans = eval(fcall, env, parent.frame())
- if (wrapupsmart && length(object at smart.prediction)) {
- wrapup.smart()
- }
- ans
- } else object at model
+ if (wrapupsmart && length(object at smart.prediction)) {
+ wrapup.smart()
+ }
+ ans
+ } else object at model
}
@@ -299,7 +336,7 @@ setMethod("model.frame", "vlm", function(formula, ...)
vmodel.matrix.default = function(object, data = environment(object),
contrasts.arg = NULL, xlev = NULL, ...) {
- print("20120221; in vmodel.matrix.default")
+
t <- if (missing(data)) terms(object) else terms(object, data = data)
if (is.null(attr(data, "terms")))
data <- model.frame(object, data, xlev = xlev) else {
@@ -384,5 +421,310 @@ setMethod("depvar", "rcam", function(object, ...)
+npred.vlm <- function(object, ...) {
+ if (length(object at misc$M))
+ object at misc$M else
+ if (ncol(as.matrix(predict(object))) > 0)
+ ncol(as.matrix(predict(object))) else
+ stop("cannot seem to obtain 'M'")
+}
+
+
+if (!isGeneric("npred"))
+ setGeneric("npred", function(object, ...) standardGeneric("npred"),
+ package = "VGAM")
+
+
+setMethod("npred", "vlm", function(object, ...)
+ npred.vlm(object, ...))
+setMethod("npred", "rrvglm", function(object, ...)
+ npred.vlm(object, ...))
+setMethod("npred", "qrrvglm", function(object, ...)
+ npred.vlm(object, ...))
+setMethod("npred", "cao", function(object, ...)
+ npred.vlm(object, ...))
+setMethod("npred", "rcam", function(object, ...)
+ npred.vlm(object, ...))
+
+
+
+
+
+
+
+hatvaluesvlm <- function(model,
+ type = c("diagonal", "matrix", "centralBlocks"), ...) {
+
+
+ if(!missing(type))
+ type <- as.character(substitute(type))
+ type.arg <- match.arg(type, c("diagonal", "matrix", "centralBlocks"))[1]
+
+
+ qrSlot <- model at qr
+
+ if (!is.list(qrSlot) && class(qrSlot) != "qr")
+ stop("slot 'qr' should be a list")
+
+ M <- npred(model)
+ nn <- nobs(model, type = "lm")
+
+ if (is.empty.list(qrSlot)) {
+
+ wzedd <- weights(model, type = "working")
+ UU <- vchol(wzedd, M = M, n = nn, silent = TRUE) # Few rows, many cols
+ X.vlm <- model.matrix(model, type = "vlm")
+ UU.X.vlm <- mux111(cc = UU, xmat = X.vlm, M = M)
+ qrSlot <- qr(UU.X.vlm)
+ } else {
+ X.vlm <- NULL
+ class(qrSlot) <- "qr" # S3 class
+ }
+ Q.S3 <- qr.Q(qrSlot)
+
+
+
+ if (type.arg == "diagonal") {
+ Diag.Hat <- rowSums(Q.S3^2)
+ Diag.Elts <- matrix(Diag.Hat, nn, M, byrow = TRUE)
+
+ if (length(model at misc$predictors.names) == M)
+ colnames(Diag.Elts) <- model at misc$predictors.names
+ if (length(rownames(model.matrix(model, type = "lm"))))
+ rownames(Diag.Elts) <- rownames(model.matrix(model, type = "lm"))
+
+ attr(Diag.Elts, "predictors.names") <- model at misc$predictors.names
+ attr(Diag.Elts, "ncol_X_vlm") <- model at misc$ncol_X_vlm
+
+ Diag.Elts
+ } else if (type.arg == "matrix") {
+ all.mat <- Q.S3 %*% t(Q.S3)
+ if (!length(X.vlm))
+ X.vlm <- model.matrix(model, type = "vlm")
+ dimnames(all.mat) <- list(rownames(X.vlm), rownames(X.vlm))
+
+ attr(all.mat, "M") <- M
+ attr(all.mat, "predictors.names") <- model at misc$predictors.names
+ attr(all.mat, "ncol_X_vlm") <- model at misc$ncol_X_vlm
+
+ all.mat
+ } else {
+ ind1 <- iam(NA, NA, M = M, both = TRUE, diag = TRUE)
+ MM12 <- M * (M + 1) / 2
+ all.rows.index = rep((0:(nn-1)) * M, rep(MM12, nn)) + ind1$row.index
+ all.cols.index = rep((0:(nn-1)) * M, rep(MM12, nn)) + ind1$col.index
+
+ H_ss = rowSums(Q.S3[all.rows.index, ] *
+ Q.S3[all.cols.index, ])
+
+ H_ss = matrix(H_ss, nn, MM12, byrow = TRUE)
+ H_ss
+ }
+}
+
+
+
+
+if (!isGeneric("hatvalues"))
+ setGeneric("hatvalues", function(model, ...)
+ standardGeneric("hatvalues"), package = "VGAM")
+
+
+setMethod("hatvalues", "vlm", function(model, ...)
+ hatvaluesvlm(model, ...))
+setMethod("hatvalues", "vglm", function(model, ...)
+ hatvaluesvlm(model, ...))
+setMethod("hatvalues", "rrvglm", function(model, ...)
+ hatvaluesvlm(model, ...))
+setMethod("hatvalues", "qrrvglm", function(model, ...)
+ hatvaluesvlm(model, ...))
+setMethod("hatvalues", "cao", function(model, ...)
+ hatvaluesvlm(model, ...))
+setMethod("hatvalues", "rcam", function(model, ...)
+ hatvaluesvlm(model, ...))
+
+
+
+
+
+
+
+
+hatplot.vlm <-
+ function(model, multiplier = c(2, 3),
+ lty = "dashed",
+ xlab = "Observation",
+ ylab = "Hat values",
+ ylim = NULL, ...) {
+
+ if (is(model, "vlm")) {
+ hatval <- hatvalues(model, diag = TRUE)
+ } else {
+ hatval <- model
+ }
+
+ if (!is.matrix(hatval))
+ stop("argument 'model' seems neither a vglm() object or a matrix")
+
+ ncol_X_vlm <- attr(hatval, "ncol_X_vlm")
+ M <- attr(hatval, "M")
+ predictors.names <- attr(hatval, "predictors.names")
+ if (!length(predictors.names)) {
+ predictors.names <- paste("Linear/additive predictor", 1:M)
+ }
+
+ if (length(M)) {
+ N <- nrow(hatval) / M
+ hatval <- matrix(hatval, N, M, byrow = TRUE)
+ } else {
+ M <- ncol(hatval)
+ N <- nrow(hatval)
+ }
+
+ if (is.null(ylim))
+ ylim = c(0, max(hatval))
+ for (jay in 1:M) {
+ plot(hatval[, jay], type = "n", main = predictors.names[jay],
+ ylim = ylim, xlab = xlab, ylab = ylab,
+ ...)
+ points(1:N, hatval[, jay], ...)
+ abline(h = multiplier * ncol_X_vlm / (N * M), lty = lty, ...)
+ }
+}
+
+
+
+
+if (!isGeneric("hatplot"))
+ setGeneric("hatplot", function(model, ...)
+ standardGeneric("hatplot"), package = "VGAM")
+
+
+setMethod("hatplot", "matrix", function(model, ...)
+ hatplot.vlm(model, ...))
+
+setMethod("hatplot", "vlm", function(model, ...)
+ hatplot.vlm(model, ...))
+setMethod("hatplot", "vglm", function(model, ...)
+ hatplot.vlm(model, ...))
+
+setMethod("hatplot", "rrvglm", function(model, ...)
+ hatplot.vlm(model, ...))
+setMethod("hatplot", "qrrvglm", function(model, ...)
+ hatplot.vlm(model, ...))
+setMethod("hatplot", "cao", function(model, ...)
+ hatplot.vlm(model, ...))
+setMethod("hatplot", "rcam", function(model, ...)
+ hatplot.vlm(model, ...))
+
+
+
+
+
+
+
+
+dfbetavlm <-
+ function(model,
+ maxit.new = 1,
+ trace.new = FALSE,
+ smallno = 1.0e-8,
+ ...) {
+
+ if (!is(model, "vlm"))
+ stop("argument 'model' does not seem to be a vglm() object")
+
+ n_lm = nobs(model, type = "lm")
+ X_lm = model.matrix(model, type = "lm")
+ X_vlm = model.matrix(model, type = "vlm")
+ p_vlm = ncol(X_vlm) # nvar(model, type = "vlm")
+ M = npred(model)
+ wz = weights(model, type = "work") # zz unused!!!!!!!
+ etastart = predict(model)
+ offset = matrix(model at offset, n_lm, M)
+ new.control = model at control
+ pweights <- weights(model, type = "prior")
+ orig.w <- if (is.numeric(model at extra$orig.w))
+ model at extra$orig.w else 1
+ y.integer <- if (is.logical(model at extra$y.integer))
+ model at extra$y.integer else FALSE
+
+
+ new.control$trace = trace.new
+ new.control$maxit = maxit.new
+
+ dfbeta <- matrix(0, n_lm, p_vlm)
+
+ Terms.zz <- NULL
+
+
+
+
+
+ for (ii in 1:n_lm) {
+ if (trace.new) {
+ cat("\n", "Observation ", ii, "\n")
+ flush.console()
+ }
+
+ w.orig = if (length(orig.w) != n_lm)
+ rep(orig.w, length.out = n_lm) else
+ orig.w
+ w.orig[ii] = w.orig[ii] * smallno # Relative
+
+ fit <- vglm.fit(x = X_lm,
+ X_vlm_arg = X_vlm, # Should be more efficient
+ y = if (y.integer)
+ round(depvar(model) * c(pweights) / c(orig.w)) else
+ (depvar(model) * c(pweights) / c(orig.w)),
+ w = w.orig, # Set to zero so that it is 'deleted'.
+ Xm2 = NULL, Ym2 = NULL,
+ etastart = etastart, # coefstart = NULL,
+ offset = offset,
+ family = model at family,
+ control = new.control,
+ criterion = new.control$criterion, # "coefficients",
+ qr.arg = FALSE,
+ constraints = constraints(model, type = "lm"),
+ extra = model at extra,
+ Terms = Terms.zz,
+ function.name = "vglm")
+
+ dfbeta[ii, ] <- fit$coeff
+ }
+
+
+ dimnames(dfbeta) <- list(rownames(X_lm), names(coef(model)))
+ dfbeta
+}
+
+
+
+
+if (!isGeneric("dfbeta"))
+ setGeneric("dfbeta", function(model, ...)
+ standardGeneric("dfbeta"), package = "VGAM")
+
+
+setMethod("dfbeta", "matrix", function(model, ...)
+ dfbetavlm(model, ...))
+
+setMethod("dfbeta", "vlm", function(model, ...)
+ dfbetavlm(model, ...))
+setMethod("dfbeta", "vglm", function(model, ...)
+ dfbetavlm(model, ...))
+
+setMethod("dfbeta", "rrvglm", function(model, ...)
+ dfbetavlm(model, ...))
+setMethod("dfbeta", "qrrvglm", function(model, ...)
+ dfbetavlm(model, ...))
+setMethod("dfbeta", "cao", function(model, ...)
+ dfbetavlm(model, ...))
+setMethod("dfbeta", "rcam", function(model, ...)
+ dfbetavlm(model, ...))
+
+
+
+
diff --git a/R/mux.q b/R/mux.q
index 4bfcadf..6b4620c 100644
--- a/R/mux.q
+++ b/R/mux.q
@@ -5,8 +5,7 @@
-mux34 <- function(xmat, cc, symmetric = FALSE)
-{
+mux34 <- function(xmat, cc, symmetric = FALSE) {
if (!is.matrix(xmat))
@@ -23,9 +22,10 @@ mux34 <- function(xmat, cc, symmetric = FALSE)
}
+
+
if(FALSE)
-mux34 <- function(xmat, cc, symmetric = FALSE)
-{
+mux34 <- function(xmat, cc, symmetric = FALSE) {
if (!is.matrix(xmat))
xmat <- as.matrix(xmat)
@@ -44,8 +44,7 @@ mux34 <- function(xmat, cc, symmetric = FALSE)
-mux2 <- function(cc, xmat)
-{
+mux2 <- function(cc, xmat) {
if (!is.matrix(xmat))
@@ -67,8 +66,11 @@ mux2 <- function(cc, xmat)
}
-mux22 <- function(cc, xmat, M, upper = FALSE, as.matrix = FALSE)
-{
+
+
+
+
+mux22 <- function(cc, xmat, M, upper = FALSE, as.matrix = FALSE) {
n <- ncol(cc)
@@ -89,58 +91,62 @@ mux22 <- function(cc, xmat, M, upper = FALSE, as.matrix = FALSE)
-mux5 <- function(cc, x, M, matrix.arg = FALSE)
-{
+mux5 <- function(cc, x, M, matrix.arg = FALSE) {
- dimx <- dim(x)
- dimcc <- dim(cc)
- r <- dimx[2]
- if (matrix.arg) {
- n <- dimcc[1]
- neltscci <- ncol(cc)
- cc <- t(cc)
- } else {
- n <- dimcc[3]
- if (dimcc[1]!= dimcc[2] || dimx[1]!= dimcc[1] ||
- (length(dimx) == 3 && dimx[3]!= dimcc[3]))
- stop('input nonconformable')
- neltscci <- M*(M+1)/2
- }
- if (is.matrix(x))
- x <- array(x,c(M,r,n))
- index.M <- iam(NA, NA, M, both = TRUE, diag = TRUE)
- index.r <- iam(NA, NA, r, both = TRUE, diag = TRUE)
-
- size <- if (matrix.arg) dimm(r)*n else r*r*n
- fred <- dotC(name = "mux5", as.double(cc), as.double(x),
- ans = double(size),
- as.integer(M), as.integer(n), as.integer(r),
- as.integer(neltscci),
- as.integer(dimm(r)),
- as.integer(as.numeric(matrix.arg)),
- double(M*M), double(r*r),
- as.integer(index.M$row), as.integer(index.M$col),
- as.integer(index.r$row), as.integer(index.r$col),
- ok3 = as.integer(1), NAOK = TRUE)
- if (fred$ok3 == 0) stop("can only handle matrix.arg == 1")
+ dimx <- dim(x)
+ dimcc <- dim(cc)
+ r <- dimx[2]
+
+ if (matrix.arg) {
+ n <- dimcc[1]
+ neltscci <- ncol(cc)
+ cc <- t(cc)
+ } else {
+ n <- dimcc[3]
+ if (dimcc[1]!= dimcc[2] ||
+ dimx[1]!= dimcc[1] ||
+ (length(dimx) == 3 && dimx[3]!= dimcc[3]))
+ stop('input nonconformable')
+ neltscci <- M*(M+1)/2
+ }
+
+ if (is.matrix(x))
+ x <- array(x,c(M, r, n))
+ index.M <- iam(NA, NA, M, both = TRUE, diag = TRUE)
+ index.r <- iam(NA, NA, r, both = TRUE, diag = TRUE)
+
+ size <- if (matrix.arg) dimm(r)*n else r*r*n
+ fred <- dotC(name = "mux5", as.double(cc), as.double(x),
+ ans = double(size),
+ as.integer(M), as.integer(n), as.integer(r),
+ as.integer(neltscci),
+ as.integer(dimm(r)),
+ as.integer(as.numeric(matrix.arg)),
+ double(M*M), double(r*r),
+ as.integer(index.M$row), as.integer(index.M$col),
+ as.integer(index.r$row), as.integer(index.r$col),
+ ok3 = as.integer(1), NAOK = TRUE)
+ if (fred$ok3 == 0)
+ stop("can only handle matrix.arg == 1")
- if (matrix.arg) {
- ans <- fred$ans
- dim(ans) <- c(dimm(r), n)
- t(ans)
- } else {
- array(fred$ans, c(r,r,n))
- }
+ if (matrix.arg) {
+ ans <- fred$ans
+ dim(ans) <- c(dimm(r), n)
+ t(ans)
+ } else {
+ array(fred$ans, c(r, r, n))
+ }
}
-mux55 <- function(evects, evals, M)
-{
+
+
+mux55 <- function(evects, evals, M) {
d <- dim(evects)
n <- ncol(evals)
@@ -160,8 +166,9 @@ mux55 <- function(evects, evals, M)
}
-mux7 <- function(cc, x)
-{
+
+
+mux7 <- function(cc, x) {
dimx <- dim(x)
dimcc <- dim(cc)
@@ -173,108 +180,115 @@ mux7 <- function(cc, x)
n <- dimcc[3]
r <- dimx[2]
if (is.matrix(x))
- x <- array(x,c(qq,r,n))
+ x <- array(x,c(qq,r, n))
- ans <- array(NA, c(M,r,n))
+ ans <- array(NA, c(M, r, n))
fred <- dotC(name = "mux7", as.double(cc), as.double(x),
ans = as.double(ans),
as.integer(M), as.integer(qq), as.integer(n),
as.integer(r), NAOK = TRUE)
- array(fred$ans,c(M,r,n))
+ array(fred$ans,c(M, r, n))
}
-mux9 <- function(cc, xmat)
-{
- if (is.vector(xmat))
- xmat <- cbind(xmat)
- dimxmat <- dim(xmat)
- dimcc <- dim(cc)
- if (dimcc[1]!= dimcc[2] || dimxmat[1]!= dimcc[3] || dimxmat[2]!= dimcc[1])
- stop('input nonconformable')
- M <- dimcc[1]
- n <- dimcc[3]
+mux9 <- function(cc, xmat) {
- ans <- matrix(as.numeric(NA),n,M)
- fred <- dotC(name = "mux9", as.double(cc), as.double(xmat),
- ans = as.double(ans),
- as.integer(M), as.integer(n), NAOK = TRUE)
- matrix(fred$ans,n,M)
+ if (is.vector(xmat))
+ xmat <- cbind(xmat)
+ dimxmat <- dim(xmat)
+ dimcc <- dim(cc)
+
+ if (dimcc[1] != dimcc[2] ||
+ dimxmat[1] != dimcc[3] ||
+ dimxmat[2] != dimcc[1])
+ stop('input nonconformable')
+ M <- dimcc[1]
+ n <- dimcc[3]
+
+ ans <- matrix(as.numeric(NA), n, M)
+ fred <- dotC(name = "mux9", as.double(cc), as.double(xmat),
+ ans = as.double(ans),
+ as.integer(M), as.integer(n), NAOK = TRUE)
+ matrix(fred$ans, n, M)
}
-mux11 <- function(cc, xmat)
-{
- dcc <- dim(cc)
- d <- dim(xmat)
- M <- dcc[1]
- R <- d[2]
- n <- dcc[3]
- if (M!= dcc[2] || d[1]!= n*M)
- stop("input inconformable")
-
- Xmat <- array(c(t(xmat)), c(R,M,n))
- Xmat <- aperm(Xmat, c(2,1,3)) # Xmat becomes M x R x n
- mat <- mux7(cc, Xmat) # mat is M x R x n
- mat <- aperm(mat, c(2,1,3)) # mat becomes R x M x n
- mat <- matrix(c(mat), n*M, R, byrow = TRUE)
- mat
+mux11 <- function(cc, xmat) {
+
+
+ dcc <- dim(cc)
+ d <- dim(xmat)
+ M <- dcc[1]
+ R <- d[2]
+ n <- dcc[3]
+ if (M != dcc[2] || d[1] != n*M)
+ stop("input inconformable")
+
+ Xmat <- array(c(t(xmat)), c(R, M, n))
+ Xmat <- aperm(Xmat, c(2, 1, 3)) # Xmat becomes M x R x n
+ mat <- mux7(cc, Xmat) # mat is M x R x n
+ mat <- aperm(mat, c(2, 1, 3)) # mat becomes R x M x n
+ mat <- matrix(c(mat), n*M, R, byrow = TRUE)
+ mat
}
-mux111 <- function(cc, xmat, M, upper = TRUE)
-{
+mux111 <- function(cc, xmat, M, upper = TRUE) {
- R <- ncol(xmat)
- n <- nrow(xmat) / M
- index <- iam(NA, NA, M, both = TRUE, diag = TRUE)
- dimm.value <- nrow(cc) # M or M(M+1)/2
+ R <- ncol(xmat)
+ n <- nrow(xmat) / M
+ index <- iam(NA, NA, M, both = TRUE, diag = TRUE)
+ dimm.value <- nrow(cc) # M or M(M+1)/2
- fred <- dotC(name = "mux111", as.double(cc), b = as.double(t(xmat)),
- as.integer(M),
- as.integer(R), as.integer(n), wk = double(M*M),
- wk2 = double(M*R), as.integer(index$row),
- as.integer(index$col), as.integer(dimm.value),
- as.integer(as.numeric(upper)), NAOK = TRUE)
+ fred <- dotC(name = "mux111", as.double(cc),
+ b = as.double(t(xmat)),
+ as.integer(M),
+ as.integer(R), as.integer(n), wk = double(M * M),
+ wk2 = double(M * R), as.integer(index$row),
+ as.integer(index$col), as.integer(dimm.value),
+ as.integer(as.numeric(upper)), NAOK = TRUE)
- ans <- fred$b
- dim(ans) <- c(R, nrow(xmat))
- d <- dimnames(xmat)
- dimnames(ans) <- list(d[[2]], d[[1]])
- t(ans)
+ ans <- fred$b
+ dim(ans) <- c(R, nrow(xmat))
+ d <- dimnames(xmat)
+ dimnames(ans) <- list(d[[2]], d[[1]])
+ t(ans)
}
-mux15 <- function(cc, xmat)
-{
- n <- nrow(xmat)
- M <- ncol(xmat)
- if (nrow(cc) != M || ncol(cc) != M)
- stop("input inconformable")
- if (max(abs(t(cc)-cc))>0.000001)
- stop("argument 'cc' is not symmetric")
-
- ans <- rep(as.numeric(NA),n*M*M)
- fred <- dotC(name = "mux15", as.double(cc), as.double(t(xmat)),
- ans = as.double(ans), as.integer(M),
- as.integer(n), NAOK = TRUE)
- array(fred$ans,c(M,M,n))
+
+
+
+mux15 <- function(cc, xmat) {
+ n <- nrow(xmat)
+ M <- ncol(xmat)
+ if (nrow(cc) != M || ncol(cc) != M)
+ stop("input inconformable")
+ if (max(abs(t(cc)-cc))>0.000001)
+ stop("argument 'cc' is not symmetric")
+
+ ans <- rep(as.numeric(NA),n*M*M)
+ fred <- dotC(name = "mux15", as.double(cc), as.double(t(xmat)),
+ ans = as.double(ans), as.integer(M),
+ as.integer(n), NAOK = TRUE)
+ array(fred$ans,c(M,M,n))
}
+
+
-vforsub <- function(cc, b, M, n)
-{
+vforsub <- function(cc, b, M, n) {
@@ -294,8 +308,7 @@ vforsub <- function(cc, b, M, n)
-vbacksub <- function(cc, b, M, n)
-{
+vbacksub <- function(cc, b, M, n) {
index <- iam(NA, NA, M, both = TRUE, diag = TRUE)
dimm.value <- nrow(cc)
if (nrow(b)!= M || ncol(b)!= n)
diff --git a/R/predict.vlm.q b/R/predict.vlm.q
index 608f194..1c099e9 100644
--- a/R/predict.vlm.q
+++ b/R/predict.vlm.q
@@ -301,6 +301,56 @@ setMethod("predict", "vlm",
+
+
+
+
+predict.vglm.se <- function(fit, ...) {
+
+
+ H_ss <- hatvalues(fit, type = "centralBlocks") # diag = FALSE
+
+ M = npred(fit)
+ nn = nobs(fit, type = "lm")
+ U <- vchol(weights(fit, type = "working"), M = M, n = nn)
+
+ Uarray = array(0, c(M, M, nn))
+ ind1 <- iam(NA, NA, M = M, both = TRUE, diag = TRUE)
+ MM12 = M * (M + 1) / 2
+ for (jay in 1:MM12)
+ Uarray[ind1$row.index[jay],
+ ind1$col.index[jay], ] <- U[jay,]
+
+ Uinv.array <- apply(Uarray, 3, backsolve, x = diag(M))
+ dim(Uinv.array) <- c(M, M, nn)
+
+ Utinv.array <- Uinv.array
+ if (M > 1)
+ for (jay in 1:(M-1)) {
+ for (kay in (jay+1):M) {
+ Utinv.array[kay, jay, ] <- Uinv.array[jay, kay, ]
+ Utinv.array[jay, kay, ] <- 0
+ }
+ }
+
+ var.boldeta_i <- mux5(H_ss, Utinv.array, M = M,
+ matrix.arg = TRUE) # First M cols are SE^2
+
+ sqrt(var.boldeta_i[, 1:M]) # SE(linear.predictor)
+
+
+
+
+ sqrt(var.boldeta_i[, 1:M])
+}
+
+
+
+
+
+
+
+
subconstraints = function(assign, constraints) {
diff --git a/R/vglm.R b/R/vglm.R
index 89368d4..1b19f71 100644
--- a/R/vglm.R
+++ b/R/vglm.R
@@ -17,45 +17,46 @@ vglm <- function(formula,
constraints = NULL,
extra = list(),
form2 = NULL,
- qr.arg = FALSE, smart = TRUE, ...)
+ qr.arg = TRUE, smart = TRUE, ...)
{
- dataname <- as.character(substitute(data)) # "list" if no data=
- function.name <- "vglm"
+ dataname <- as.character(substitute(data)) # "list" if no data=
+ function.name <- "vglm"
- ocall <- match.call()
+ ocall <- match.call()
- if (smart)
- setup.smart("write")
+ if (smart)
+ setup.smart("write")
- if (missing(data))
- data <- environment(formula)
+ if (missing(data))
+ data <- environment(formula)
- mf <- match.call(expand.dots = FALSE)
- m <- match(c("formula", "data", "subset", "weights", "na.action",
- "etastart", "mustart", "offset"), names(mf), 0)
- mf <- mf[c(1, m)]
- mf$drop.unused.levels <- TRUE
- mf[[1]] <- as.name("model.frame")
- mf <- eval(mf, parent.frame())
- switch(method, model.frame = return(mf), vglm.fit = 1,
- stop("invalid 'method': ", method))
- mt <- attr(mf, "terms")
+ mf <- match.call(expand.dots = FALSE)
+ m <- match(c("formula", "data", "subset", "weights", "na.action",
+ "etastart", "mustart", "offset"), names(mf), 0)
+ mf <- mf[c(1, m)]
+ mf$drop.unused.levels <- TRUE
+ mf[[1]] <- as.name("model.frame")
+ mf <- eval(mf, parent.frame())
+ switch(method, model.frame = return(mf), vglm.fit = 1,
+ stop("invalid 'method': ", method))
+ mt <- attr(mf, "terms")
- xlev = .getXlevels(mt, mf)
- y <- model.response(mf, "any") # model.extract(mf, "response")
- x <- if (!is.empty.model(mt)) model.matrix(mt, mf, contrasts) else
- matrix(, NROW(y), 0)
- attr(x, "assign") = attrassigndefault(x, mt)
+ xlev = .getXlevels(mt, mf)
+ y <- model.response(mf, "any") # model.extract(mf, "response")
+ x <- if (!is.empty.model(mt)) model.matrix(mt, mf, contrasts) else
+ matrix(, NROW(y), 0)
+ attr(x, "assign") = attrassigndefault(x, mt)
-if (!is.null(form2)) {
+ if (!is.null(form2)) {
if (!is.null(subset))
- stop("argument 'subset' cannot be used when argument 'form2' is used")
+ stop("argument 'subset' cannot be used when ",
+ "argument 'form2' is used")
retlist = shadowvglm(formula =
form2,
family = family, data = data,
@@ -71,141 +72,141 @@ if (!is.null(form2)) {
Xm2 <- retlist$Xm2
if (length(Ym2)) {
- if (nrow(as.matrix(Ym2)) != nrow(as.matrix(y)))
- stop("number of rows of 'y' and 'Ym2' are unequal")
+ if (nrow(as.matrix(Ym2)) != nrow(as.matrix(y)))
+ stop("number of rows of 'y' and 'Ym2' are unequal")
}
if (length(Xm2)) {
- if (nrow(as.matrix(Xm2)) != nrow(as.matrix(x)))
- stop("number of rows of 'y' and 'Ym2' are unequal")
+ if (nrow(as.matrix(Xm2)) != nrow(as.matrix(x)))
+ stop("number of rows of 'y' and 'Ym2' are unequal")
}
-} else {
+ } else {
Xm2 = Ym2 = NULL
-}
-
-
- offset <- model.offset(mf)
- if (is.null(offset))
- offset <- 0 # yyy ???
- w <- model.weights(mf)
- if (!length(w)) {
- w <- rep(1, nrow(mf))
- } else
- if (ncol(as.matrix(w)) == 1 && any(w < 0))
- stop("negative weights not allowed")
-
- if (is.character(family))
- family <- get(family)
- if (is.function(family))
- family <- family()
- if (!inherits(family, "vglmff")) {
- stop("'family = ", family, "' is not a VGAM family function")
+ }
+
+
+ offset <- model.offset(mf)
+ if (is.null(offset))
+ offset <- 0 # yyy ???
+ w <- model.weights(mf)
+ if (!length(w)) {
+ w <- rep(1, nrow(mf))
+ } else
+ if (ncol(as.matrix(w)) == 1 && any(w < 0))
+ stop("negative weights not allowed")
+
+ if (is.character(family))
+ family <- get(family)
+ if (is.function(family))
+ family <- family()
+ if (!inherits(family, "vglmff")) {
+ stop("'family = ", family, "' is not a VGAM family function")
+ }
+
+ eval(vcontrol.expression)
+
+ if (length(slot(family, "first")))
+ eval(slot(family, "first"))
+
+
+ vglm.fitter <- get(method)
+
+ fit <- vglm.fitter(x = x, y = y, w = w, offset = offset,
+ Xm2 = Xm2, Ym2 = Ym2,
+ etastart = etastart, mustart = mustart, coefstart = coefstart,
+ family = family,
+ control = control,
+ constraints = constraints,
+ criterion = control$criterion,
+ extra = extra,
+ qr.arg = qr.arg,
+ Terms = mt, function.name = function.name, ...)
+
+ fit$misc$dataname <- dataname
+
+ if (smart) {
+ fit$smart.prediction <- get.smart.prediction()
+ wrapup.smart()
+ }
+
+ answer <-
+ new(Class = "vglm",
+ "assign" = attr(x, "assign"),
+ "call" = ocall,
+ "coefficients" = fit$coefficients,
+ "constraints" = fit$constraints,
+ "criterion" = fit$crit.list,
+ "df.residual" = fit$df.residual,
+ "df.total" = fit$df.total,
+ "dispersion" = 1,
+ "effects" = fit$effects,
+ "family" = fit$family,
+ "misc" = fit$misc,
+ "model" = if (model) mf else data.frame(),
+ "R" = fit$R,
+ "rank" = fit$rank,
+ "residuals" = as.matrix(fit$residuals),
+ "rss" = fit$rss,
+ "smart.prediction" = as.list(fit$smart.prediction),
+ "terms" = list(terms = mt))
+
+ if (!smart) answer at smart.prediction <- list(smart.arg = FALSE)
+
+ if (qr.arg) {
+ class(fit$qr) = "list"
+ slot(answer, "qr") = fit$qr
+ }
+ if (length(attr(x, "contrasts")))
+ slot(answer, "contrasts") = attr(x, "contrasts")
+ if (length(fit$fitted.values))
+ slot(answer, "fitted.values") = as.matrix(fit$fitted.values)
+ slot(answer, "na.action") = if (length(aaa <- attr(mf, "na.action")))
+ list(aaa) else list()
+ if (length(offset))
+ slot(answer, "offset") = as.matrix(offset)
+
+ if (length(fit$weights))
+ slot(answer, "weights") = as.matrix(fit$weights)
+
+ if (x.arg)
+ slot(answer, "x") = fit$x # The 'small' (lm) design matrix
+ if (x.arg && length(Xm2))
+ slot(answer, "Xm2") = Xm2 # The second (lm) design matrix
+ if (y.arg && length(Ym2))
+ slot(answer, "Ym2") = as.matrix(Ym2) # The second response
+ if (!is.null(form2))
+ slot(answer, "callXm2") = retlist$call
+ answer at misc$formula = formula
+ answer at misc$form2 = form2
+
+ if (length(xlev))
+ slot(answer, "xlevels") = xlev
+ if (y.arg)
+ slot(answer, "y") = as.matrix(fit$y)
+
+
+ slot(answer, "control") = fit$control
+ slot(answer, "extra") = if (length(fit$extra)) {
+ if (is.list(fit$extra)) fit$extra else {
+ warning("'extra' is not a list, therefore placing ",
+ "'extra' into a list")
+ list(fit$extra)
}
-
- eval(vcontrol.expression)
-
- if (length(slot(family, "first")))
- eval(slot(family, "first"))
+ } else list() # R-1.5.0
+ slot(answer, "iter") = fit$iter
+ slot(answer, "post") = fit$post
- vglm.fitter <- get(method)
+ fit$predictors = as.matrix(fit$predictors) # Must be a matrix
- fit <- vglm.fitter(x = x, y = y, w = w, offset = offset,
- Xm2 = Xm2, Ym2 = Ym2,
- etastart = etastart, mustart = mustart, coefstart = coefstart,
- family = family,
- control = control,
- constraints = constraints,
- criterion = control$criterion,
- extra = extra,
- qr.arg = qr.arg,
- Terms = mt, function.name = function.name, ...)
+ 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)
- fit$misc$dataname <- dataname
- if (smart) {
- fit$smart.prediction <- get.smart.prediction()
- wrapup.smart()
- }
-
- answer <-
- new(Class = "vglm",
- "assign" = attr(x, "assign"),
- "call" = ocall,
- "coefficients" = fit$coefficients,
- "constraints" = fit$constraints,
- "criterion" = fit$crit.list,
- "df.residual" = fit$df.residual,
- "df.total" = fit$df.total,
- "dispersion" = 1,
- "effects" = fit$effects,
- "family" = fit$family,
- "misc" = fit$misc,
- "model" = if (model) mf else data.frame(),
- "R" = fit$R,
- "rank" = fit$rank,
- "residuals" = as.matrix(fit$residuals),
- "rss" = fit$rss,
- "smart.prediction" = as.list(fit$smart.prediction),
- "terms" = list(terms = mt))
-
- if (!smart) answer at smart.prediction <- list(smart.arg = FALSE)
-
- if (qr.arg) {
- class(fit$qr) = "list"
- slot(answer, "qr") = fit$qr
- }
- if (length(attr(x, "contrasts")))
- slot(answer, "contrasts") = attr(x, "contrasts")
- if (length(fit$fitted.values))
- slot(answer, "fitted.values") = as.matrix(fit$fitted.values)
- slot(answer, "na.action") = if (length(aaa <- attr(mf, "na.action")))
- list(aaa) else list()
- if (length(offset))
- slot(answer, "offset") = as.matrix(offset)
-
- if (length(fit$weights))
- slot(answer, "weights") = as.matrix(fit$weights)
-
- if (x.arg)
- slot(answer, "x") = fit$x # The 'small' (lm) design matrix
- if (x.arg && length(Xm2))
- slot(answer, "Xm2") = Xm2 # The second (lm) design matrix
- if (y.arg && length(Ym2))
- slot(answer, "Ym2") = as.matrix(Ym2) # The second response
- if (!is.null(form2))
- slot(answer, "callXm2") = retlist$call
- answer at misc$formula = formula
- answer at misc$form2 = form2
-
- if (length(xlev))
- slot(answer, "xlevels") = xlev
- if (y.arg)
- slot(answer, "y") = as.matrix(fit$y)
-
-
- slot(answer, "control") = fit$control
- slot(answer, "extra") = if (length(fit$extra)) {
- if (is.list(fit$extra)) fit$extra else {
- warning("'extra' is not a list, therefore placing ",
- "'extra' into a list")
- list(fit$extra)
- }
- } 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
-
- 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)
-
-
- answer
+ answer
}
attr(vglm, "smart") <- TRUE
diff --git a/R/vglm.control.q b/R/vglm.control.q
index 3bc3e42..83c1936 100644
--- a/R/vglm.control.q
+++ b/R/vglm.control.q
@@ -37,6 +37,7 @@ vglm.control <- function(checkwz = TRUE,
epsilon = 1e-7,
half.stepsizing = TRUE,
maxit = 30,
+ nowarning = FALSE,
stepsize = 1,
save.weight = FALSE,
trace = FALSE,
@@ -91,6 +92,7 @@ vglm.control <- function(checkwz = TRUE,
epsilon = epsilon,
half.stepsizing = as.logical(half.stepsizing)[1],
maxit = maxit,
+ nowarning = as.logical(nowarning)[1],
min.criterion = .min.criterion.VGAM,
save.weight = as.logical(save.weight)[1],
stepsize = stepsize,
diff --git a/R/vglm.fit.q b/R/vglm.fit.q
index f3f9963..bc9a96a 100644
--- a/R/vglm.fit.q
+++ b/R/vglm.fit.q
@@ -4,418 +4,449 @@
-vglm.fit <- function(x, y, w=rep(1, length(x[, 1])),
+
+
+
+vglm.fit <- function(x, y, w = rep(1, length(x[, 1])),
+ X_vlm_arg = NULL,
Xm2 = NULL, Ym2 = NULL,
etastart = NULL, mustart = NULL, coefstart = NULL,
offset = 0, family,
- control=vglm.control(),
+ control = vglm.control(),
criterion = "coefficients",
qr.arg = FALSE,
constraints = NULL,
extra = NULL,
- Terms=Terms, function.name = "vglm", ...)
+ Terms = Terms, function.name = "vglm", ...)
{
- specialCM = NULL
- post = list()
- check.rank <- TRUE # Set this to false for family functions vppr() etc.
- nonparametric <- FALSE
- epsilon <- control$epsilon
- maxit <- control$maxit
- save.weight <- control$save.weight
- trace <- control$trace
- orig.stepsize <- control$stepsize
- minimize.criterion <- control$min.criterion
-
-
-
- n <- dim(x)[1]
-
- new.s.call <- expression({
- if (c.list$one.more) {
- fv <- c.list$fit
- new.coeffs <- c.list$coeff
-
- if (length(slot(family, "middle")))
- eval(slot(family, "middle"))
-
- eta <- fv + offset
- mu <- slot(family, "linkinv")(eta, extra)
-
- if (length(slot(family, "middle2")))
- eval(slot(family, "middle2"))
-
- old.crit <- new.crit
- new.crit <-
- switch(criterion,
- coefficients = new.coeffs,
- tfun(mu = mu, y = y, w = w, res = FALSE, eta = eta, extra))
-
-
- if (trace && orig.stepsize == 1) {
- cat("VGLM linear loop ", iter, ": ", criterion, "= ")
- UUUU =
- switch(criterion,
- coefficients = format(new.crit, dig = round(2-log10(epsilon))),
- format(round(new.crit, 4)))
-
- switch(criterion,
- coefficients = {if(length(new.crit) > 2) cat("\n");
- cat(UUUU, fill = TRUE, sep = ", ")},
- cat(UUUU, fill = TRUE, sep = ", "))
- }
-
-
- {
- take.half.step = (control$half.stepsizing &&
- length(old.coeffs)) &&
- ((orig.stepsize != 1) ||
- (criterion != "coefficients" &&
- (if(minimize.criterion) new.crit > old.crit else
- new.crit < old.crit)))
- if (!is.logical(take.half.step))
- take.half.step = TRUE
- if (take.half.step) {
- stepsize <- 2 * min(orig.stepsize, 2*stepsize)
- new.coeffs.save <- new.coeffs
- if (trace)
- cat("Taking a modified step")
- repeat {
- if (trace) {
- cat(".")
- flush.console()
- }
- stepsize <- stepsize / 2
- if (too.small <- stepsize < 0.001)
- break
- new.coeffs <- (1-stepsize)*old.coeffs +
- stepsize*new.coeffs.save
-
- if (length(slot(family, "middle")))
- eval(slot(family, "middle"))
-
- fv <- X_vlm_save %*% new.coeffs
- if (M > 1)
- fv <- matrix(fv, n, M, byrow = TRUE)
-
- eta <- fv + offset
- mu <- slot(family, "linkinv")(eta, extra)
-
- if (length(slot(family, "middle2")))
- eval(slot(family, "middle2"))
-
-
- new.crit <-
- switch(criterion,
- coefficients = new.coeffs,
- tfun(mu = mu,y = y,w = w,res = FALSE,eta = eta,extra))
-
- if ((criterion == "coefficients") ||
- ( minimize.criterion && new.crit < old.crit) ||
- (!minimize.criterion && new.crit > old.crit))
- break
- } # of repeat
-
- if (trace)
- cat("\n")
- if (too.small) {
- warning("iterations terminated because ",
- "half-step sizes are very small")
- one.more <- FALSE
- } else {
- if (trace) {
- cat("VGLM linear loop ",
- iter, ": ", criterion, "= ")
-
- UUUU = switch(criterion,
- coefficients = format(new.crit,
- dig = round(2-log10(epsilon))),
- format(round(new.crit, 4)))
-
- switch(criterion,
- coefficients = {
- if(length(new.crit) > 2) cat("\n");
- cat(UUUU, fill = TRUE, sep = ", ")},
- cat(UUUU, fill = TRUE, sep = ", "))
- }
-
- one.more <- eval(control$convergence)
- }
- } else {
- one.more <- eval(control$convergence)
- }
- }
- flush.console()
-
- if (!is.logical(one.more)) one.more = FALSE
- if (one.more) {
- iter <- iter + 1
- deriv.mu <- eval(slot(family, "deriv"))
- wz <- eval(slot(family, "weight"))
- if (control$checkwz)
- wz = checkwz(wz, M = M, trace = trace,
- wzepsilon = control$wzepsilon)
-
- U <- vchol(wz, M = M, n = n, silent=!trace)
- tvfor <- vforsub(U, as.matrix(deriv.mu), M = M, n = n)
- z <- eta + vbacksub(U, tvfor, M = M, n = n) - offset
-
- c.list$z <- z
- c.list$U <- U
- if (copy_X_vlm) c.list$X_vlm <- X_vlm_save
- }
-
- c.list$one.more <- one.more
- c.list$coeff = runif(length(new.coeffs)) # 12/3/03; twist needed!
- old.coeffs <- new.coeffs
- }
- c.list
- })
-
-
-
-
-
- copy_X_vlm <- FALSE # May be overwritten in @initialize
- stepsize <- orig.stepsize
- old.coeffs <- coefstart
-
- intercept.only <- ncol(x) == 1 && dimnames(x)[[2]] == "(Intercept)"
- y.names <- predictors.names <- NULL # May be overwritten in @initialize
-
- n.save <- n
-
-
- if (length(slot(family, "initialize")))
- eval(slot(family, "initialize")) # Initialize mu & M (& optionally w)
-
-
- if (length(etastart)) {
- eta <- etastart
- mu <- if (length(mustart)) mustart else
- if (length(body(slot(family, "linkinv"))))
- slot(family, "linkinv")(eta, extra) else
- warning("argument 'etastart' assigned a value ",
- "but there is no 'linkinv' slot to use it")
+ specialCM = NULL
+ post = list()
+ check.rank <- TRUE # Set this to false for family functions vppr() etc.
+ nonparametric <- FALSE
+ epsilon <- control$epsilon
+ maxit <- control$maxit
+ save.weight <- control$save.weight
+ trace <- control$trace
+ orig.stepsize <- control$stepsize
+ minimize.criterion <- control$min.criterion
+
+
+
+ n <- dim(x)[1]
+
+ new.s.call <- expression({
+ if (c.list$one.more) {
+ fv <- c.list$fit
+ new.coeffs <- c.list$coeff
+
+ if (length(slot(family, "middle")))
+ eval(slot(family, "middle"))
+
+ eta <- fv + offset
+ mu <- slot(family, "linkinv")(eta, extra)
+
+ if (length(slot(family, "middle2")))
+ eval(slot(family, "middle2"))
+
+ old.crit <- new.crit
+ new.crit <-
+ switch(criterion,
+ coefficients = new.coeffs,
+ tfun(mu = mu, y = y, w = w,
+ res = FALSE, eta = eta, extra))
+
+
+ if (trace && orig.stepsize == 1) {
+ cat("VGLM linear loop ", iter, ": ", criterion, "= ")
+ UUUU =
+ switch(criterion,
+ coefficients = format(new.crit,
+ dig = round(2 - log10(epsilon))),
+ format(round(new.crit, 4)))
+
+ switch(criterion,
+ coefficients = {if(length(new.crit) > 2) cat("\n");
+ cat(UUUU, fill = TRUE, sep = ", ")},
+ cat(UUUU, fill = TRUE, sep = ", "))
+ }
+
+
+ {
+ take.half.step =
+ (control$half.stepsizing &&
+ length(old.coeffs)) &&
+ ((orig.stepsize != 1) ||
+ (criterion != "coefficients" &&
+ (if(minimize.criterion) new.crit > old.crit else
+ new.crit < old.crit)))
+ if (!is.logical(take.half.step))
+ take.half.step = TRUE
+ if (take.half.step) {
+ stepsize <- 2 * min(orig.stepsize, 2*stepsize)
+ new.coeffs.save <- new.coeffs
+ if (trace)
+ cat("Taking a modified step")
+ repeat {
+ if (trace) {
+ cat(".")
+ flush.console()
+ }
+ stepsize <- stepsize / 2
+ if (too.small <- stepsize < 0.001)
+ break
+ new.coeffs <- (1-stepsize)*old.coeffs +
+ stepsize*new.coeffs.save
+
+ if (length(slot(family, "middle")))
+ eval(slot(family, "middle"))
+
+ fv <- X_vlm_save %*% new.coeffs
+ if (M > 1)
+ fv <- matrix(fv, n, M, byrow = TRUE)
+
+ eta <- fv + offset
+ mu <- slot(family, "linkinv")(eta, extra)
+
+ if (length(slot(family, "middle2")))
+ eval(slot(family, "middle2"))
+
+
+ new.crit <-
+ switch(criterion,
+ coefficients = new.coeffs,
+ tfun(mu = mu, y = y, w = w,
+ res = FALSE, eta = eta, extra))
+
+ if ((criterion == "coefficients") ||
+ ( minimize.criterion && new.crit < old.crit) ||
+ (!minimize.criterion && new.crit > old.crit))
+ break
+ } # of repeat
+
+ if (trace)
+ cat("\n")
+ if (too.small) {
+ warning("iterations terminated because ",
+ "half-step sizes are very small")
+ one.more <- FALSE
+ } else {
+ if (trace) {
+ cat("VGLM linear loop ",
+ iter, ": ", criterion, "= ")
+
+ UUUU = switch(criterion,
+ coefficients = format(new.crit,
+ dig = round(2-log10(epsilon))),
+ format(round(new.crit, 4)))
+
+ switch(criterion,
+ coefficients = {
+ if(length(new.crit) > 2) cat("\n");
+ cat(UUUU, fill = TRUE, sep = ", ")},
+ cat(UUUU, fill = TRUE, sep = ", "))
+ }
+
+ one.more <- eval(control$convergence)
+ }
+ } else {
+ one.more <- eval(control$convergence)
+ }
+ }
+ flush.console()
+
+ if (!is.logical(one.more)) one.more = FALSE
+ if (one.more) {
+ iter <- iter + 1
+ deriv.mu <- eval(slot(family, "deriv"))
+ wz <- eval(slot(family, "weight"))
+ if (control$checkwz)
+ wz = checkwz(wz, M = M, trace = trace,
+ wzepsilon = control$wzepsilon)
+
+ U <- vchol(wz, M = M, n = n, silent = !trace)
+ tvfor <- vforsub(U, as.matrix(deriv.mu), M = M, n = n)
+ z <- eta + vbacksub(U, tvfor, M = M, n = n) - offset
+
+ c.list$z <- z
+ c.list$U <- U
+ if (copy_X_vlm) c.list$X_vlm <- X_vlm_save
+ }
+
+ c.list$one.more <- one.more
+ c.list$coeff = runif(length(new.coeffs)) # 12/3/03; twist needed!
+ old.coeffs <- new.coeffs
}
+ c.list
+ })
+
+
+
+
+
+ copy_X_vlm <- FALSE # May be overwritten in @initialize
+ stepsize <- orig.stepsize
+ old.coeffs <- coefstart
- if (length(mustart)) {
- mu <- mustart
- 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")
- }
+ intercept.only <- ncol(x) == 1 &&
+ dimnames(x)[[2]] == "(Intercept)"
+ y.names <- predictors.names <- NULL # May be overwritten in @initialize
+
+ n.save <- n
+
+
+ if (length(slot(family, "initialize")))
+ eval(slot(family, "initialize")) # Initialize mu & M (& optionally w)
+
+
+ if (length(etastart)) {
+ eta <- etastart
+ mu <- if (length(mustart)) mustart else
+ if (length(body(slot(family, "linkinv"))))
+ slot(family, "linkinv")(eta, extra) else
+ warning("argument 'etastart' assigned a value ",
+ "but there is no 'linkinv' slot to use it")
+ }
+
+ if (length(mustart)) {
+ mu <- mustart
+ 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")
}
+ }
- M <- if (is.matrix(eta)) ncol(eta) else 1
+ M <- if (is.matrix(eta)) ncol(eta) else 1
- if (length(slot(family, "constraints")))
- eval(slot(family, "constraints"))
+ if (length(slot(family, "constraints")))
+ eval(slot(family, "constraints"))
- Blist <- process.constraints(constraints, x, M, specialCM = specialCM)
+ Blist <- process.constraints(constraints, x, M,
+ specialCM = specialCM)
- ncolBlist <- unlist(lapply(Blist, ncol))
- dimB <- sum(ncolBlist)
+ ncolBlist <- unlist(lapply(Blist, ncol))
+ dimB <- sum(ncolBlist)
- X_vlm_save = lm2vlm.model.matrix(x, Blist, xij=control$xij, Xm2=Xm2)
- if (length(coefstart)) {
- 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, "linkinv")(eta, extra)
- }
+ X_vlm_save = if (length(X_vlm_arg)) X_vlm_arg else
+ lm2vlm.model.matrix(x, Blist, xij = control$xij,
+ Xm2 = Xm2)
- if (criterion != "coefficients") {
- tfun <- slot(family, criterion) # family[[criterion]]
- }
- iter <- 1
- new.crit <- switch(criterion,
- coefficients = 1,
- tfun(mu = mu, y = y, w = w, res = FALSE, eta = eta, extra))
- old.crit <- if (minimize.criterion) 10*new.crit+10 else -10*new.crit-10
- deriv.mu <- eval(slot(family, "deriv"))
- wz <- eval(slot(family, "weight"))
- if (control$checkwz)
- wz = checkwz(wz, M = M, trace = trace,
- wzepsilon = control$wzepsilon)
- U <- vchol(wz, M = M, n = n, silent=!trace)
- tvfor <- vforsub(U, as.matrix(deriv.mu), M = M, n = n)
- z <- eta + vbacksub(U, tvfor, M = M, n = n) - offset
- c.list <- list(z=as.double(z), fit=as.double(t(eta)), one.more = TRUE,
- coeff=as.double(rep(1,ncol(X_vlm_save))), U=as.double(U),
- copy_X_vlm=copy_X_vlm,
- X_vlm = if (copy_X_vlm) as.double(X_vlm_save) else
- double(3))
+ if (length(coefstart)) {
+ 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, "linkinv")(eta, extra)
+ }
- dX_vlm <- as.integer(dim(X_vlm_save))
- nrow_X_vlm <- dX_vlm[[1]]
- ncol_X_vlm <- dX_vlm[[2]]
+ if (criterion != "coefficients") {
+ tfun <- slot(family, criterion) # family[[criterion]]
+ }
- if (nrow_X_vlm < ncol_X_vlm)
- stop(ncol_X_vlm, "parameters but only ", nrow_X_vlm, " observations")
+ iter <- 1
+ new.crit <- switch(criterion,
+ coefficients = 1,
+ tfun(mu = mu, y = y, w = w,
+ res = FALSE, eta = eta, extra))
+ old.crit <- if (minimize.criterion)
+ 10*new.crit+10 else
+ -10*new.crit-10
+ deriv.mu <- eval(slot(family, "deriv"))
+ wz <- eval(slot(family, "weight"))
+ if (control$checkwz)
+ wz = checkwz(wz, M = M, trace = trace,
+ wzepsilon = control$wzepsilon)
+ U <- vchol(wz, M = M, n = n, silent = !trace)
+ tvfor <- vforsub(U, as.matrix(deriv.mu), M = M, n = n)
+ z <- eta + vbacksub(U, tvfor, M = M, n = n) - offset
- bf.call <- expression(vlm.wfit(xmat = X_vlm_save, z, Blist = NULL, U = U,
- matrix.out = FALSE, is.vlmX = TRUE,
- qr = qr.arg, xij = NULL))
+ c.list <- list(z = as.double(z), fit = as.double(t(eta)),
+ one.more = TRUE,
+ coeff = as.double(rep(1, ncol(X_vlm_save))),
+ U = as.double(U),
+ copy_X_vlm = copy_X_vlm,
+ X_vlm = if (copy_X_vlm) as.double(X_vlm_save) else
+ double(3))
- while(c.list$one.more) {
- tfit <- eval(bf.call) # fit$smooth.frame is new
+
+ dX_vlm <- as.integer(dim(X_vlm_save))
+ nrow_X_vlm <- dX_vlm[[1]]
+ ncol_X_vlm <- dX_vlm[[2]]
+
+ if (nrow_X_vlm < ncol_X_vlm)
+ stop(ncol_X_vlm, "parameters but only ", nrow_X_vlm,
+ " observations")
+
+
+
+ bf.call <- expression(vlm.wfit(xmat = X_vlm_save, z,
+ Blist = NULL, U = U,
+ matrix.out = FALSE,
+ is.vlmX = TRUE,
+ qr = qr.arg, xij = NULL))
+
+
+ while(c.list$one.more) {
+ tfit <- eval(bf.call) # fit$smooth.frame is new
- c.list$coeff <- tfit$coefficients
+ c.list$coeff <- tfit$coefficients
- tfit$predictors <- tfit$fitted.values
+ tfit$predictors <- tfit$fitted.values
- c.list$fit <- tfit$fitted.values
- c.list <- eval(new.s.call)
- NULL
- }
+ c.list$fit <- tfit$fitted.values
+ c.list <- eval(new.s.call)
+ NULL
+ }
- if (maxit > 1 && iter >= maxit)
- warning("convergence not obtained in ", maxit, " iterations")
+ if (maxit > 1 && iter >= maxit && !control$nowarning)
+ warning("convergence not obtained in ", maxit, " iterations")
- dnrow_X_vlm <- labels(X_vlm_save)
- xnrow_X_vlm <- dnrow_X_vlm[[2]]
- ynrow_X_vlm <- dnrow_X_vlm[[1]]
- if (length(slot(family, "fini")))
- eval(slot(family, "fini"))
+ dnrow_X_vlm <- labels(X_vlm_save)
+ xnrow_X_vlm <- dnrow_X_vlm[[2]]
+ ynrow_X_vlm <- dnrow_X_vlm[[1]]
- if (M > 1)
- tfit$predictors <- matrix(tfit$predictors, n, M)
+ if (length(slot(family, "fini")))
+ eval(slot(family, "fini"))
- coefs <- tfit$coefficients
- asgn <- attr(X_vlm_save, "assign")
+ if (M > 1)
+ tfit$predictors <- matrix(tfit$predictors, n, M)
- names(coefs) <- xnrow_X_vlm
+ coefs <- tfit$coefficients
+ asgn <- attr(X_vlm_save, "assign")
- rank <- tfit$rank
- cnames <- xnrow_X_vlm
+ names(coefs) <- xnrow_X_vlm
- if (check.rank && rank < ncol_X_vlm)
- stop("vglm only handles full-rank models (currently)")
+ rank <- tfit$rank
+ cnames <- xnrow_X_vlm
- R <- tfit$qr$qr[1:ncol_X_vlm, 1:ncol_X_vlm, drop = FALSE]
- R[lower.tri(R)] <- 0
- attributes(R) <- list(dim=c(ncol_X_vlm, ncol_X_vlm),
- dimnames=list(cnames, cnames), rank=rank)
+ if (check.rank && rank < ncol_X_vlm)
+ stop("vglm only handles full-rank models (currently)")
- effects <- tfit$effects
- neff <- rep("", nrow_X_vlm)
- neff[seq(ncol_X_vlm)] <- cnames
- names(effects) <- neff
+ R <- tfit$qr$qr[1:ncol_X_vlm, 1:ncol_X_vlm, drop = FALSE]
+ R[lower.tri(R)] <- 0
+ attributes(R) <- list(dim = c(ncol_X_vlm, ncol_X_vlm),
+ dimnames = list(cnames, cnames), rank=rank)
- dim(tfit$predictors) <- c(n, M)
- dn <- labels(x)
- yn <- dn[[1]]
- xn <- dn[[2]]
+ effects <- tfit$effects
+ neff <- rep("", nrow_X_vlm)
+ neff[seq(ncol_X_vlm)] <- cnames
+ names(effects) <- neff
+ dim(tfit$predictors) <- c(n, M)
+ dn <- labels(x)
+ yn <- dn[[1]]
+ xn <- dn[[2]]
- residuals <- z - tfit$predictors
- if (M == 1) {
- tfit$predictors <- as.vector(tfit$predictors)
- residuals <- as.vector(residuals)
- names(residuals) <- names(tfit$predictors) <- yn
- } else {
- dimnames(residuals) <- dimnames(tfit$predictors) <-
- list(yn, predictors.names)
- }
-
- if (is.matrix(mu)) {
- if (length(dimnames(y)[[2]])) {
- y.names <- dimnames(y)[[2]]
- }
- if (length(dimnames(mu)[[2]])) {
- y.names <- dimnames(mu)[[2]]
- }
- dimnames(mu) <- list(yn, y.names)
- } else {
- names(mu) <- names(fv)
- }
+ residuals <- z - tfit$predictors
+ if (M == 1) {
+ tfit$predictors <- as.vector(tfit$predictors)
+ residuals <- as.vector(residuals)
+ names(residuals) <- names(tfit$predictors) <- yn
+ } else {
+ dimnames(residuals) <- dimnames(tfit$predictors) <-
+ list(yn, predictors.names)
+ }
- df.residual <- nrow_X_vlm - rank
- fit <- list(assign = asgn,
- coefficients = coefs,
- constraints = Blist,
- df.residual = df.residual,
- df.total = n*M,
- effects = effects,
- fitted.values = mu,
- offset = offset,
- rank = rank,
- residuals = residuals,
- R = R,
- terms = Terms) # terms: This used to be done in vglm()
-
- if (qr.arg) {
- fit$qr <- tfit$qr
- dimnames(fit$qr$qr) <- dnrow_X_vlm
+ if (is.matrix(mu)) {
+ if (length(dimnames(y)[[2]])) {
+ y.names <- dimnames(y)[[2]]
}
-
- if (M == 1) {
- wz <- as.vector(wz) # Convert wz into a vector
- } # else
- fit$weights <- if (save.weight) wz else NULL
-
-
- misc <- list(
- colnames.x = xn,
- colnames.X_vlm = xnrow_X_vlm,
- criterion = criterion,
- function.name = function.name,
- intercept.only=intercept.only,
- predictors.names = predictors.names,
- M = M,
- n = n,
- nonparametric = nonparametric,
- nrow_X_vlm = nrow_X_vlm,
- orig.assign = attr(x, "assign"),
- p = ncol(x),
- ncol_X_vlm = ncol_X_vlm,
- ynames = dimnames(y)[[2]])
-
-
- crit.list <- list()
- if (criterion != "coefficients")
- crit.list[[criterion]] <- fit[[criterion]] <- new.crit
-
- for(ii in names(.min.criterion.VGAM)) {
- if (ii != criterion &&
- any(slotNames(family) == ii) &&
- length(body(slot(family, ii)))) {
- fit[[ii]] <- crit.list[[ii]] <- (slot(family, ii))(mu = mu,
- y = y, w = w, res = FALSE, eta = eta, extra)
- }
+ if (length(dimnames(mu)[[2]])) {
+ y.names <- dimnames(mu)[[2]]
+ }
+ dimnames(mu) <- list(yn, y.names)
+ } else {
+ names(mu) <- names(fv)
+ }
+
+
+ df.residual <- nrow_X_vlm - rank
+ fit <- list(assign = asgn,
+ coefficients = coefs,
+ constraints = Blist,
+ df.residual = df.residual,
+ df.total = n*M,
+ effects = effects,
+ fitted.values = mu,
+ offset = offset,
+ rank = rank,
+ residuals = residuals,
+ R = R,
+ terms = Terms) # terms: This used to be done in vglm()
+
+ if (qr.arg) {
+ fit$qr <- tfit$qr
+ dimnames(fit$qr$qr) <- dnrow_X_vlm
+ }
+
+ if (M == 1) {
+ wz <- as.vector(wz) # Convert wz into a vector
+ } # else
+ fit$weights <- if (save.weight) wz else NULL
+
+
+ misc <- list(
+ colnames.x = xn,
+ colnames.X_vlm = xnrow_X_vlm,
+ criterion = criterion,
+ function.name = function.name,
+ intercept.only=intercept.only,
+ predictors.names = predictors.names,
+ M = M,
+ n = n,
+ nonparametric = nonparametric,
+ nrow_X_vlm = nrow_X_vlm,
+ orig.assign = attr(x, "assign"),
+ p = ncol(x),
+ ncol_X_vlm = ncol_X_vlm,
+ ynames = dimnames(y)[[2]])
+
+
+ crit.list <- list()
+ if (criterion != "coefficients")
+ crit.list[[criterion]] <- fit[[criterion]] <- new.crit
+
+ for(ii in names(.min.criterion.VGAM)) {
+ if (ii != criterion &&
+ any(slotNames(family) == ii) &&
+ length(body(slot(family, ii)))) {
+ fit[[ii]] <-
+ crit.list[[ii]] <-
+ (slot(family, ii))(mu = mu, y = y, w = w,
+ res = FALSE, eta = eta, extra)
}
+ }
- if (w[1] != 1 || any(w != w[1]))
- fit$prior.weights <- w
+ if (w[1] != 1 || any(w != w[1]))
+ fit$prior.weights <- w
- if (length(slot(family, "last")))
- eval(slot(family, "last"))
+ if (length(slot(family, "last")))
+ eval(slot(family, "last"))
- structure(c(fit, list(predictors = tfit$predictors,
+ structure(c(fit,
+ list(predictors = tfit$predictors,
contrasts = attr(x, "contrasts"),
control = control,
crit.list = crit.list,
diff --git a/data/alclevels.rda b/data/alclevels.rda
index a9375c8..ad50757 100644
Binary files a/data/alclevels.rda and b/data/alclevels.rda differ
diff --git a/data/alcoff.rda b/data/alcoff.rda
index 7782950..5e6180f 100644
Binary files a/data/alcoff.rda and b/data/alcoff.rda differ
diff --git a/data/auuc.rda b/data/auuc.rda
index 82e7292..b1de85d 100644
Binary files a/data/auuc.rda and b/data/auuc.rda differ
diff --git a/data/backPain.rda b/data/backPain.rda
index b8a97f8..bdd516a 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 48e80c1..4fc62ee 100644
Binary files a/data/car.all.rda and b/data/car.all.rda differ
diff --git a/data/crashbc.rda b/data/crashbc.rda
index b7cd392..c301cda 100644
Binary files a/data/crashbc.rda and b/data/crashbc.rda differ
diff --git a/data/crashf.rda b/data/crashf.rda
index a1f3747..8ee5172 100644
Binary files a/data/crashf.rda and b/data/crashf.rda differ
diff --git a/data/crashi.rda b/data/crashi.rda
index f56adae..3f2e18d 100644
Binary files a/data/crashi.rda and b/data/crashi.rda differ
diff --git a/data/crashmc.rda b/data/crashmc.rda
index edf8f59..a98ddc3 100644
Binary files a/data/crashmc.rda and b/data/crashmc.rda differ
diff --git a/data/crashp.rda b/data/crashp.rda
index 85c23ca..7083223 100644
Binary files a/data/crashp.rda and b/data/crashp.rda differ
diff --git a/data/crashtr.rda b/data/crashtr.rda
index 22b613c..56b7f46 100644
Binary files a/data/crashtr.rda and b/data/crashtr.rda differ
diff --git a/data/crime.us.rda b/data/crime.us.rda
index 94e70cd..6ed26f6 100644
Binary files a/data/crime.us.rda and b/data/crime.us.rda differ
diff --git a/data/datalist b/data/datalist
index a8b4d3f..2b5d14a 100644
--- a/data/datalist
+++ b/data/datalist
@@ -36,6 +36,7 @@ pneumo
rainfall
ruge
toxop
+ucberk
ugss
venice
venice90
diff --git a/data/fibre15.rda b/data/fibre15.rda
index 895e424..9241a9c 100644
Binary files a/data/fibre15.rda and b/data/fibre15.rda differ
diff --git a/data/fibre1dot5.rda b/data/fibre1dot5.rda
index caec8d9..210170c 100644
Binary files a/data/fibre1dot5.rda and b/data/fibre1dot5.rda differ
diff --git a/data/finney44.rda b/data/finney44.rda
index 26f11db..6f43bba 100644
Binary files a/data/finney44.rda and b/data/finney44.rda differ
diff --git a/data/gala.rda b/data/gala.rda
index f1d9c73..7b15c26 100644
Binary files a/data/gala.rda and b/data/gala.rda differ
diff --git a/data/hspider.rda b/data/hspider.rda
index f4881ef..2039f04 100644
Binary files a/data/hspider.rda and b/data/hspider.rda differ
diff --git a/data/hued.rda b/data/hued.rda
index 82658bf..f102e02 100644
Binary files a/data/hued.rda and b/data/hued.rda differ
diff --git a/data/huie.rda b/data/huie.rda
index 4a250b9..0160b6b 100644
Binary files a/data/huie.rda and b/data/huie.rda differ
diff --git a/data/huse.rda b/data/huse.rda
index 11e8c39..23aa88b 100644
Binary files a/data/huse.rda and b/data/huse.rda differ
diff --git a/data/leukemia.rda b/data/leukemia.rda
index 314b7a8..b800e62 100644
Binary files a/data/leukemia.rda and b/data/leukemia.rda differ
diff --git a/data/marital.nz.rda b/data/marital.nz.rda
index 7c51054..e225bf6 100644
Binary files a/data/marital.nz.rda and b/data/marital.nz.rda differ
diff --git a/data/mmt.rda b/data/mmt.rda
index 1902b9f..aba86e8 100644
Binary files a/data/mmt.rda and b/data/mmt.rda differ
diff --git a/data/pneumo.rda b/data/pneumo.rda
index 789a802..ddf3da9 100644
Binary files a/data/pneumo.rda and b/data/pneumo.rda differ
diff --git a/data/rainfall.rda b/data/rainfall.rda
index 190fe2b..7eafe0e 100644
Binary files a/data/rainfall.rda and b/data/rainfall.rda differ
diff --git a/data/ruge.rda b/data/ruge.rda
index a99d004..0a90538 100644
Binary files a/data/ruge.rda and b/data/ruge.rda differ
diff --git a/data/toxop.rda b/data/toxop.rda
index d0c02f3..ac0958c 100644
Binary files a/data/toxop.rda and b/data/toxop.rda differ
diff --git a/data/ucberk.txt.gz b/data/ucberk.txt.gz
new file mode 100644
index 0000000..932929c
Binary files /dev/null and b/data/ucberk.txt.gz differ
diff --git a/data/ugss.rda b/data/ugss.rda
index c7dfc32..fb5fc61 100644
Binary files a/data/ugss.rda and b/data/ugss.rda differ
diff --git a/data/venice.rda b/data/venice.rda
index e074438..16e8ec4 100644
Binary files a/data/venice.rda and b/data/venice.rda differ
diff --git a/data/venice90.rda b/data/venice90.rda
index 5303d30..4e26679 100644
Binary files a/data/venice90.rda and b/data/venice90.rda differ
diff --git a/data/wffc.indiv.rda b/data/wffc.indiv.rda
index 6f2369e..3194917 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 0d97c86..efe9ed9 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 016db77..61b66d8 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 b13eb0f..0e46967 100644
Binary files a/data/wffc.teams.rda and b/data/wffc.teams.rda differ
diff --git a/data/xs.nz.rda b/data/xs.nz.rda
index 2f36daa..d6d1bf6 100644
Binary files a/data/xs.nz.rda and b/data/xs.nz.rda differ
diff --git a/inst/doc/categoricalVGAM.pdf b/inst/doc/categoricalVGAM.pdf
index 37470d7..40abdf7 100644
Binary files a/inst/doc/categoricalVGAM.pdf and b/inst/doc/categoricalVGAM.pdf differ
diff --git a/man/CommonVGAMffArguments.Rd b/man/CommonVGAMffArguments.Rd
index f1ad488..cee7815 100644
--- a/man/CommonVGAMffArguments.Rd
+++ b/man/CommonVGAMffArguments.Rd
@@ -17,6 +17,7 @@ TypicalVGAMfamilyFunction(lsigma = "loge", esigma = list(), isigma = NULL,
parallel = TRUE, shrinkage.init = 0.95,
nointercept = NULL, imethod = 1,
prob.x = c(0.15, 0.85), mv = FALSE,
+ whitespace = FALSE,
oim = FALSE, nsimEIM = 100, zero = NULL)
}
\arguments{
@@ -47,6 +48,7 @@ TypicalVGAMfamilyFunction(lsigma = "loge", esigma = list(), isigma = NULL,
a \emph{self-starting} \pkg{VGAM} family function.
If a failure to converge occurs make use of these types of arguments.
+
}
\item{parallel}{
A logical, or formula specifying which terms have equal/unequal
@@ -60,6 +62,7 @@ TypicalVGAMfamilyFunction(lsigma = "loge", esigma = list(), isigma = NULL,
or greater than 1. However this parallelism or proportional-odds
assumption ought to be checked.
+
}
\item{nsimEIM}{
Some \pkg{VGAM} family functions use simulation to obtain an approximate
@@ -114,6 +117,15 @@ TypicalVGAMfamilyFunction(lsigma = "loge", esigma = list(), isigma = NULL,
}
+ \item{whitespace}{
+ Logical.
+ Should white spaces (\code{" "}) be used in the
+ labelling of the linear/additive predictors?
+ Setting \code{TRUE} usually results in more readability but
+ it occupies more columns of the output.
+
+
+ }
\item{oim}{
Logical.
Should the observed information matrices (OIMs) be used for
@@ -310,6 +322,16 @@ fit3 <- vglm(y2 ~ x, normal1(zero = 2), gdata,
constraints = clist) # Conflict!
coef(fit3, matrix = TRUE) # Shows that clist[["x"]] was overwritten,
constraints(fit3) # i.e., 'zero' seems to override the 'constraints' arg
+
+# Example 6 ('whitespace' argument)
+pneumo = transform(pneumo, let = log(exposure.time))
+fit1 = vglm(cbind(normal, mild, severe) ~ let,
+ sratio(whitespace = FALSE, parallel = TRUE), pneumo)
+fit2 = vglm(cbind(normal, mild, severe) ~ let,
+ sratio(whitespace = TRUE, parallel = TRUE), pneumo)
+head(predict(fit1), 2) # No white spaces
+head(predict(fit2), 2) # Uses white spaces
}
+
\keyword{models}
diff --git a/man/acat.Rd b/man/acat.Rd
index 0fbfa50..c2adf14 100644
--- a/man/acat.Rd
+++ b/man/acat.Rd
@@ -8,7 +8,8 @@
}
\usage{
acat(link = "loge", earg = list(),
- parallel = FALSE, reverse = FALSE, zero = NULL)
+ parallel = FALSE, reverse = FALSE, zero = NULL,
+ whitespace = FALSE)
}
%- maybe also 'usage' for other objects documented here.
\arguments{
@@ -45,6 +46,10 @@ acat(link = "loge", earg = list(),
The values must be from the set \{1,2,\ldots,\eqn{M}\}.
}
+ \item{whitespace}{
+ See \code{\link{CommonVGAMffArguments}} for information.
+
+ }
}
\details{
In this help file the response \eqn{Y} is assumed to be a factor
diff --git a/man/alaplace3.Rd b/man/alaplace3.Rd
index c2661e6..ac327e6 100644
--- a/man/alaplace3.Rd
+++ b/man/alaplace3.Rd
@@ -74,9 +74,10 @@ alaplace3(llocation = "identity", lscale = "loge", lkappa = "loge",
}
\item{sameScale}{ Logical.
- Should the scale parameters be equal? It is advised to keep
- \code{sameScale = TRUE} unchanged because it does not make sense to
- have different values for each \code{tau} value.
+ Should the scale parameters be equal? It is advised
+ to keep \code{sameScale = TRUE} unchanged because it
+ does not make sense to have different values for each
+ \code{tau} value.
}
@@ -103,11 +104,12 @@ alaplace3(llocation = "identity", lscale = "loge", lkappa = "loge",
}
\item{Scale.arg}{
The value of the scale parameter \eqn{\sigma}{sigma}.
- This argument may be used to compute quantiles at different
- \eqn{\tau}{tau} values from an existing fitted \code{alaplace2()} model
- (practical only if it has a single value).
- If the model has \code{parallelLocation = TRUE} then only the intercept
- need be estimated; use an offset.
+ This argument may be used to compute quantiles at
+ different \eqn{\tau}{tau} values from an existing fitted
+ \code{alaplace2()} model (practical only if it has a
+ single value).
+ If the model has \code{parallelLocation = TRUE} then
+ only the intercept need be estimated; use an offset.
See below for an example.
% This is because the expected information matrix is diagonal,
@@ -123,8 +125,8 @@ alaplace3(llocation = "identity", lscale = "loge", lkappa = "loge",
\item{zero}{
See \code{\link{CommonVGAMffArguments}} for more information.
Where possible,
- the default is to model all the \eqn{\sigma}{sigma} and \eqn{\kappa}{kappa}
- as an intercept-only term.
+ the default is to model all the \eqn{\sigma}{sigma}
+ and \eqn{\kappa}{kappa} as an intercept-only term.
}
}
@@ -148,8 +150,8 @@ alaplace3(llocation = "identity", lscale = "loge", lkappa = "loge",
(sqrt(2) * kappa / sigma) * |y-xi| ) }
for \eqn{y > \xi}{y > xi}.
Here, the ranges are
- for all real \eqn{y} and \eqn{\xi}{xi}, positive \eqn{\sigma}{sigma} and
- positive \eqn{\kappa}{kappa}.
+ for all real \eqn{y} and \eqn{\xi}{xi}, positive \eqn{\sigma}{sigma}
+ and positive \eqn{\kappa}{kappa}.
The special case \eqn{\kappa = 1}{kappa = 1} corresponds to the
(symmetric) Laplace distribution of Kotz et al. (2001).
The mean is \eqn{\xi + \sigma (1/\kappa - \kappa) / \sqrt{2}}{xi +
@@ -179,12 +181,12 @@ alaplace3(llocation = "identity", lscale = "loge", lkappa = "loge",
in the \pkg{quantreg} package.
- Both \code{alaplace1()} and \code{alaplace2()}
- can handle multiple responses,
- and the number of linear/additive predictors is dictated by the
- length of \code{tau} or \code{kappa}.
- The function \code{alaplace2()} can also handle a matrix
- response with a single-valued \code{tau} or \code{kappa}.
+ Both \code{alaplace1()} and \code{alaplace2()} can handle
+ multiple responses, and the number of linear/additive
+ predictors is dictated by the length of \code{tau} or
+ \code{kappa}. The function \code{alaplace2()} can also
+ handle a matrix response with a single-valued \code{tau}
+ or \code{kappa}.
}
@@ -207,11 +209,11 @@ alaplace3(llocation = "identity", lscale = "loge", lkappa = "loge",
\bold{46}, 33--50.
-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.
+ 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.
Yee, T. W. (2012)
@@ -290,17 +292,22 @@ mymu = function(x) exp(-2 + 6*sin(2*x-0.2) / (x+0.5)^2)
adata = transform(adata, y = rpois(n, lambda = mymu(x)))
mytau = c(0.25, 0.75); mydof = 4
-fit = vgam(y ~ s(x, df = mydof), alaplace1(tau = mytau, llocation = "loge",
- parallelLoc = FALSE), adata, trace = TRUE)
-fitp = vgam(y ~ s(x, df = mydof), alaplace1(tau = mytau, llocation = "loge",
- parallelLoc = TRUE), adata, trace = TRUE)
+fit = vgam(y ~ s(x, df = mydof),
+ alaplace1(tau = mytau, llocation = "loge",
+ parallelLoc = FALSE),
+ adata, trace = TRUE)
+fitp = vgam(y ~ s(x, df = mydof),
+ alaplace1(tau = mytau, llocation = "loge", parallelLoc = TRUE),
+ adata, trace = TRUE)
\dontrun{ par(las = 1); mylwd = 1.5
with(adata, plot(x, jitter(y, factor = 0.5), col = "red",
main = "Example 1; green: parallelLoc = TRUE",
ylab = "y", pch = "o", cex = 0.75))
-with(adata, matlines(x, fitted(fit ), col = "blue", lty = "solid", lwd = mylwd))
-with(adata, matlines(x, fitted(fitp), col = "green", lty = "solid", lwd = mylwd))
+with(adata, matlines(x, fitted(fit ), col = "blue",
+ lty = "solid", lwd = mylwd))
+with(adata, matlines(x, fitted(fitp), col = "green",
+ lty = "solid", lwd = mylwd))
finexgrid = seq(0, 1, len = 1001)
for(ii in 1:length(mytau))
lines(finexgrid, qpois(p = mytau[ii], lambda = mymu(finexgrid)),
@@ -319,11 +326,13 @@ newtau = 0.5 # Want to refit the model with this tau value
fitp3 = vglm(y ~ 1 + offset(predict(fitp2)[,1]),
family = alaplace1(tau = newtau, llocation = "loge"),
adata)
-\dontrun{ with(adata, plot(x, jitter(y, factor = 0.5), col = "red", ylab = "y",
- pch = "o", cex = 0.75,
+\dontrun{ with(adata, plot(x, jitter(y, factor = 0.5), col = "red",
+ pch = "o", cex = 0.75, ylab = "y",
main = "Example 2; parallelLoc = TRUE"))
-with(adata, matlines(x, fitted(fitp2), col = "blue", lty = 1, lwd = mylwd))
-with(adata, matlines(x, fitted(fitp3), col = "black", lty = 1, lwd = mylwd)) }
+with(adata, matlines(x, fitted(fitp2), col = "blue",
+ lty = 1, lwd = mylwd))
+with(adata, matlines(x, fitted(fitp3), col = "black",
+ lty = 1, lwd = mylwd)) }
@@ -341,8 +350,8 @@ for(ii in 1:length(mytau)) {
iloc = ifelse(ii == 1, with(adata, median(y)), 1.0) # Well-chosen!
mydf = ifelse(ii == 1, 5, 3) # Maybe less smoothing will help
lloc = ifelse(ii == 1, "identity", "loge") # 2nd value must be "loge"
- fit3 = vglm(usey ~ ns(x, df = mydf), adata, trace = TRUE,
- fam = alaplace1(tau = usetau[ii], lloc = lloc, iloc = iloc))
+ fit3 = vglm(usey ~ ns(x, df = mydf), data = adata, trace = TRUE,
+ alaplace1(tau = usetau[ii], lloc = lloc, iloc = iloc))
answer[,ii] = (if(ii == 1) 0 else answer[,ii-1]) + fitted(fit3)
adata = transform(adata, offsety = answer[,ii])
}
diff --git a/man/betaII.Rd b/man/betaII.Rd
index 72f4f7e..ad80196 100644
--- a/man/betaII.Rd
+++ b/man/betaII.Rd
@@ -63,6 +63,7 @@ provided \eqn{q > 1}; these are returned as the fitted values.
The object is used by modelling functions such as \code{\link{vglm}},
and \code{\link{vgam}}.
+
}
\references{
Kleiber, C. and Kotz, S. (2003)
@@ -73,9 +74,7 @@ Hoboken, NJ, USA: Wiley-Interscience.
\author{ T. W. Yee }
\note{
- If the self-starting initial values fail, try experimenting with
- the initial value arguments, especially those whose default value
- is not \code{NULL}.
+ See the note in \code{\link{genbetaII}}.
}
@@ -97,7 +96,7 @@ Hoboken, NJ, USA: Wiley-Interscience.
bdata = data.frame(y = rsinmad(2000, shape1.a = 1, 6, 2)) # Not genuine data!
fit = vglm(y ~ 1, betaII, bdata, trace = TRUE)
fit = vglm(y ~ 1, betaII(ishape2.p = 0.7, ishape3.q = 0.7),
- bdata, trace = TRUE, crit = "coef")
+ bdata, trace = TRUE)
coef(fit, matrix = TRUE)
Coef(fit)
summary(fit)
diff --git a/man/binom2.orUC.Rd b/man/binom2.orUC.Rd
index 3dda3e4..f74b5a1 100644
--- a/man/binom2.orUC.Rd
+++ b/man/binom2.orUC.Rd
@@ -11,14 +11,14 @@
}
\usage{
rbinom2.or(n, mu1,
- mu2=if(exchangeable) mu1 else stop("'mu2' not specified"),
- oratio=1, exchangeable=FALSE, tol=0.001, twoCols=TRUE,
- colnames=if(twoCols) c("y1","y2") else c("00", "01", "10", "11"),
- ErrorCheck=TRUE)
+ mu2 = if(exchangeable) mu1 else stop("argument 'mu2' not specified"),
+ oratio = 1, exchangeable = FALSE, tol = 0.001, twoCols = TRUE,
+ colnames = if(twoCols) c("y1","y2") else c("00", "01", "10", "11"),
+ ErrorCheck = TRUE)
dbinom2.or(mu1,
- mu2=if(exchangeable) mu1 else stop("'mu2' not specified"),
- oratio=1, exchangeable=FALSE, tol=0.001,
- colnames=c("00", "01", "10", "11"), ErrorCheck=TRUE)
+ mu2 = if(exchangeable) mu1 else stop("'mu2' not specified"),
+ oratio = 1, exchangeable = FALSE, tol = 0.001,
+ colnames = c("00", "01", "10", "11"), ErrorCheck = TRUE)
}
%- maybe also 'usage' for other objects documented here.
@@ -31,7 +31,7 @@ dbinom2.or(mu1,
}
\item{mu1, mu2}{
The marginal probabilities.
- Only \code{mu1} is needed if \code{exchangeable=TRUE}.
+ Only \code{mu1} is needed if \code{exchangeable = TRUE}.
Values should be between 0 and 1.
}
@@ -98,27 +98,27 @@ dbinom2.or(mu1,
\examples{
# Example 1
nn = 2000
-ymat = rbinom2.or(n=nn, mu1=0.8, oratio=exp(2), exch=TRUE)
-(mytab = table(ymat[,1], ymat[,2], dnn=c("Y1","Y2")))
+ymat = rbinom2.or(n = nn, mu1 = 0.8, oratio = exp(2), exch = TRUE)
+(mytab = table(ymat[,1], ymat[,2], dnn=c("Y1", "Y2")))
(myor = mytab["0","0"] * mytab["1","1"] / (mytab["1","0"] * mytab["0","1"]))
-fit = vglm(ymat ~ 1, binom2.or(exch=TRUE))
-coef(fit, matrix=TRUE)
+fit = vglm(ymat ~ 1, binom2.or(exch = TRUE))
+coef(fit, matrix = TRUE)
# Example 2
x = sort(runif(nn))
-mu1 = logit(-2+4*x, inv=TRUE)
-mu2 = logit(-1+3*x, inv=TRUE)
-dmat = dbinom2.or(mu1=mu1, mu2=mu2, oratio=exp(2))
-ymat = rbinom2.or(n=nn, mu1=mu1, mu2=mu2, oratio=exp(2))
+mu1 = logit(-2+4*x, inv = TRUE)
+mu2 = logit(-1+3*x, inv = TRUE)
+dmat = dbinom2.or(mu1 = mu1, mu2 = mu2, oratio = exp(2))
+ymat = rbinom2.or(n = nn, mu1 = mu1, mu2 = mu2, oratio = exp(2))
fit2 = vglm(ymat ~ x, binom2.or)
-coef(fit2, matrix=TRUE)
+coef(fit2, matrix = TRUE)
\dontrun{
-matplot(x, dmat, lty=1:4, col=1:4, type="l", main="Joint probabilities",
- ylim=0:1, lwd=2)
-legend(x=0, y=0.5, lty=1:4, col=1:4, lwd=2,
- legend=c("1 = (y1=0, y2=0)", "2 = (y1=0, y2=1)",
- "3 = (y1=1, y2=0)", "4 = (y1=1, y2=1)"))
+matplot(x, dmat, lty = 1:4, col = 1:4, type = "l",
+ main = "Joint probabilities", ylim = 0:1, lwd = 2)
+legend(x = 0, y = 0.5, lty = 1:4, col = 1:4, lwd = 2,
+ legend = c("1 = (y1=0, y2=0)", "2 = (y1=0, y2=1)",
+ "3 = (y1=1, y2=0)", "4 = (y1=1, y2=1)"))
}
}
\keyword{distribution}
diff --git a/man/bratUC.Rd b/man/bratUC.Rd
index 88396ec..f569270 100644
--- a/man/bratUC.Rd
+++ b/man/bratUC.Rd
@@ -9,7 +9,7 @@
}
\usage{
-Brat(mat, ties = 0 * mat, string = c(" > "," == "))
+Brat(mat, ties = 0 * mat, string = c(">","=="), whitespace = FALSE)
}
%- maybe also 'usage' for other objects documented here.
\arguments{
@@ -22,7 +22,7 @@ Brat(mat, ties = 0 * mat, string = c(" > "," == "))
are best labelled with the competitors' names.
-}
+ }
\item{ties}{
Matrix of counts.
This should be the same dimension as \code{mat}. By
@@ -30,17 +30,25 @@ Brat(mat, ties = 0 * mat, string = c(" > "," == "))
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
+ Australia in rugby. Suggested alternatives include
+ \code{" beats "} or \code{" wins against "}. The second value
is used to handle ties.
-}
+ }
+ \item{whitespace}{
+ Logical. If \code{TRUE} then a white space is added before
+ and after \code{string}; it generally enhances readability.
+ See \code{\link{CommonVGAMffArguments}} for some similar-type
+ information.
+
+
+ }
}
\details{
In the \pkg{VGAM} package it is necessary for each
@@ -92,8 +100,9 @@ journal = c("Biometrika", "Comm Statist", "JASA", "JRSS-B")
mat = matrix(c( NA, 33, 320, 284, 730, NA, 813, 276,
498, 68, NA, 325, 221, 17, 142, NA), 4, 4)
dimnames(mat) = list(winner = journal, loser = journal)
-Brat(mat)
-vglm(Brat(mat) ~ 1, brat, trace = TRUE)
+Brat(mat) # Less readable
+Brat(mat, whitespace = TRUE) # More readable
+vglm(Brat(mat, whitespace = TRUE) ~ 1, brat, trace = TRUE)
}
\keyword{models}
\keyword{regression}
diff --git a/man/cauchit.Rd b/man/cauchit.Rd
index 8688166..bf0aa44 100644
--- a/man/cauchit.Rd
+++ b/man/cauchit.Rd
@@ -102,61 +102,62 @@ cauchit(theta, earg = list(bvalue= .Machine$double.eps),
\examples{
p = seq(0.01, 0.99, by=0.01)
cauchit(p)
-max(abs(cauchit(cauchit(p), inverse=TRUE) - p)) # Should be 0
+max(abs(cauchit(cauchit(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))
cauchit(p) # 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), lwd = (mylwd <- 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"
- 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")
- legend(0, 4.5, c("logit", "probit", "cloglog", "cauchit"),
- col=c("limegreen","purple","chocolate", "tan"), lwd=2)
- } else
- abline(v=0.5, lty="dashed")
+ matplot(p, cbind(logit(p, deriv = d), probit(p, deriv = d)),
+ type = "n", col = "purple", ylab = "transformation",
+ las=1, main = if (d == 0) "Some probability link functions"
+ else "First derivative")
+ lines(p, logit(p, deriv = d), col = "limegreen")
+ lines(p, probit(p, deriv = d), col = "purple")
+ lines(p, cloglog(p, deriv = d), col = "chocolate")
+ lines(p, cauchit(p, deriv = d), col = "tan")
+ if (d == 0) {
+ abline(v = 0.5, h = 0, lty = "dashed")
+ legend(0, 4.5, c("logit", "probit", "cloglog", "cauchit"), lwd = mylwd,
+ col = c("limegreen","purple","chocolate", "tan"))
+ } else
+ 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",
- main = if (d == 0) "Some inverse probability link functions"
- else "First derivative", lwd=2, las=1)
- 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")
- legend(-4, 1, c("logit", "probit", "cloglog", "cauchit"),
- col=c("limegreen","purple","chocolate", "tan"), lwd=2)
- }
+ matplot(y, cbind( logit(y, deriv = d, inverse = TRUE),
+ probit(y, deriv = d, inverse = TRUE)),
+ type = "n", col = "purple", xlab = "transformation", ylab = "p",
+ main = if (d == 0) "Some inverse probability link functions"
+ else "First derivative", las=1)
+ lines(y, logit(y, deriv = d, inverse = TRUE), col = "limegreen")
+ lines(y, probit(y, deriv = d, inverse = TRUE), col = "purple")
+ lines(y, cloglog(y, deriv = d, inverse = TRUE), col = "chocolate")
+ lines(y, cauchit(y, deriv = d, inverse = TRUE), col = "tan")
+ if (d == 0) {
+ abline(h = 0.5, v = 0, lty = "dashed")
+ legend(-4, 1, c("logit", "probit", "cloglog", "cauchit"), lwd = mylwd,
+ col = c("limegreen","purple","chocolate", "tan"))
+ }
}
+par(lwd = 1)
}
}
\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/cratio.Rd b/man/cratio.Rd
index 379b000..c0a4c77 100644
--- a/man/cratio.Rd
+++ b/man/cratio.Rd
@@ -8,7 +8,8 @@
}
\usage{
cratio(link = "logit", earg = list(),
- parallel = FALSE, reverse = FALSE, zero = NULL)
+ parallel = FALSE, reverse = FALSE, zero = NULL,
+ whitespace = FALSE)
}
%- maybe also 'usage' for other objects documented here.
\arguments{
@@ -45,6 +46,10 @@ cratio(link = "logit", earg = list(),
The default value means none are modelled as intercept-only terms.
}
+ \item{whitespace}{
+ See \code{\link{CommonVGAMffArguments}} for information.
+
+ }
}
\details{
In this help file the response \eqn{Y} is assumed to be a factor
@@ -137,7 +142,8 @@ contains further information and examples.
\examples{
pneumo = transform(pneumo, let = log(exposure.time))
-(fit = vglm(cbind(normal,mild,severe) ~ let, cratio(parallel = TRUE), pneumo))
+(fit = vglm(cbind(normal, mild, severe) ~ let,
+ cratio(parallel = TRUE), pneumo))
coef(fit, matrix = TRUE)
constraints(fit)
predict(fit)
diff --git a/man/cumulative.Rd b/man/cumulative.Rd
index be37157..169d289 100644
--- a/man/cumulative.Rd
+++ b/man/cumulative.Rd
@@ -10,7 +10,8 @@
}
\usage{
cumulative(link = "logit", earg = list(), parallel = FALSE,
- reverse = FALSE, mv = FALSE, intercept.apply = FALSE)
+ reverse = FALSE, mv = FALSE, intercept.apply = FALSE,
+ whitespace = FALSE)
}
%scumulative(link="logit", earg = list(),
% lscale="loge", escale = list(),
@@ -98,6 +99,11 @@ cumulative(link = "logit", earg = list(), parallel = FALSE,
% Numeric. Initial values for the scale parameters.
% }
+ \item{whitespace}{
+ See \code{\link{CommonVGAMffArguments}} for information.
+
+ }
+
}
\details{
In this help file the response \eqn{Y} is assumed to be a factor
diff --git a/man/dagum.Rd b/man/dagum.Rd
index fc6ef4a..5601488 100644
--- a/man/dagum.Rd
+++ b/man/dagum.Rd
@@ -82,9 +82,7 @@ Hoboken, NJ, USA: Wiley-Interscience.
\author{ T. W. Yee }
\note{
-If the self-starting initial values fail, try experimenting
-with the initial value arguments, especially those whose
-default value is not \code{NULL}.
+ See the note in \code{\link{genbetaII}}.
From Kleiber and Kotz (2003), the MLE is rather sensitive to isolated
@@ -110,9 +108,9 @@ while estimates for \eqn{a} and \eqn{p} can be considered unbiased for
}
\examples{
-ddata = data.frame(y = rdagum(n = 3000, 4, 6, 2))
+ddata = data.frame(y = rdagum(n = 3000, exp(1), exp(2), exp(1)))
fit = vglm(y ~ 1, dagum, ddata, trace = TRUE)
-fit = vglm(y ~ 1, dagum(ishape1.a = 2.1), ddata, trace = TRUE, crit = "c")
+fit = vglm(y ~ 1, dagum(ishape1.a = exp(1)), ddata, trace = TRUE)
coef(fit, matrix = TRUE)
Coef(fit)
summary(fit)
diff --git a/man/df.residual.Rd b/man/df.residual.Rd
new file mode 100644
index 0000000..a2ca589
--- /dev/null
+++ b/man/df.residual.Rd
@@ -0,0 +1,75 @@
+\name{df.residual}
+\alias{df.residual}
+\alias{df.residual_vlm}
+%\alias{df.residual.default}
+\title{Residual Degrees-of-Freedom}
+\description{
+ Returns the residual degrees-of-freedom extracted from a fitted
+ VGLM object.
+
+}
+\usage{
+df.residual_vlm(object, type = c("vlm", "lm"), \dots)
+}
+\arguments{
+ \item{object}{
+ an object for which the degrees-of-freedom are desired,
+ e.g., a \code{\link{vglm}} object.
+
+ }
+ \item{type}{
+ the type of residual degrees-of-freedom wanted.
+ In some applications the 'usual' LM-type value is requested.
+ The default is the first choice.
+
+ }
+ \item{\dots}{
+ additional optional arguments.
+
+ }
+}
+\details{
+ When a VGLM is fitted, a large ordinary least squares
+ (OLS) fit is performed.
+ The number of rows is \eqn{M} times the 'ordinary' number
+ of rows of the LM-type model.
+ Here, \eqn{M} is the number of linear/additive predictors.
+ The formula for the VLM-type residual degrees-of-freedom
+ is \eqn{nM - p^{*}} where \eqn{p^{*}} is the number of
+ columns of the 'big' VLM matrix.
+ The formula for the LM-type residual degrees-of-freedom
+ is \eqn{n - p} where \eqn{p} is the number of
+ columns of the 'ordinary' LM matrix.
+
+}
+\value{
+ The value of the residual degrees-of-freedom extracted
+ from the object.
+
+
+}
+\seealso{
+ \code{\link{vglm}},
+ \code{\link[stats]{deviance}},
+ \code{\link[stats]{lm}}.
+
+
+}
+
+
+\examples{
+pneumo <- transform(pneumo, let = log(exposure.time))
+(fit <- vglm(cbind(normal,mild,severe) ~ let, propodds, pneumo))
+model.matrix(fit)
+
+df.residual(fit, type = "vlm")
+nobs(fit, type = "vlm")
+nvar(fit, type = "vlm")
+
+df.residual(fit, type = "lm") # This is more usual to some people
+nobs(fit, type = "lm")
+nvar(fit, type = "lm")
+}
+
+\keyword{models}
+\keyword{regression}
diff --git a/man/fisk.Rd b/man/fisk.Rd
index 7b2ddc6..d46548b 100644
--- a/man/fisk.Rd
+++ b/man/fisk.Rd
@@ -77,9 +77,8 @@ Hoboken, NJ: Wiley-Interscience.
\author{ T. W. Yee }
\note{
- If the self-starting initial values fail, try experimenting
- with the initial value arguments, especially those whose
- default value is not \code{NULL}.
+ See the note in \code{\link{genbetaII}}.
+
}
@@ -97,9 +96,9 @@ Hoboken, NJ: Wiley-Interscience.
}
\examples{
-fdata = data.frame(y = rfisk(n = 200, 4, 6))
+fdata = data.frame(y = rfisk(n = 200, exp(1), exp(2)))
fit = vglm(y ~ 1, fisk, fdata, trace = TRUE)
-fit = vglm(y ~ 1, fisk(ishape1.a = 3.3), fdata, trace = TRUE, crit = "coef")
+fit = vglm(y ~ 1, fisk(ishape1.a = exp(1)), fdata, trace = TRUE)
coef(fit, matrix = TRUE)
Coef(fit)
summary(fit)
diff --git a/man/fsqrt.Rd b/man/fsqrt.Rd
index 61971c0..b4117fe 100644
--- a/man/fsqrt.Rd
+++ b/man/fsqrt.Rd
@@ -8,7 +8,7 @@
}
\usage{
-fsqrt(theta, earg = list(min=0, max=1, mux=sqrt(2)),
+fsqrt(theta, earg = list(min = 0, max = 1, mux = sqrt(2)),
inverse = FALSE, deriv = 0, short = TRUE, tag = FALSE)
}
%- maybe also 'usage' for other objects documented here.
@@ -49,9 +49,11 @@ fsqrt(theta, earg = list(min=0, max=1, mux=sqrt(2)),
Numerical values of \code{theta}
out of range result in \code{NA} or \code{NaN}.
+
The arguments \code{short} and \code{tag} are used only if
\code{theta} is character.
+
}
\value{
For \code{fsqrt} with \code{deriv = 0}:
@@ -65,11 +67,13 @@ fsqrt(theta, earg = list(min=0, max=1, mux=sqrt(2)),
\code{theta} is between \code{-mux*sqrt(max-min)} and
\code{mux*sqrt(max-min)}.
+
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.
+
}
%\references{
%
@@ -84,80 +88,81 @@ fsqrt(theta, earg = list(min=0, max=1, mux=sqrt(2)),
e.g., with \code{\link{binomialff}}, \code{\link{cumulative}}. See
the example below.
+
}
\seealso{
\code{\link{Links}}.
+
+
}
\examples{
-p = seq(0.01, 0.99, by=0.01)
+p = seq(0.01, 0.99, by = 0.01)
fsqrt(p)
-max(abs(fsqrt(fsqrt(p), inverse=TRUE) - p)) # Should be 0
+max(abs(fsqrt(fsqrt(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))
fsqrt(p) # Has NAs
\dontrun{
-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)
+par(mfrow = c(2, 2), lwd = (mylwd <- 2))
+y = seq(-4, 4, length = 100)
for(d in 0:1) {
- matplot(p, cbind(logit(p, deriv=d), fsqrt(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, fsqrt(p, deriv=d), col="tan", lwd=2)
- if (d == 0) {
- abline(v=0.5, h=0, lty="dashed")
- legend(0, 4.5, c("logit", "probit", "cloglog", "fsqrt"),
- col=c("limegreen","purple","chocolate", "tan"), lwd=2)
- } else
- abline(v=0.5, lty="dashed")
+ matplot(p, cbind(logit(p, deriv = d), fsqrt(p, deriv = d)),
+ type = "n", col = "purple", ylab = "transformation", las = 1,
+ main = if (d == 0) "Some probability link functions"
+ else "First derivative")
+ lines(p, logit(p, deriv = d), col = "limegreen")
+ lines(p, probit(p, deriv = d), col = "purple")
+ lines(p, cloglog(p, deriv = d), col = "chocolate")
+ lines(p, fsqrt(p, deriv = d), col = "tan")
+ if (d == 0) {
+ abline(v = 0.5, h = 0, lty = "dashed")
+ legend(0, 4.5, c("logit", "probit", "cloglog", "fsqrt"), lwd = 2,
+ col = c("limegreen","purple","chocolate", "tan"))
+ } else
+ abline(v = 0.5, lty = "dashed")
}
for(d in 0) {
- matplot(y, cbind(logit(y, deriv=d, inverse=TRUE),
- fsqrt(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, fsqrt(y, deriv=d, inverse=TRUE), col="tan", lwd=2)
- if (d == 0) {
- abline(h=0.5, v=0, lty="dashed")
- legend(-4, 1, c("logit", "probit", "cloglog", "fsqrt"),
- col=c("limegreen","purple","chocolate", "tan"), lwd=2)
- }
+ matplot(y, cbind(logit(y, deriv = d, inverse = TRUE),
+ fsqrt(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")
+ lines(y, probit(y, deriv = d, inverse = TRUE), col = "purple")
+ lines(y, cloglog(y, deriv = d, inverse = TRUE), col = "chocolate")
+ lines(y, fsqrt(y, deriv = d, inverse = TRUE), col = "tan")
+ if (d == 0) {
+ abline(h = 0.5, v = 0, lty = "dashed")
+ legend(-4, 1, c("logit", "probit", "cloglog", "fsqrt"), lwd = 2,
+ col = c("limegreen","purple","chocolate", "tan"))
+ }
}
+par(lwd = 1)
}
# This is lucky to converge
-earg = list(min=0, max=1, mux=5)
+earg = list(min = 0, max = 1, mux = 5)
fit.h = vglm(agaaus ~ bs(altitude),
- fam= binomialff(link="fsqrt", earg=earg),
- data=hunua, trace=TRUE, crit="d")
+ fam = binomialff(link = "fsqrt", earg = earg),
+ data = hunua, trace = TRUE)
\dontrun{
-plotvgam(fit.h, se=TRUE, lcol="red", scol="red",
- main="Red is Hunua, Blue is Waitakere")
-}
-head(predict(fit.h, hunua, type="response"))
+plotvgam(fit.h, se = TRUE, lcol = "orange", scol = "orange",
+ main = "Orange is Hunua, Blue is Waitakere") }
+head(predict(fit.h, hunua, type = "response"))
\dontrun{
# The following fails.
-pneumo = transform(pneumo, let=log(exposure.time))
-earg = list(min=0, max=1, mux=10)
+pneumo = transform(pneumo, let = log(exposure.time))
+earg = list(min = 0, max = 1, mux = 10)
fit = vglm(cbind(normal, mild, severe) ~ let,
- cumulative(link="fsqrt", earg=earg, par=TRUE, rev=TRUE),
- data = pneumo, trace=TRUE, maxit=200)
-}
+ cumulative(link = "fsqrt", earg = earg, par = TRUE, rev = TRUE),
+ data = pneumo, trace = TRUE, maxit = 200) }
}
\keyword{math}
\keyword{models}
diff --git a/man/genbetaII.Rd b/man/genbetaII.Rd
index 58a6189..54b24d2 100644
--- a/man/genbetaII.Rd
+++ b/man/genbetaII.Rd
@@ -5,6 +5,7 @@
\description{
Maximum likelihood estimation of the 4-parameter
generalized beta II distribution.
+
}
\usage{
genbetaII(lshape1.a = "loge", lscale = "loge", lshape2.p = "loge", lshape3.q = "loge",
@@ -23,16 +24,19 @@ genbetaII(lshape1.a = "loge", lscale = "loge", lshape2.p = "loge", lshape3.q = "
All four parameters are positive.
See \code{\link{Links}} for more choices.
+
}
\item{eshape1.a, escale, eshape2.p, eshape3.q}{
List. Extra argument for each of the links.
See \code{earg} in \code{\link{Links}} for general information.
+
}
\item{ishape1.a, iscale}{
Optional initial values for \code{a} and \code{scale}.
A \code{NULL} means a value is computed internally.
+
}
\item{ishape2.p, ishape3.q}{
Optional initial values for \code{p} and \code{q}.
@@ -44,6 +48,7 @@ genbetaII(lshape1.a = "loge", lscale = "loge", lshape2.p = "loge", lshape3.q = "
Here, the values must be from the set \{1,2,3,4\} which correspond to
\code{a}, \code{scale}, \code{p}, \code{q}, respectively.
+
}
}
\details{
@@ -56,6 +61,7 @@ genbetaII(lshape1.a = "loge", lscale = "loge", lshape2.p = "loge", lshape3.q = "
Brazauskas (2002).
The argument names given here are used by other families that
are special cases of this family.
+ Fisher scoring is used here and for the special cases too.
The 4-parameter generalized beta II distribution has density
@@ -76,6 +82,7 @@ provided \eqn{-ap < 1 < aq}; these are returned as the fitted values.
%\eqn{u^{p-1} (1-u)^{q-1}}{u^(p-1) (1-u)^(q-1)} where \eqn{y>0}.
+
}
\value{
An object of class \code{"vglmff"} (see \code{\link{vglmff-class}}).
@@ -105,13 +112,15 @@ Fisher information matrix for the Feller-Pareto distribution.
If the self-starting initial values fail, try experimenting
with the initial value arguments, especially those whose
default value is not \code{NULL}.
-
-
-Successful convergence depends on having very
-good initial values. This is rather difficult for this distribution!
+Also, the constraint \eqn{-ap < 1 < aq}
+may be violated as the iterations progress so it pays
+to monitor convergence, e.g., set \code{trace = TRUE}.
+Successful convergence depends on having very good initial
+values. This is rather difficult for this distribution!
More improvements could be made here.
+
}
\seealso{
@@ -126,13 +135,14 @@ More improvements could be made here.
\code{\link{invparalogistic}},
\code{\link{lino}}.
+
}
\examples{
-gdata = data.frame(y = rsinmad(n = 3000, 4, 6, 2)) # Not very good data!
+gdata = data.frame(y = rsinmad(3000, exp(2), exp(2), exp(1))) # A special case!
fit = vglm(y ~ 1, genbetaII, gdata, trace = TRUE)
-fit = vglm(y ~ 1, data = gdata, trace = TRUE, crit = "coef",
- genbetaII(ishape2.p = 1, ishape1.a = 4, iscale = 7, ishape3.q = 2.3))
+fit = vglm(y ~ 1, data = gdata, trace = TRUE,
+ genbetaII(ishape1.a = 4, ishape2.p = 2.2, iscale = 7, ishape3.q = 2.3))
coef(fit, matrix = TRUE)
Coef(fit)
summary(fit)
diff --git a/man/hatvalues.Rd b/man/hatvalues.Rd
new file mode 100644
index 0000000..13d2002
--- /dev/null
+++ b/man/hatvalues.Rd
@@ -0,0 +1,263 @@
+% 20120312
+% Modified from file src/library/stats/man/influence.measures.Rd
+
+\name{hatvalues}
+%\title{Regression Deletion Diagnostics}
+\title{Hat Values and Regression Deletion Diagnostics}
+
+%\concept{studentized residuals}
+%\concept{standardized residuals}
+%\concept{Cook's distances}
+%\concept{Covariance ratios}
+\concept{DFBETAs}
+%\concept{DFFITs}
+
+%\alias{influence.measures}
+%\alias{print.infl}
+%\alias{summary.infl}
+%\alias{hat}
+\alias{hatvalues}
+%\alias{hatvalues.lm}
+\alias{hatvaluesvlm}
+\alias{hatplot}
+\alias{hatplot.vlm}
+%\alias{rstandard}
+%\alias{rstandard.lm}
+%\alias{rstandard.glm}
+%\alias{rstudent}
+%\alias{rstudent.lm}
+%\alias{rstudent.glm}
+\alias{dfbeta}
+\alias{dfbetavlm}
+%\alias{dfbetas}
+%\alias{dfbetas.lm}
+%\alias{dffits}
+%\alias{covratio}
+%\alias{cooks.distance}
+%\alias{cooks.distance.lm}
+%\alias{cooks.distance.glm}
+\usage{
+hatvalues(model, \dots)
+hatvaluesvlm(model, type = c("diagonal", "matrix", "centralBlocks"), \dots)
+hatplot(model, \dots)
+hatplot.vlm(model, multiplier = c(2, 3), lty = "dashed",
+ xlab = "Observation", ylab = "Hat values", ylim = NULL, \dots)
+dfbetavlm(model, maxit.new = 1,
+ trace.new = FALSE,
+ smallno = 1.0e-8, ...)
+}
+\arguments{
+ \item{model}{an \R object, typically returned by \code{\link{vglm}}.
+%or \code{\link{glm}}.
+
+
+ }
+ \item{type}{Character.
+ The default is the first choice, which is
+ a \eqn{nM \times nM}{nM x nM} matrix.
+ If \code{type = "matrix"} then the \emph{entire} hat matrix is
+ returned.
+ If \code{type = "centralBlocks"} then \eqn{n} central
+ \eqn{M \times M}{M x M} block matrices, in matrix-band format.
+
+ }
+
+% \item{diag}{Logical. If \code{TRUE} then the diagonal elements
+% of the hat matrix are returned, else the \emph{entire} hat matrix is
+% returned.
+% In the latter case, it is a \eqn{nM \times nM}{nM x nM} matrix.
+
+
+% }
+
+
+ \item{multiplier}{Numeric, the multiplier.
+ The usual rule-of-thumb is that values greater than two or three
+ times the average leverage (at least for the linear model) should
+ be checked.
+
+
+ }
+ \item{lty, xlab, ylab, ylim}{Graphical parameters, see
+ \code{\link[graphics]{par}} etc.
+ The default of \code{ylim} is \code{c(0, max(hatvalues(model)))}
+ which means that if the horizontal dashed lines cannot be seen
+ then there are no particularly influential observations.
+
+
+ }
+ \item{maxit.new, trace.new, smallno}{
+ Having \code{maxit.new = 1} will give a one IRLS step approximation
+ from the ordinary solution (and no warnings!).
+ Else having \code{maxit.new = 10}, say, should usually mean
+ convergence will occur for all observations when they are
+ removed one-at-a-time.
+ Else having \code{maxit.new = 2}, say, should usually mean
+ some lack of convergence will occur when observations are
+ removed one-at-a-time.
+ Setting \code{trace.new = TRUE} will produce some running output
+ at each IRLS iteration and for each individual row of the model matrix.
+ The argument \code{smallno} multiplies each value of the
+ original prior weight (often unity); setting it identically
+ to zero will result in an error, but setting a very small value
+ effectively removes that observation.
+
+
+ }
+
+% \item{infl}{influence structure as returned by
+% \code{\link{lm.influence}} or \code{\link{influence}} (the latter
+% only for the \code{glm} method of \code{rstudent} and
+% \code{cooks.distance}).}
+% \item{res}{(possibly weighted) residuals, with proper default.}
+% \item{sd}{standard deviation to use, see default.}
+% \item{dispersion}{dispersion (for \code{\link{glm}} objects) to use,
+% see default.}
+% \item{hat}{hat values \eqn{H_{ii}}{H[i,i]}, see default.}
+% \item{type}{type of residuals for \code{glm} method for \code{rstandard.}}
+
+% \item{x}{the \eqn{X} or design matrix.}
+% \item{intercept}{should an intercept column be prepended to \code{x}?}
+ \item{\dots}{further arguments,
+ for example, graphical parameters for \code{hatplot.vlm()}.
+% passed to or from other methods.
+
+
+ }
+
+}
+\description{
+ When complete, a
+ suite of functions that can be used to compute some of the
+ regression (leave-one-out deletion) diagnostics,
+ for the VGLM class.
+
+
+% This suite of functions can be used to compute some of the
+% regression (leave-one-out deletion) diagnostics for linear and
+% generalized linear models discussed in Belsley, Kuh and Welsch
+% (1980), Cook and Weisberg (1982), etc.
+
+
+}
+\details{
+ The invocation \code{hatvalues(vglmObject)} should return a
+ \eqn{n \times M}{n x M} matrix of the diagonal elements of the
+ hat (projection) matrix of a \code{\link{vglm}} object.
+ To do this,
+ the QR decomposition of the object is retrieved or
+ reconstructed, and then straightforward calculations
+ are performed.
+
+
+ The invocation \code{hatplot(vglmObject)} should plot
+ the diagonal of the hat matrix for each of the \eqn{M}
+ linear/additive predictors.
+ By default, two horizontal dashed lines are added;
+ hat values higher than these ought to be checked.
+
+
+
+
+% The primary high-level function is \code{influence.measures}
+% which produces a class \code{"infl"} object tabular display
+% showing the DFBETAS for each model variable, DFFITS, covariance
+% ratios, Cook's distances and the diagonal elements of the
+% hat matrix. Cases which are influential with respect to any
+% of these measures are marked with an asterisk.
+
+
+% The functions \code{dfbetas}, \code{dffits}, \code{covratio}
+% and \code{cooks.distance} provide direct access to the
+% corresponding diagnostic quantities. Functions \code{rstandard}
+% and \code{rstudent} give the standardized and Studentized
+% residuals respectively. (These re-normalize the residuals to
+% have unit variance, using an overall and leave-one-out measure
+% of the error variance respectively.)
+
+
+% Values for generalized linear models are approximations, as
+% described in Williams (1987) (except that Cook's distances
+% are scaled as \eqn{F} rather than as chi-square values). The
+% approximations can be poor when some cases have large influence.
+
+
+% The optional \code{infl}, \code{res} and \code{sd} arguments are
+% there to encourage the use of these direct access functions,
+% in situations where, e.g., the underlying basic influence
+% measures (from \code{\link{lm.influence}} or the generic
+% \code{\link{influence}}) are already available.
+
+
+% Note that cases with \code{weights == 0} are \emph{dropped} from all
+% these functions, but that if a linear model has been fitted with
+% \code{na.action = na.exclude}, suitable values are filled in for the
+% cases excluded during fitting.
+
+
+% The function \code{hat()} exists mainly for S (version 2)
+% compatibility; we recommend using \code{hatvalues()} instead.
+
+
+
+}
+\note{
+ It is hoped, soon, that the full suite of functions described at
+ \code{\link[stats]{influence.measures}} will be written for VGLMs.
+ This will enable general regression deletion diagnostics to be
+ available for the entire VGLM class.
+
+
+% For \code{hatvalues}, \code{dfbeta}, and \code{dfbetas}, the method
+% for linear models also works for generalized linear models.
+
+
+}
+\author{
+ T. W. Yee.
+
+
+}
+%\references{
+% Belsley, D. A., Kuh, E. and Welsch, R. E. (1980)
+% \emph{Regression Diagnostics}.
+% New York: Wiley.
+%
+% Cook, R. D. and Weisberg, S. (1982)
+% \emph{Residuals and Influence in Regression}.
+% London: Chapman and Hall.
+%
+% Williams, D. A. (1987)
+% Generalized linear model diagnostics using the deviance and single
+% case deletions. \emph{Applied Statistics} \bold{36}, 181--191.
+%
+% Fox, J. (1997)
+% \emph{Applied Regression, Linear Models, and Related Methods}. Sage.
+%
+% Fox, J. (2002)
+% \emph{An R and S-Plus Companion to Applied Regression}.
+% Sage Publ.; \url{http://www.socsci.mcmaster.ca/jfox/Books/Companion/}.
+%
+%
+%}
+
+\seealso{
+ \code{\link{vglm}},
+ \code{\link{cumulative}},
+ \code{\link[stats]{influence.measures}}.
+
+
+}
+\examples{
+# Proportional odds model, p.179, in McCullagh and Nelder (1989)
+pneumo <- transform(pneumo, let = log(exposure.time))
+fit <- vglm(cbind(normal, mild, severe) ~ let, cumulative, data = pneumo)
+hatvalues(fit) # n x M matrix, with positive values
+all.equal(sum(hatvalues(fit)), fit at rank) # Should be TRUE
+\dontrun{ par(mfrow = c(1, 2))
+hatplot(fit, ylim = c(0, 1), las = 1, col = "blue") }
+}
+\keyword{regression}
+
+
+
diff --git a/man/invlomax.Rd b/man/invlomax.Rd
index 32400e7..4df531e 100644
--- a/man/invlomax.Rd
+++ b/man/invlomax.Rd
@@ -77,9 +77,7 @@ Hoboken, NJ, USA: Wiley-Interscience.
\author{ T. W. Yee }
\note{
-If the self-starting initial values fail, try experimenting
-with the initial value arguments, especially those whose
-default value is not \code{NULL}.
+ See the note in \code{\link{genbetaII}}.
}
@@ -99,9 +97,10 @@ default value is not \code{NULL}.
}
\examples{
-idata = data.frame(y = rinvlomax(n = 2000, 6, 2))
+idata = data.frame(y = rinvlomax(n = 2000, exp(2), exp(1)))
fit = vglm(y ~ 1, invlomax, idata, trace = TRUE)
-fit = vglm(y ~ 1, invlomax, idata, trace = TRUE, crit = "coef")
+fit = vglm(y ~ 1, invlomax(iscale = exp(2), ishape2.p = exp(1)), idata,
+ trace = TRUE, epsilon = 1e-8)
coef(fit, matrix = TRUE)
Coef(fit)
summary(fit)
diff --git a/man/invparalogistic.Rd b/man/invparalogistic.Rd
index 1dbeb2c..cc5fcb0 100644
--- a/man/invparalogistic.Rd
+++ b/man/invparalogistic.Rd
@@ -77,9 +77,7 @@ Hoboken, NJ, USA: Wiley-Interscience.
\author{ T. W. Yee }
\note{
-If the self-starting initial values fail, try experimenting
-with the initial value arguments, especially those whose
-default value is not \code{NULL}.
+ See the note in \code{\link{genbetaII}}.
}
@@ -99,10 +97,10 @@ default value is not \code{NULL}.
}
\examples{
-idata = data.frame(y = rinvparalogistic(n = 3000, 4, 6))
+idata = data.frame(y = rinvparalogistic(n = 3000, exp(1), exp(2)))
fit = vglm(y ~ 1, invparalogistic, idata, trace = TRUE)
-fit = vglm(y ~ 1, invparalogistic(ishape1.a = 2.7, iscale = 3.3),
- idata, trace = TRUE, crit = "coef")
+fit = vglm(y ~ 1, invparalogistic(ishape1.a = 2.7, iscale = 7.3),
+ idata, trace = TRUE, epsilon = 1e-8)
coef(fit, matrix = TRUE)
Coef(fit)
summary(fit)
diff --git a/man/logit.Rd b/man/logit.Rd
index 8360779..d3f058d 100644
--- a/man/logit.Rd
+++ b/man/logit.Rd
@@ -149,50 +149,48 @@ 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))
+\dontrun{ par(mfrow = c(2,2), lwd = (mylwd <- 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"
- else "First derivative")
- 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)
- } else
- abline(v = 0.5, lty = "dashed")
+ matplot(p, cbind(logit(p, deriv = d), probit(p, deriv = d)),
+ type = "n", col = "purple", ylab = "transformation", las = 1,
+ main = if (d == 0) "Some probability link functions"
+ else "First derivative")
+ lines(p, logit(p, deriv = d), col = "limegreen")
+ lines(p, probit(p, deriv = d), col = "purple")
+ lines(p, cloglog(p, deriv = d), col = "chocolate")
+ lines(p, cauchit(p, deriv = d), 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 = mylwd)
+ } else
+ 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"
- else "First derivative")
- 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)
- }
+ matplot(y, cbind(logit(y, deriv = d, inverse = TRUE),
+ probit(y, deriv = d, inverse = TRUE)), las = 1,
+ type = "n", col = "purple", xlab = "transformation", ylab = "p",
+ main = if (d == 0) "Some inverse probability link functions"
+ else "First derivative")
+ lines(y, logit(y, deriv = d, inverse = TRUE), col = "limegreen")
+ lines(y, probit(y, deriv = d, inverse = TRUE), col = "purple")
+ lines(y, cloglog(y, deriv = d, inverse = TRUE), col = "chocolate")
+ lines(y, cauchit(y, deriv = d, inverse = TRUE), 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 = mylwd)
+ }
}
p = seq(0.21, 0.59, by = 0.01)
-plot(p, elogit(p, earg = list(min = 0.2, max = 0.6)), lwd = 2,
+plot(p, elogit(p, earg = list(min = 0.2, max = 0.6)),
type = "l", col = "black", ylab = "transformation", xlim = c(0,1),
las = 1, main = "elogit(p, earg = list(min = 0.2, max = 0.6)")
+par(lwd = 1)
}
}
\keyword{math}
diff --git a/man/lomax.Rd b/man/lomax.Rd
index 8466288..17217f5 100644
--- a/man/lomax.Rd
+++ b/man/lomax.Rd
@@ -80,9 +80,7 @@ Hoboken, NJ, USA: Wiley-Interscience.
\author{ T. W. Yee }
\note{
-If the self-starting initial values fail, try experimenting
-with the initial value arguments, especially those whose
-default value is not \code{NULL}.
+ See the note in \code{\link{genbetaII}}.
}
@@ -101,9 +99,9 @@ default value is not \code{NULL}.
}
\examples{
-ldata = data.frame(y = rlomax(n = 1000, exp(1), exp(1)))
+ldata = data.frame(y = rlomax(n = 1000, exp(1), exp(2)))
fit = vglm(y ~ 1, lomax, ldata, trace = TRUE)
-fit = vglm(y ~ 1, lomax(iscale = exp(1), ishape3.q = 2), ldata, trace = TRUE)
+fit = vglm(y ~ 1, lomax(iscale = exp(1), ishape3.q = exp(2)), ldata, trace = TRUE)
coef(fit, matrix = TRUE)
Coef(fit)
summary(fit)
diff --git a/man/model.matrixvlm.Rd b/man/model.matrixvlm.Rd
index 01acf01..30c8a20 100644
--- a/man/model.matrixvlm.Rd
+++ b/man/model.matrixvlm.Rd
@@ -2,7 +2,8 @@
\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"),
+ lapred.index = NULL, \dots)
}
\arguments{
\item{object}{an object of a class that inherits from the
@@ -17,12 +18,25 @@ model.matrixvlm(object, type = c("vlm","lm","lm2","bothlmlm2"), \dots)
to the \code{form2} argument.
The value \code{"bothlmlm2"} means both LM and VLM model matrices.
+
}
+ \item{lapred.index}{
+ Single integer. The index for a linear/additive predictor,
+ it must have a value from the set \code{1:M}, and
+ \code{type = "lm"} must be assigned.
+ Then it returns a subset of the VLM matrix corresponding to
+ the \code{lapred.index}th linear/additive predictor; this
+ is a LM-type matrix.
+
+
+ }
\item{\dots}{further arguments passed to or from other methods.
These include \code{data} (which
is a data frame created with \code{\link{model.framevlm}}),
\code{contrasts.arg}, and \code{xlev}.
See \code{\link[stats]{model.matrix}} for more information.
+
+
}
}
@@ -81,22 +95,22 @@ Reduced-rank vector generalized linear models.
# Illustrates smart prediction
pneumo = transform(pneumo, let = log(exposure.time))
fit = vglm(cbind(normal, mild, severe) ~ poly(c(scale(let)), 2),
- fam = multinomial,
+ family = multinomial,
data = pneumo, trace = TRUE, x = FALSE)
class(fit)
-fit at x
+fit at x # Not saved on the object
model.matrix(fit)
+model.matrix(fit, lapred.index = 1, type = "lm")
+model.matrix(fit, lapred.index = 2, type = "lm")
-Check1 = head(model.matrix(fit, type = "lm"))
-Check1
-Check2 = model.matrix(fit, data = head(pneumo), type = "lm")
-Check2
+(Check1 = head(model.matrix(fit, type = "lm")))
+(Check2 = model.matrix(fit, data = head(pneumo), type = "lm"))
all.equal(c(Check1), c(Check2))
q0 = head(predict(fit))
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
+all.equal(q0, q1) # Should be TRUE
+all.equal(q1, q2) # Should be TRUE
}
\keyword{models}
diff --git a/man/multinomial.Rd b/man/multinomial.Rd
index 05d3804..24c63d8 100644
--- a/man/multinomial.Rd
+++ b/man/multinomial.Rd
@@ -9,7 +9,7 @@
}
\usage{
multinomial(zero = NULL, parallel = FALSE, nointercept = NULL,
- refLevel = "last")
+ refLevel = "last", whitespace = FALSE)
}
%- maybe also 'usage' for other objects documented here.
\arguments{
@@ -26,7 +26,7 @@ multinomial(zero = NULL, parallel = FALSE, nointercept = NULL,
equal/unequal coefficients.
}
- \item{nointercept}{
+ \item{nointercept, whitespace}{
See \code{\link{CommonVGAMffArguments}} for more details.
}
diff --git a/man/notdocumentedyet.Rd b/man/notdocumentedyet.Rd
index 8dbfe1e..9bce2aa 100644
--- a/man/notdocumentedyet.Rd
+++ b/man/notdocumentedyet.Rd
@@ -2,6 +2,16 @@
\alias{notdocumentedyet}
%
%
+% 20120310
+%\alias{hatvalues}
+%\alias{hatvalues.vlm}
+%
+%
+% 20120307
+\alias{npred}
+\alias{npred.vlm}
+%
+%
%
% 20120215
% \alias{print.vglmff}
@@ -236,8 +246,8 @@
\alias{deviance.uqo}
\alias{deviance.vglm}
\alias{deviance.vlm}
-\alias{df.residual}
-\alias{df.residual.vlm}
+%\alias{df.residual}
+%\alias{df.residual_vlm}
\alias{dimm}
% \alias{dneg.binomial}
\alias{dnorm2}
diff --git a/man/paralogistic.Rd b/man/paralogistic.Rd
index 6e32e0b..42178bd 100644
--- a/man/paralogistic.Rd
+++ b/man/paralogistic.Rd
@@ -75,9 +75,7 @@ Hoboken, NJ, USA: Wiley-Interscience.
\author{ T. W. Yee }
\note{
-If the self-starting initial values fail, try experimenting
-with the initial value arguments, especially those whose
-default value is not \code{NULL}.
+ See the note in \code{\link{genbetaII}}.
}
@@ -95,10 +93,10 @@ default value is not \code{NULL}.
}
\examples{
-pdata = data.frame(y = rparalogistic(n = 3000, 4, 6))
+pdata = data.frame(y = rparalogistic(n = 3000, exp(1), exp(2)))
fit = vglm(y ~ 1, paralogistic, pdata, trace = TRUE)
-fit = vglm(y ~ 1, paralogistic(ishape1.a = 2.3, iscale = 5),
- pdata, trace = TRUE, crit = "coef")
+fit = vglm(y ~ 1, paralogistic(ishape1.a = 2.3, iscale = 7),
+ pdata, trace = TRUE, epsilon = 1e-8)
coef(fit, matrix = TRUE)
Coef(fit)
summary(fit)
diff --git a/man/posbinomUC.Rd b/man/posbinomUC.Rd
index 0f73356..7a66855 100644
--- a/man/posbinomUC.Rd
+++ b/man/posbinomUC.Rd
@@ -13,21 +13,43 @@
}
\usage{
dposbinom(x, size, prob, log = FALSE)
-pposbinom(q, size, prob, lower.tail = TRUE, log.p = FALSE)
-qposbinom(p, size, prob, lower.tail = TRUE, log.p = FALSE)
+pposbinom(q, size, prob)
+qposbinom(p, size, prob)
rposbinom(n, size, prob)
}
%- maybe also 'usage' for other objects documented here.
\arguments{
\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. }
- \item{size}{number of trials. It is the \eqn{N} symbol in the formula
- given in \code{\link{posbinomial}}. }
+ \item{n}{number of observations.
+ Fed into \code{\link[stats]{runif}}.
+
+
+ }
+ \item{size}{number of trials.
+ It is the \eqn{N} symbol in the formula
+ given in \code{\link{posbinomial}}.
+
+ }
\item{prob}{probability of success on each trial. }
- \item{log, log.p, lower.tail}{ Arguments that are passed on to
- \code{\link[stats:Binomial]{pbinom}} etc.}
+
+
+% 20120407:
+% \item{log.p, lower.tail}{
+% Arguments that are passed on to
+% \code{\link[stats:Binomial]{pbinom}} etc.
+%
+% }
+
+
+
+ \item{log}{
+ See
+ \code{\link[stats:Binomial]{dbinom}}.
+
+ }
+
+
}
\details{
The positive-binomial distribution is a binomial distribution but with
@@ -58,27 +80,33 @@ rposbinom(n, size, prob)
For \code{dposbinom()}, if arguments \code{size} or \code{prob}
equal 0 then a \code{NaN} is returned.
- For \code{rposbinom()}, the arguments of the function are fed into
- \code{\link[stats:Binomial]{rbinom}} until \eqn{n} positive values
- are obtained. This may take a long time if \code{prob} has values
- close to 0.
- The family function \code{\link{posbinomial}} estimates the parameters
- by maximum likelihood estimation.
+% 20120405; no longer true to a superior method:
+% For \code{rposbinom()}, the arguments of the function are fed into
+% \code{\link[stats:Binomial]{rbinom}} until \eqn{n} positive values
+% are obtained. This may take a long time if \code{prob} has values
+% close to 0.
+
+
+ The family function \code{\link{posbinomial}} estimates the
+ parameters by maximum likelihood estimation.
+
}
\seealso{
\code{\link{posbinomial}},
+ \code{\link{zabinomial}},
+ \code{\link{zibinomial}},
\code{\link[stats:Binomial]{rbinom}}.
+
+
}
\examples{
prob = 0.2; size = 10
-y = rposbinom(n = 1000, size, prob)
-
-table(y)
+table(y <- rposbinom(n = 1000, size, prob))
mean(y) # Sample mean
-prob / (1-(1-prob)^size) # Population mean
+size * prob / (1-(1-prob)^size) # Population mean
(ii = dposbinom(0:size, size, prob))
cumsum(ii) - pposbinom(0:size, size, prob) # Should be 0s
@@ -88,11 +116,11 @@ table(qposbinom(runif(1000), size, prob))
round(dposbinom(1:10, size, prob) * 1000) # Should be similar
\dontrun{ barplot(rbind(dposbinom(x = 0:size, size, prob),
- dbinom(x = 0:size, size, prob)),
- beside = TRUE, col = c("blue","green"),
+ dbinom(x = 0:size, size, prob)),
+ beside = TRUE, col = c("blue", "green"),
main=paste("Positive-binomial(", size, ",", prob, ") (blue) vs",
- " Binomial(", size, ",", prob, ") (green)", sep=""),
- names.arg = as.character(0:size), las=1) }
+ " Binomial(", size, ",", prob, ") (green)", sep = ""),
+ names.arg = as.character(0:size), las = 1) }
# Simulated data example
nn = 1000; sizeval1 = 10; sizeval2 = 20
diff --git a/man/posgeomUC.Rd b/man/posgeomUC.Rd
index bd4699f..2aa790a 100644
--- a/man/posgeomUC.Rd
+++ b/man/posgeomUC.Rd
@@ -22,7 +22,7 @@ rposgeom(n, prob)
\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.
+ Fed into \code{\link[stats]{runif}}.
}
\item{prob}{
@@ -61,11 +61,12 @@ rposgeom(n, prob)
%}
\author{ T. W. Yee }
-\note{
- For \code{rposgeom()}, the arguments of the function are fed
- into \code{\link[stats:Geometric]{rgeom}} until \eqn{n} positive
- values are obtained. This may take a long time if \code{prob}
- has values close to 1.
+%\note{
+% 20120405; no longer true to a superior method:
+% For \code{rposgeom()}, the arguments of the function are fed
+% into \code{\link[stats:Geometric]{rgeom}} until \eqn{n} positive
+% values are obtained. This may take a long time if \code{prob}
+% has values close to 1.
% The family function \code{posgeometric} needs not be written.
@@ -73,11 +74,12 @@ rposgeom(n, prob)
% \eqn{prob}{prob} by maximum likelihood estimation.
-}
+%}
\seealso{
% \code{posgeometric},
\code{\link{zageometric}},
+ \code{\link{zigeometric}},
\code{\link[stats:Geometric]{rgeom}}.
@@ -86,7 +88,7 @@ rposgeom(n, prob)
prob <- 0.75; y = rposgeom(n = 1000, prob)
table(y)
mean(y) # Sample mean
-1/prob # Population mean
+1 / prob # Population mean
(ii <- dposgeom(0:7, prob))
cumsum(ii) - pposgeom(0:7, prob) # Should be 0s
diff --git a/man/posnegbinUC.Rd b/man/posnegbinUC.Rd
index c7df7b8..55fd3b4 100644
--- a/man/posnegbinUC.Rd
+++ b/man/posnegbinUC.Rd
@@ -21,11 +21,11 @@ rposnegbin(n, size, prob = NULL, munb = NULL)
\arguments{
\item{x, q}{vector of quantiles.}
\item{p}{vector of probabilities.}
- \item{n}{
- number of random values to return.
- If \code{length(n) > 1} then the length is taken to be the number required.
+ \item{n}{number of observations.
+ Fed into \code{\link[stats]{runif}}.
}
+
\item{size, prob, munb, log}{
Same arguments as that of an ordinary negative binomial distribution
(see \code{\link[stats:NegBinomial]{dnbinom}}).
@@ -49,11 +49,18 @@ rposnegbin(n, size, prob = NULL, munb = NULL)
\deqn{\mu / (1-p(0))}{%
munb / (1-p(0))}
where \eqn{\mu}{munb} the mean of an ordinary negative binomial distribution.
- The arguments of
- \code{rposnegbin()}
- are fed into
- \code{\link[stats:NegBinomial]{rnbinom}} until \eqn{n} positive values
- are obtained.
+
+
+
+
+% 20120405; no longer true to a superior method:
+% The arguments of
+% \code{rposnegbin()}
+% are fed into
+% \code{\link[stats:NegBinomial]{rnbinom}} until \eqn{n} positive values
+% are obtained.
+
+
}
\value{
@@ -75,44 +82,49 @@ for counts with extra zeros.
}
\author{ T. W. Yee }
-\note{
- The running time
- of \code{rposnegbin()}
- is slow when \code{munb} is very close to zero.
-
-}
+%\note{
+% 20120405; no longer true to a superior method:
+% The running time
+% of \code{rposnegbin()}
+% is slow when \code{munb} is very close to zero.
+%
+%}
\seealso{
\code{\link{posnegbinomial}},
- \code{\link[stats:NegBinomial]{rnbinom}},
- \code{\link{zanegbinomial}}.
+ \code{\link{zanegbinomial}},
+ \code{\link{zinegbinomial}},
+ \code{\link[stats:NegBinomial]{rnbinom}}.
+
% \code{\link[MASS]{rnegbin}},
+
}
\examples{
munb <- 5; size <- 4; n <- 1000
-table(y <- rposnegbin(n, munb=munb, size=size))
+table(y <- rposnegbin(n, munb = munb, size = size))
mean(y) # sample mean
-munb / (1 - (size/(size+munb))^size) # population mean
-munb / pnbinom(0, mu=munb, size=size, lower.tail = FALSE) # same as before
+munb / (1 - (size / (size + munb))^size) # population mean
+munb / pnbinom(0, mu = munb, size = size, lower.tail = FALSE) # same as before
x <- (-1):17
-(ii <- dposnegbin(x, munb=munb, size=size))
-max(abs(cumsum(ii) - pposnegbin(x, munb=munb, size=size))) # Should be 0
+(ii <- dposnegbin(x, munb = munb, size = size))
+max(abs(cumsum(ii) - pposnegbin(x, munb = munb, size = size))) # Should be 0
\dontrun{
x <- 0:10
-barplot(rbind(dposnegbin(x, munb=munb, size=size), dnbinom(x, mu=munb, size=size)),
+barplot(rbind(dposnegbin(x, munb = munb, size = size),
+ dnbinom(x, mu = munb, size = size)),
beside = TRUE, col = c("blue","green"),
- main=paste("dposnegbin(munb=", munb, ", size=", size, ") (blue) vs",
- " dnbinom(mu=", munb, ", size=", size, ") (green)", sep=""),
+ main = paste("dposnegbin(munb = ", munb, ", size = ", size, ") (blue) vs",
+ " dnbinom(mu = ", munb, ", size = ", size, ") (green)", sep = ""),
names.arg = as.character(x)) }
# Another test for pposnegbin()
nn <- 5000
-mytab <- cumsum(table(rposnegbin(nn, munb=munb, size=size))) / nn
-myans <- pposnegbin(sort(as.numeric(names(mytab))), munb=munb, size=size)
+mytab <- cumsum(table(rposnegbin(nn, munb = munb, size = size))) / nn
+myans <- pposnegbin(sort(as.numeric(names(mytab))), munb = munb, size = size)
max(abs(mytab - myans)) # Should be 0
}
\keyword{distribution}
diff --git a/man/pospoisUC.Rd b/man/pospoisUC.Rd
index ae5d1bb..ee38af2 100644
--- a/man/pospoisUC.Rd
+++ b/man/pospoisUC.Rd
@@ -21,10 +21,11 @@ rpospois(n, lambda)
\arguments{
\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.
+ \item{n}{number of observations.
+ Fed into \code{\link[stats]{runif}}.
}
+
\item{lambda}{
vector of positive means (of an ordinary Poisson distribution).
Short vectors are recycled.
@@ -63,10 +64,11 @@ rpospois(n, lambda)
\author{ T. W. Yee }
\note{
- For \code{rpospois}, the arguments of the function are fed
- into \code{\link[stats:Poisson]{rpois}} until \eqn{n} positive
- values are obtained. This may take a long time if \code{lambda}
- has values close to 0.
+% 20120405; no longer true to a superior method:
+% For \code{rpospois}, the arguments of the function are fed
+% into \code{\link[stats:Poisson]{rpois}} until \eqn{n} positive
+% values are obtained. This may take a long time if \code{lambda}
+% has values close to 0.
The family function \code{\link{pospoisson}} estimates
@@ -78,6 +80,7 @@ rpospois(n, lambda)
\seealso{
\code{\link{pospoisson}},
\code{\link{zapoisson}},
+ \code{\link{zipoisson}},
\code{\link[stats:Poisson]{rpois}}.
diff --git a/man/probit.Rd b/man/probit.Rd
index f8f8d14..1241b9c 100644
--- a/man/probit.Rd
+++ b/man/probit.Rd
@@ -58,21 +58,26 @@ probit(theta, earg = list(), inverse = FALSE, deriv = 0,
The arguments \code{short} and \code{tag} are used only if
\code{theta} is character.
+
}
\value{
For \code{deriv = 0}, the probit of \code{theta}, i.e.,
\code{qnorm(theta)} when \code{inverse = FALSE}, and if \code{inverse =
TRUE} then \code{pnorm(theta)}.
+
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.
+
}
\references{
McCullagh, P. and Nelder, J. A. (1989)
\emph{Generalized Linear Models}, 2nd ed. London: Chapman & Hall.
+
+
}
\author{ Thomas W. Yee }
@@ -80,36 +85,40 @@ probit(theta, earg = list(), inverse = FALSE, deriv = 0,
Numerical instability may occur when \code{theta} is close to 1 or 0.
One way of overcoming this is to use \code{earg}.
+
In terms of the threshold approach with cumulative probabilities for
an ordinal response this link function corresponds to the univariate
normal distribution (see \code{\link{normal1}}).
+
}
\seealso{
\code{\link{Links}},
\code{\link{logit}},
\code{\link{cloglog}},
\code{\link{cauchit}}.
+
+
}
\examples{
-p = seq(0.01, 0.99, by=0.01)
+p = seq(0.01, 0.99, by = 0.01)
probit(p)
-max(abs(probit(probit(p), inverse=TRUE) - p)) # Should be 0
+max(abs(probit(probit(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))
probit(p) # Has NAs
-probit(p, earg=list(bvalue= .Machine$double.eps)) # Has no NAs
-
-\dontrun{
-p = seq(0.01, 0.99, by=0.01)
-plot(p, logit(p), type="l", col="limegreen", ylab="transformation",
- lwd=2, las=1, main="Some probability link functions")
-lines(p, probit(p), col="purple", lwd=2)
-lines(p, cloglog(p), col="chocolate", lwd=2)
-lines(p, cauchit(p), col="tan", lwd=2)
-abline(v=0.5, h=0, lty="dashed")
+probit(p, earg = list(bvalue = .Machine$double.eps)) # Has no NAs
+
+\dontrun{p = seq(0.01, 0.99, by = 0.01); par(lwd = (mylwd <- 2))
+plot(p, logit(p), type = "l", col = "limegreen", ylab = "transformation",
+ las = 1, main = "Some probability link functions")
+lines(p, probit(p), col = "purple")
+lines(p, cloglog(p), col = "chocolate")
+lines(p, cauchit(p), col = "tan")
+abline(v = 0.5, h = 0, lty = "dashed")
legend(0.1, 4.0, c("logit", "probit", "cloglog", "cauchit"),
- col=c("limegreen","purple","chocolate","tan"), lwd=2) }
+ col = c("limegreen","purple","chocolate","tan"), lwd = mylwd)
+par(lwd = 1) }
}
\keyword{math}
\keyword{models}
diff --git a/man/propodds.Rd b/man/propodds.Rd
index be31bca..dcb782f 100644
--- a/man/propodds.Rd
+++ b/man/propodds.Rd
@@ -7,13 +7,13 @@
}
\usage{
-propodds(reverse = TRUE)
+propodds(reverse = TRUE, whitespace = FALSE)
}
\arguments{
- \item{reverse}{
+ \item{reverse, whitespace}{
Logical.
- Fed into the \code{reverse} argument of \code{\link{cumulative}}.
+ Fed into arguments of the same name in \code{\link{cumulative}}.
}
}
@@ -31,12 +31,14 @@ propodds(reverse = TRUE)
\code{cumulative(reverse = reverse, link = "logit", parallel = TRUE)}.
Please see \code{\link{cumulative}} for more details on this model.
+
}
\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{
@@ -70,20 +72,22 @@ contains further information and examples.
No check is made to verify that the response is ordinal;
see \code{\link[base:factor]{ordered}}.
+
}
\seealso{
\code{\link{cumulative}}.
+
}
\examples{
# Fit the proportional odds model, p.179, in McCullagh and Nelder (1989)
pneumo = transform(pneumo, let = log(exposure.time))
(fit = vglm(cbind(normal, mild, severe) ~ let, propodds, pneumo))
-depvar(fit) # Sample proportions
-weights(fit, type = "prior") # Number of observations
+depvar(fit) # Sample proportions
+weights(fit, type = "prior") # Number of observations
coef(fit, matrix = TRUE)
-constraints(fit) # Constraint matrices
+constraints(fit) # Constraint matrices
summary(fit)
# Check that the model is linear in let ----------------------
diff --git a/man/sinmad.Rd b/man/sinmad.Rd
index f2b28e8..94d8e1c 100644
--- a/man/sinmad.Rd
+++ b/man/sinmad.Rd
@@ -84,10 +84,7 @@ Hoboken, NJ, USA: Wiley-Interscience.
\author{ T. W. Yee }
\note{
- If the self-starting initial values fail, try experimenting with
- the initial value arguments, especially those whose default
- value is not \code{NULL}. Also, the constraint \eqn{-a < 1 < aq}
- may be violated as the iterations progress.
+ See the note in \code{\link{genbetaII}}.
}
@@ -108,7 +105,7 @@ Hoboken, NJ, USA: Wiley-Interscience.
\examples{
sdata = data.frame(y = rsinmad(n = 1000, exp(1), exp(2), exp(0)))
fit = vglm(y ~ 1, sinmad, sdata, trace = TRUE)
-fit = vglm(y ~ 1, sinmad, sdata, trace = TRUE, crit = "coef")
+fit = vglm(y ~ 1, sinmad(ishape1.a = exp(1)), sdata, trace = TRUE)
coef(fit, matrix = TRUE)
Coef(fit)
summary(fit)
diff --git a/man/sratio.Rd b/man/sratio.Rd
index c1f61ec..cfb3a87 100644
--- a/man/sratio.Rd
+++ b/man/sratio.Rd
@@ -8,7 +8,8 @@
}
\usage{
sratio(link = "logit", earg = list(),
- parallel = FALSE, reverse = FALSE, zero = NULL)
+ parallel = FALSE, reverse = FALSE, zero = NULL,
+ whitespace = FALSE)
}
%- maybe also 'usage' for other objects documented here.
\arguments{
@@ -46,6 +47,10 @@ sratio(link = "logit", earg = list(),
The default value means none are modelled as intercept-only terms.
}
+ \item{whitespace}{
+ See \code{\link{CommonVGAMffArguments}} for information.
+
+ }
}
\details{
In this help file the response \eqn{Y} is assumed to be a factor
@@ -119,6 +124,8 @@ contains further information and examples.
\section{Warning }{
No check is made to verify that the response is ordinal;
see \code{\link[base:factor]{ordered}}.
+
+
}
\seealso{
@@ -131,11 +138,14 @@ contains further information and examples.
\code{\link{probit}},
\code{\link{cloglog}},
\code{\link{cauchit}}.
+
+
}
\examples{
pneumo = transform(pneumo, let = log(exposure.time))
-(fit = vglm(cbind(normal,mild,severe) ~ let, sratio(parallel = TRUE), pneumo))
+(fit = vglm(cbind(normal, mild, severe) ~ let,
+ sratio(parallel = TRUE), data = pneumo))
coef(fit, matrix = TRUE)
constraints(fit)
predict(fit)
diff --git a/man/ucberk.Rd b/man/ucberk.Rd
new file mode 100644
index 0000000..2ff893b
--- /dev/null
+++ b/man/ucberk.Rd
@@ -0,0 +1,69 @@
+\name{ucberk}
+\alias{ucberk}
+\docType{data}
+\title{ University California Berkeley Graduate Admissions }
+\description{
+ University California Berkeley Graduate Admissions: counts
+ cross-classified by acceptance/rejection and gender, for
+ the six largest departments.
+
+}
+\usage{data(ucberk)}
+\format{
+ A data frame with 6 departmental groups with the following 5 columns.
+ \describe{
+ \item{m.deny}{Counts of men denied admission. }
+ \item{m.admit}{Counts of men admitted. }
+ \item{w.deny}{Counts of women denied admission. }
+ \item{w.admit}{Counts of women admitted. }
+ \item{dept}{Department (the six largest),
+ called \code{A}, code{B}, \dots, code{F}.
+ }
+ }
+}
+\details{
+ From Bickel et al. (1975),
+ the data consists of applications for admission to graduate
+ study at the University of California, Berkeley, for the
+ fall 1973 quarter.
+ In the admissions cycle for that quarter,
+ the Graduate Division at Berkeley received approximately
+ 15,000 applications, some of which were later withdrawn or
+ transferred to a different proposed entry quarter by the
+ applicants. Of the applications finally remaining for the
+ fall 1973 cycle 12,763 were sufficiently complete to permit
+ a decision.
+ There were about 101 graduate department and
+ interdepartmental graduate majors. There were 8442 male
+ applicants and 4321 female applicants. About 44 percent of
+ the males and about 35 percent of the females were admitted.
+ The data are well-known for illustrating Simpson's paradox.
+
+
+
+
+}
+%\source{
+%
+%
+%}
+\references{
+ Bickel, P. J., Hammel, E. A. and O'Connell, J. W. (1975)
+ Sex bias in graduate admissions: data from Berkeley.
+ \emph{Science}, \bold{187}(4175): 398--404.
+
+
+ Freedman, D., Pisani, R. and Purves, R. (1998)
+ Chapter 2 of \emph{Statistics}, 3rd. ed.,
+ W. W. Norton & Company.
+
+
+
+}
+\examples{
+summary(ucberk)
+}
+\keyword{datasets}
+% 7 February 1975
+% Bickel, et al., 187 (4175): 398-404
+
diff --git a/man/undocumented-methods.Rd b/man/undocumented-methods.Rd
index 4c51271..b5a656a 100644
--- a/man/undocumented-methods.Rd
+++ b/man/undocumented-methods.Rd
@@ -122,6 +122,37 @@
% \alias{formula,vsmooth.spline-method}
%
%
+%
+\alias{hatvalues,ANY-method}
+\alias{hatvalues,vlm-method}
+\alias{hatvalues,vglm-method}
+\alias{hatvalues,cao-method}
+\alias{hatvalues,qrrvglm-method}
+\alias{hatvalues,rcam-method}
+\alias{hatvalues,rrvglm-method}
+%
+%
+\alias{hatplot,ANY-method}
+\alias{hatplot,matrix-method}
+\alias{hatplot,vlm-method}
+\alias{hatplot,vglm-method}
+\alias{hatplot,cao-method}
+\alias{hatplot,qrrvglm-method}
+\alias{hatplot,rcam-method}
+\alias{hatplot,rrvglm-method}
+%
+%
+\alias{dfbeta,ANY-method}
+\alias{dfbeta,matrix-method}
+\alias{dfbeta,vlm-method}
+\alias{dfbeta,vglm-method}
+\alias{dfbeta,cao-method}
+\alias{dfbeta,qrrvglm-method}
+\alias{dfbeta,rcam-method}
+\alias{dfbeta,rrvglm-method}
+%
+%
+%
\alias{guplot,numeric-method}
\alias{guplot,vlm-method}
%\alias{model.frame,ANY-method}
@@ -169,6 +200,12 @@
\alias{model.matrix,vlm-method}
\alias{nobs,ANY-method}
\alias{nobs,vlm-method}
+\alias{npred,ANY-method}
+\alias{npred,vlm-method}
+\alias{npred,cao-method}
+\alias{npred,qrrvglm-method}
+\alias{npred,rcam-method}
+\alias{npred,rrvglm-method}
\alias{nvar,ANY-method}
\alias{nvar,vlm-method}
\alias{nvar,vgam-method}
diff --git a/man/vglm.Rd b/man/vglm.Rd
index 998e9de..c50d758 100644
--- a/man/vglm.Rd
+++ b/man/vglm.Rd
@@ -14,7 +14,7 @@ vglm(formula, family, data = list(), weights = NULL, subset = NULL,
coefstart = NULL, control = vglm.control(...), offset = NULL,
method = "vglm.fit", model = FALSE, x.arg = TRUE, y.arg = TRUE,
contrasts = NULL, constraints = NULL, extra = list(),
- form2 = NULL, qr.arg = FALSE, smart = TRUE, ...)
+ form2 = NULL, qr.arg = TRUE, smart = TRUE, ...)
}
%- maybe also `usage' for other objects documented here.
\arguments{
@@ -358,12 +358,14 @@ The \code{VGAM} Package.
\code{\link{vgam}}.
Methods functions include
\code{coef.vlm},
+ \code{\link{hatvaluesvlm}},
\code{\link{predictvglm}},
\code{summary.vglm},
\code{AIC.vglm},
\code{\link{lrtest_vglm}},
etc.
+
}
\examples{
diff --git a/man/vglm.control.Rd b/man/vglm.control.Rd
index a94da3f..c0cd8ed 100644
--- a/man/vglm.control.Rd
+++ b/man/vglm.control.Rd
@@ -10,7 +10,8 @@
\usage{
vglm.control(checkwz = TRUE, criterion = names(.min.criterion.VGAM),
epsilon = 1e-07, half.stepsizing = TRUE,
- maxit = 30, stepsize = 1, save.weight = FALSE,
+ maxit = 30, nowarning = FALSE,
+ stepsize = 1, save.weight = FALSE,
trace = FALSE, wzepsilon = .Machine$double.eps^0.75,
xij = NULL, ...)
}
@@ -52,7 +53,16 @@ vglm.control(checkwz = TRUE, criterion = names(.min.criterion.VGAM),
}
\item{maxit}{
- maximum number of Newton-Raphson/Fisher-scoring iterations allowed.
+ maximum number of (usually Fisher-scoring) iterations allowed.
+ Sometimes Newton-Raphson is used.
+
+
+ }
+ \item{nowarning}{
+ logical indicating whether to suppress a warning if
+ convergence is not obtained within \code{maxit} iterations.
+ This is ignored if \code{maxit = 1} is set.
+
}
\item{stepsize}{
--
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