[r-cran-vgam] 17/63: Import Upstream version 0.7-10
Andreas Tille
tille at debian.org
Tue Jan 24 13:54:24 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 ed1fa424f022055b5265eb9f0f4b9ee3300fcef0
Author: Andreas Tille <tille at debian.org>
Date: Tue Jan 24 14:16:49 2017 +0100
Import Upstream version 0.7-10
---
BUGS | 151 +
DESCRIPTION | 8 +-
NAMESPACE | 7 +-
NEWS | 30 +
R/aamethods.q | 75 +-
R/add1.vglm.q | 2 +-
R/attrassign.R | 2 +-
R/bAIC.q | 44 +-
R/build.terms.vlm.q | 34 +-
R/calibrate.q | 90 +-
R/cao.R | 58 +-
R/cao.fit.q | 492 ++--
R/coef.vlm.q | 28 +-
R/cqo.R | 3 +-
R/cqo.fit.q | 369 +--
R/deviance.vlm.q | 4 +-
R/effects.vglm.q | 2 +-
R/{family.aunivariate.q => family.aunivariate.R} | 234 +-
R/{family.basics.q => family.basics.R} | 293 +-
R/{family.binomial.q => family.binomial.R} | 442 +--
R/{family.bivariate.q => family.bivariate.R} | 429 +--
R/{family.categorical.q => family.categorical.R} | 573 ++--
R/{family.censored.q => family.censored.R} | 142 +-
R/{family.circular.q => family.circular.R} | 76 +-
R/{family.extremes.q => family.extremes.R} | 622 ++---
R/{family.fishing.q => family.fishing.R} | 13 +-
R/{family.functions.q => family.functions.R} | 58 +-
R/{family.genetic.q => family.genetic.R} | 134 +-
R/{family.glmgam.q => family.glmgam.R} | 344 +--
R/{family.loglin.q => family.loglin.R} | 18 +-
R/{family.mixture.q => family.mixture.R} | 110 +-
R/{family.nonlinear.q => family.nonlinear.R} | 46 +-
R/{family.normal.q => family.normal.R} | 230 +-
R/{family.positive.q => family.positive.R} | 118 +-
R/{family.qreg.q => family.qreg.R} | 435 +--
R/{family.rcqo.q => family.rcqo.R} | 122 +-
R/{family.rrr.q => family.rrr.R} | 838 +++---
R/{family.survival.q => family.survival.R} | 80 +-
R/{family.ts.q => family.ts.R} | 69 +-
R/{family.univariate.q => family.univariate.R} | 3243 +++++++++++-----------
R/{family.vglm.q => family.vglm.R} | 8 +-
R/{family.zeroinf.q => family.zeroinf.R} | 523 ++--
R/{fitted.vlm.q => fitted.vlm.R} | 18 +-
R/formula.vlm.q | 28 +-
R/generic.q | 2 +-
R/links.q | 479 ++--
R/logLik.vlm.q | 10 +-
R/model.matrix.vglm.q | 70 +-
R/mux.q | 76 +-
R/plot.vglm.q | 219 +-
R/predict.vgam.q | 120 +-
R/predict.vglm.q | 36 +-
R/predict.vlm.q | 106 +-
R/print.vglm.q | 36 +-
R/print.vlm.q | 16 +-
R/qrrvglm.control.q | 54 +-
R/qtplot.q | 155 +-
R/residuals.vlm.q | 76 +-
R/rrvglm.R | 62 +-
R/rrvglm.control.q | 54 +-
R/rrvglm.fit.q | 175 +-
R/s.q | 12 +-
R/s.vam.q | 38 +-
R/smart.R | 94 +-
R/step.vglm.q | 2 +-
R/summary.vgam.q | 70 +-
R/summary.vglm.q | 70 +-
R/summary.vlm.q | 50 +-
R/uqo.R | 218 +-
R/vgam.R | 81 +-
R/vgam.control.q | 28 +-
R/vgam.fit.q | 90 +-
R/vgam.match.q | 26 +-
R/vglm.R | 70 +-
R/vglm.control.q | 34 +-
R/vglm.fit.q | 100 +-
R/vlm.R | 46 +-
R/vlm.wfit.q | 55 +-
R/vsmooth.spline.q | 154 +-
R/zzz.R | 2 +-
data/backPain.R | 5 +
data/backPain.txt | 102 +
data/{chest.txt => chestnz.txt} | 0
data/nzmarital.R | 1809 ++++++++++++
inst/CITATION | 62 +
inst/doc/categoricalVGAM.Rnw | 2559 +++++++++++++++++
inst/doc/categoricalVGAM.pdf | Bin 0 -> 2956343 bytes
inst/doc/categoricalVGAMbib.bib | 611 ++++
inst/doc/jss.bst | 1647 +++++++++++
inst/doc/jss.cls | 473 ++++
man/AA.Aa.aa.Rd | 1 -
man/AB.Ab.aB.ab2.Rd | 1 -
man/ABO.Rd | 1 -
man/AICvlm.Rd | 8 +-
man/BratUC.Rd | 13 +-
man/Coef.qrrvglm-class.Rd | 4 +-
man/Coef.qrrvglm.Rd | 6 +-
man/CommonVGAMffArguments.Rd | 36 +-
man/DeLury.Rd | 5 +
man/Links.Rd | 26 +-
man/Opt.Rd | 14 +-
man/SurvS4-class.Rd | 4 +-
man/{Surv.Rd => SurvS4.Rd} | 17 +-
man/Tol.Rd | 16 +-
man/VGAM-package.Rd | 42 +-
man/acat.Rd | 21 +-
man/alaplace3.Rd | 44 +-
man/amh.Rd | 3 +-
man/amlbinomial.Rd | 22 +-
man/amlexponential.Rd | 23 +-
man/amlnormal.Rd | 55 +-
man/amlpoisson.Rd | 24 +-
man/auuc.Rd | 6 +-
man/backPain.Rd | 52 +
man/benfUC.Rd | 21 +-
man/benini.Rd | 10 +-
man/beniniUC.Rd | 11 +-
man/beta.ab.Rd | 16 +-
man/betaII.Rd | 6 +-
man/betabin.ab.Rd | 11 +-
man/betabinUC.Rd | 16 +-
man/betabinomial.Rd | 19 +-
man/betaff.Rd | 20 +-
man/betageomUC.Rd | 5 +-
man/betageometric.Rd | 14 +-
man/betanormUC.Rd | 26 +-
man/betaprime.Rd | 18 +-
man/binom2.or.Rd | 19 +-
man/binom2.orUC.Rd | 5 +-
man/binom2.rho.Rd | 8 +-
man/binom2.rhoUC.Rd | 2 +-
man/binomialff.Rd | 41 +-
man/bisa.Rd | 21 +-
man/borel.tanner.Rd | 4 +-
man/brat.Rd | 94 +-
man/bratt.Rd | 99 +-
man/calibrate.qrrvglm.Rd | 2 +
man/calibrate.qrrvglm.control.Rd | 5 +-
man/cao.Rd | 28 +-
man/cao.control.Rd | 47 +-
man/cardioid.Rd | 8 +-
man/cauchit.Rd | 10 +-
man/cauchy.Rd | 15 +-
man/ccoef-methods.Rd | 2 +-
man/ccoef.Rd | 2 +
man/cenpoisson.Rd | 32 +-
man/cgumbel.Rd | 5 +-
man/{chest.Rd => chestnz.Rd} | 8 +-
man/chisq.Rd | 6 +-
man/cloglog.Rd | 7 +
man/cnormal1.Rd | 18 +-
man/cqo.Rd | 121 +-
man/cratio.Rd | 23 +-
man/cumulative.Rd | 72 +-
man/dagum.Rd | 6 +-
man/dcnormal1.Rd | 4 +-
man/deplot.lmscreg.Rd | 5 +-
man/dexpbinomial.Rd | 5 +-
man/dirichlet.Rd | 10 +-
man/erf.Rd | 20 +-
man/erlang.Rd | 11 +-
man/expexp.Rd | 6 +-
man/expexp1.Rd | 12 +-
man/exponential.Rd | 24 +-
man/felix.Rd | 4 +-
man/fff.Rd | 48 +-
man/fgm.Rd | 3 +-
man/fisk.Rd | 5 +-
man/fnormal1.Rd | 14 +-
man/frechet.Rd | 8 +-
man/freund61.Rd | 7 +-
man/fsqrt.Rd | 8 +-
man/gamma1.Rd | 4 +-
man/gamma2.Rd | 18 +-
man/gamma2.ab.Rd | 15 +-
man/gammahyp.Rd | 12 +-
man/garma.Rd | 12 +-
man/gaussianff.Rd | 16 +-
man/genbetaII.Rd | 6 +-
man/genpoisson.Rd | 10 +-
man/geometric.Rd | 27 +-
man/gev.Rd | 17 +-
man/ggamma.Rd | 18 +-
man/golf.Rd | 18 +-
man/gpd.Rd | 43 +-
man/gumbel.Rd | 22 +-
man/gumbelIbiv.Rd | 10 +-
man/hspider.Rd | 16 +-
man/hzeta.Rd | 10 +-
man/hzetaUC.Rd | 1 +
man/iam.Rd | 4 -
man/identity.Rd | 1 +
man/inv.gaussianff.Rd | 3 +-
man/invparalogistic.Rd | 2 +-
man/kumar.Rd | 15 +-
man/laplace.Rd | 18 +-
man/laplaceUC.Rd | 7 +-
man/leipnik.Rd | 14 +-
man/lerch.Rd | 5 +-
man/levy.Rd | 13 +-
man/lgammaUC.Rd | 4 +-
man/lgammaff.Rd | 15 +-
man/lino.Rd | 8 +-
man/linoUC.Rd | 4 +-
man/lirat.Rd | 3 +-
man/lms.bcg.Rd | 20 +-
man/lms.bcn.Rd | 20 +-
man/lms.yjn.Rd | 15 +-
man/logUC.Rd | 3 +-
man/logff.Rd | 30 +-
man/logistic.Rd | 14 +-
man/logit.Rd | 8 +-
man/loglapUC.Rd | 2 +-
man/loglaplace.Rd | 3 +-
man/loglinb2.Rd | 11 +-
man/loglinb3.Rd | 3 +
man/loglog.Rd | 1 +
man/lognormal.Rd | 16 +-
man/logoff.Rd | 5 +-
man/lomax.Rd | 10 +-
man/lqnorm.Rd | 19 +-
man/lv.Rd | 8 +-
man/lvplot.qrrvglm.Rd | 50 +-
man/lvplot.rrvglm.Rd | 11 +-
man/maxwell.Rd | 5 +-
man/{MaxwellUC.Rd => maxwellUC.Rd} | 8 +-
man/mccullagh89.Rd | 8 +-
man/mckaygamma2.Rd | 6 +-
man/micmen.Rd | 5 +-
man/mix2exp.Rd | 22 +-
man/mix2normal1.Rd | 22 +-
man/mix2poisson.Rd | 22 +-
man/multinomial.Rd | 45 +-
man/negbinomial.Rd | 31 +-
man/normal1.Rd | 14 +-
man/nzmarital.Rd | 49 +
man/paralogistic.Rd | 12 +-
man/pareto1.Rd | 13 +-
man/paretoIV.Rd | 6 +-
man/persp.qrrvglm.Rd | 12 +-
man/plackUC.Rd | 9 +-
man/plotdeplot.lmscreg.Rd | 3 +-
man/plotqtplot.lmscreg.Rd | 2 +-
man/plotvgam.Rd | 11 +-
man/plotvgam.control.Rd | 14 +-
man/pneumo.Rd | 3 +-
man/poissonff.Rd | 32 +-
man/poissonp.Rd | 13 +-
man/polf.Rd | 33 +-
man/polonoUC.Rd | 6 +-
man/posbinomUC.Rd | 11 +-
man/posbinomial.Rd | 25 +-
man/posnegbinUC.Rd | 3 +-
man/posnegbinomial.Rd | 49 +-
man/posnormUC.Rd | 3 +-
man/posnormal1.Rd | 15 +-
man/pospoisUC.Rd | 10 +-
man/pospoisson.Rd | 19 +-
man/powl.Rd | 5 +-
man/predict.qrrvglm.Rd | 16 +-
man/predict.vglm.Rd | 6 +-
man/prentice74.Rd | 36 +-
man/probit.Rd | 3 +-
man/propodds.Rd | 99 +
man/prplot.Rd | 89 +
man/qrrvglm.control.Rd | 74 +-
man/qtplot.gumbel.Rd | 2 +-
man/qtplot.lmscreg.Rd | 2 +-
man/rcqo.Rd | 39 -
man/recexp1.Rd | 2 +-
man/reciprocal.Rd | 1 +
man/recnormal1.Rd | 2 +-
man/rhobit.Rd | 1 +
man/riceff.Rd | 6 +-
man/rig.Rd | 8 +-
man/rlplot.egev.Rd | 2 +-
man/rrvglm.control.Rd | 4 +-
man/s.Rd | 60 +-
man/simplex.Rd | 3 +-
man/sinmad.Rd | 6 +-
man/skellam.Rd | 16 +-
man/skellamUC.Rd | 2 +-
man/skewnormal1.Rd | 21 +-
man/slash.Rd | 4 +-
man/slashUC.Rd | 13 +-
man/smartpred.Rd | 2 +-
man/snormUC.Rd | 2 +-
man/sratio.Rd | 18 +-
man/studentt.Rd | 9 +-
man/tikuv.Rd | 3 +-
man/tobit.Rd | 28 +-
man/trplot.qrrvglm.Rd | 8 +-
man/undocumented-methods.Rd | 2 +
man/uqo.Rd | 6 +-
man/uqo.control.Rd | 2 +-
man/vgam.Rd | 9 +-
man/vgam.control.Rd | 51 +-
man/vglm.Rd | 10 +-
man/vglm.control.Rd | 12 +
man/vonmises.Rd | 10 +-
man/vsmooth.spline.Rd | 59 +-
man/wald.Rd | 8 +-
man/weibull.Rd | 4 +-
man/wffc.P2star.Rd | 7 +-
man/wffc.Rd | 27 +-
man/wffc.indiv.Rd | 5 +-
man/wffc.nc.Rd | 10 +-
man/wffc.teams.Rd | 9 +-
man/yeo.johnson.Rd | 22 +-
man/yulesimon.Rd | 8 +-
man/zanegbinUC.Rd | 13 +-
man/zanegbinomial.Rd | 20 +-
man/zapoisUC.Rd | 16 +-
man/zapoisson.Rd | 24 +-
man/zero.Rd | 4 +-
man/zeta.Rd | 32 +-
man/zetaUC.Rd | 6 +-
man/zetaff.Rd | 34 +-
man/zibinomUC.Rd | 7 +-
man/zibinomial.Rd | 8 +-
man/zinegbinUC.Rd | 7 +-
man/zinegbinomial.Rd | 31 +-
man/zipebcom.Rd | 14 +-
man/zipf.Rd | 9 +-
man/zipfUC.Rd | 7 +-
man/zipoisUC.Rd | 11 +-
man/zipoisson.Rd | 46 +-
src/cqof.f | 449 +--
src/fgam.f | 15 +-
src/lms.f | 2 +
src/rgam.f | 5 +-
src/tyeepolygamma.f | 12 +-
src/vmux.f | 3 +-
src/zeta.f | 138 -
src/zeta4.c | 258 ++
335 files changed, 16904 insertions(+), 8741 deletions(-)
diff --git a/BUGS b/BUGS
new file mode 100755
index 0000000..f3cbb77
--- /dev/null
+++ b/BUGS
@@ -0,0 +1,151 @@
+Here is a list of known bugs.
+
+
+
+2009/07/13
+cqo() fails... I think it is due to initial values being faulty.
+Hope to look into it soon.
+
+
+
+
+
+
+
+
+2009/06/18
+
+For a given VGAM family function,
+arguments such as parallel, exchangeable etc.
+will not work if the RHS of the formula is an intercept only.
+For example,
+parallel = FALSE ~ 1
+and
+exchangeable = TRUE ~ 1
+will fail.
+Instead, try something like
+parallel = TRUE ~ x2 + x3 + x4 -1
+and
+exchangeable = FAlSE ~ x2 + x3 + x4 + x5 -1
+respectively.
+
+
+2009/01/01
+
+prediction with vgam( ~ offset(myoffsetmatrix) + ... )
+fails inside a function because myoffsetmatrix cannot be found.
+
+
+
+2008/08/12
+
+Under Windows, the vgam() example involving the Hunua data seems
+to fail. It is under investigation.
+
+
+
+2008/08/04
+
+VGAM interferes with other packages, e.g., predict() and summary().
+This is due to S3 and S4 interference, and currently I haven't sussed out
+the full details (e.g., NAMESPACES). For now it is best to attach VGAM
+only when needed and detach it when other packages are to be used. This
+can be done with
+
+library(VGAM)
+
+and
+
+detach("package:VGAM")
+
+
+
+2008/05/16
+
+zipf() did not handle 0 < s < 1.
+The prerelease version fixes this.
+
+
+
+2008/03/12
+
+A call such as
+
+mydof = 4
+Fit = vgam(y ~ s(x, df=mydof), fam=poissonff)
+
+will result in failure when
+
+plot(Fit)
+
+Instead, one needs
+
+Fit = vgam(y ~ s(x, df=4), fam=poissonff)
+
+
+
+2008/02/16
+
+The VGAM package interferes with other functions, for example, if VGAM
+is loaded and lmobject is an "lm" object then
+
+fitted(lmobject)
+predict(lmobject)
+resid(lmobject)
+residuals(lmobject)
+
+will fail.
+
+
+
+2006/05/18
+
+dirmul() is not working yet.
+
+
+
+
+2005/11/16
+
+cao() now works in Windows.
+The argument xij does not work properly.
+
+
+
+2005/8/31
+
+The windows version of cao() seems to hang.
+It does not hang in Linux.
+
+
+2005/6/10
+
+cao() works in Linux but seems to hang in Windows.
+The latter (distributed in a .zip file format) is made from a R Cross
+Build process which may be a reason for the bug. I'm slowly looking
+into the bug.
+
+
+2005/5/6
+
+The VGAM package interferes with other code, including glm(). This may
+be due to the smart prediction code, or be due to the NAMESPACE facility.
+In order to use other functions outside the VGAM package you may need
+to type "detach()".
+
+
+2003/7/14
+
+vgam(y ~ s(x, df=2), subset= x > 2)
+
+will fail in R because the subset argument has the effect that the
+"df" and "spar" attributes are removed from the data frame containing
+the smoothing variables.
+
+Current fix: create a separate data frame satisfying the subset=
+condition, and then run vgam() on this smaller data frame.
+
+Thanks for Eugene Zwane for finding this bug.
+
+
+
diff --git a/DESCRIPTION b/DESCRIPTION
index f735b8e..c8bedf2 100755
--- a/DESCRIPTION
+++ b/DESCRIPTION
@@ -1,6 +1,6 @@
Package: VGAM
-Version: 0.7-9
-Date: 2009-06-15
+Version: 0.7-10
+Date: 2010-01-05
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>
@@ -15,6 +15,6 @@ License: GPL-2
URL: http://www.stat.auckland.ac.nz/~yee/VGAM
LazyLoad: yes
LazyData: yes
-Packaged: 2009-06-15 17:14:11 UTC; yee
+Packaged: 2010-01-05 11:25:57 UTC; zeileis
Repository: CRAN
-Date/Publication: 2009-06-16 13:09:39
+Date/Publication: 2010-01-05 11:53:59
diff --git a/NAMESPACE b/NAMESPACE
index 49853f2..5bb1270 100644
--- a/NAMESPACE
+++ b/NAMESPACE
@@ -1,5 +1,5 @@
# These functions are
-# Copyright (C) 1998-2009 T.W. Yee, University of Auckland. All rights reserved.
+# Copyright (C) 1998-2010 T.W. Yee, University of Auckland. All rights reserved.
@@ -162,7 +162,7 @@ rlplot, rlplot.vglm, rrar.control,
rrvglm.control.Gaussian)
export(
-Surv, is.SurvS4, as.character.SurvS4, print.SurvS4,
+SurvS4, is.SurvS4, as.character.SurvS4, print.SurvS4,
simple.exponential, simple.poisson,
mbinomial,
seq2binomial, size.binomial,
@@ -272,6 +272,7 @@ export(
AA.Aa.aa, AB.Ab.aB.ab2, AB.Ab.aB.ab, ABO, acat,
beta.ab, betaff,
dbetageom, pbetageom, rbetageom, betageometric,
+dbetanorm, pbetanorm, qbetanorm, rbetanorm, # betanorm,
betaprime,
betaII,
zipebcom,
@@ -283,7 +284,7 @@ calibrate, cao.control,
cao, ccoef, cdf.lmscreg, cgo, chisq, clo,
Coef.qrrvglm, Coef, Coef.rrvglm, Coef.vlm,
predict.qrrvglm,
-cratio, cumulative)
+cratio, cumulative, propodds, prplot, prplot.control)
export(
deplot.lmscreg, dirichlet,
exponential, G1G2G3)
diff --git a/NEWS b/NEWS
index 8fa3e6f..f369c06 100755
--- a/NEWS
+++ b/NEWS
@@ -5,6 +5,36 @@
**************************************************
+
+ CHANGES IN VGAM VERSION 0.7-10
+
+NEW FEATURES
+
+ o Surv() renamed to Surv4(), class "SurvS4" renamed to "Surv4".
+ o coef(summary(vglmObject)) returns a 3-column matrix of estimates,
+ standard errors and Wald statistics, rather than coef(vglmObject)
+ in the past.
+ o Improved VGAM family functions: fff() uses simulated Fisher
+ scoring now and has slightly better initial values.
+ o New VGAM family functions:
+ propodds(reverse) is equivalent to
+ cumulative(parallel=TRUE, reverse=reverse) (for convenience only).
+ o Compatible with R 2.10.1 and the article "The VGAM package
+ for categorical data analysis," Journal of Statistical Software,
+ 2010. A vignette based on this paper is included.
+ o Argument w.als renamed to w.aml in amlnormal().
+
+
+BUG FIXES
+
+ o VGAM family functions: fff() had poor initial values.
+ o betabinomial()@loglikelihood required 'ycounts' to be integer.
+ o [dpqr]betanorm() were written but not in the NAMESPACE.
+
+
+
+
+
CHANGES IN VGAM VERSION 0.7-9
NEW FEATURES
diff --git a/R/aamethods.q b/R/aamethods.q
index f7093a9..42a1d0e 100644
--- a/R/aamethods.q
+++ b/R/aamethods.q
@@ -1,5 +1,5 @@
# These functions are
-# Copyright (C) 1998-2009 T.W. Yee, University of Auckland. All rights reserved.
+# Copyright (C) 1998-2010 T.W. Yee, University of Auckland. All rights reserved.
@@ -9,7 +9,7 @@
is.Numeric <- function(x, allowable.length=Inf, integer.valued=FALSE, positive=FALSE)
- if(all(is.numeric(x)) && all(is.finite(x)) &&
+ if (all(is.numeric(x)) && all(is.finite(x)) &&
(if(is.finite(allowable.length)) length(x)==allowable.length else TRUE) &&
(if(integer.valued) all(x==round(x)) else TRUE) &&
(if(positive) all(x>0) else TRUE)) TRUE else FALSE
@@ -18,15 +18,18 @@ is.Numeric <- function(x, allowable.length=Inf, integer.valued=FALSE, positive=F
VGAMenv = new.env()
+
+
+
.onLoad <- function(lib, pkg) require(methods) # 25/1/05
-if(!any(search()=="package:methods"))
+if (!any(search()=="package:methods"))
library(methods)
-if(!any(search()=="package:splines"))
+if (!any(search()=="package:splines"))
require(splines)
@@ -66,22 +69,22 @@ prototype = .VGAM.prototype.list)
valid.vglmff = function(object) {
compulsory = c("initialize", "weight", "deriv", "inverse")
for(ii in compulsory) {
- if(!length(slot(object, ii)))
+ if (!length(slot(object, ii)))
stop("slot ", ii, " is empty")
}
- if(length(as.list(object at inverse)) != 3)
+ if (length(as.list(object at inverse)) != 3)
stop("wrong number of arguments in object at inverse")
}
-if(FALSE)
+if (FALSE)
setValidity("vglmff", valid.vglmff)
-if(!isGeneric("print"))
+if (!isGeneric("print"))
setGeneric("print", function(x, ...) standardGeneric("print"),
package="VGAM")
@@ -89,15 +92,15 @@ if(!isGeneric("print"))
print.vglmff <- function(x, ...) {
f <- x at vfamily
- if(is.null(f))
+ if (is.null(f))
stop("not a VGAM family function")
nn <- x at blurb
- if(!length(nn))
+ if (!length(nn))
invisible(return(x))
cat("Family: ", f[1], "\n")
- if(length(f)>1) cat("Informal classes:", paste(f, collapse=", "), "\n")
+ if (length(f)>1) cat("Informal classes:", paste(f, collapse=", "), "\n")
cat("\n")
for(ii in 1:length(nn))
@@ -225,7 +228,7 @@ setClass("summary.vlm", representation(
-if(FALSE)
+if (FALSE)
setClass("qrrvglm", representation(
"assign" = "list",
"call" = "call",
@@ -271,7 +274,7 @@ if(FALSE)
-if(FALSE)
+if (FALSE)
setAs("qrrvglm", "vglm", function(from)
new("vglm", "extra"=from at extra,
"family"=from at family,
@@ -319,17 +322,17 @@ setMethod("summary", "grc",
summary.grc(object, ...))
-if(FALSE) {
+if (FALSE) {
setClass("vfamily",
representation("list"))
}
-if(!isGeneric("Coef"))
+if (!isGeneric("Coef"))
setGeneric("Coef", function(object, ...) standardGeneric("Coef"),
package="VGAM")
-if(!isGeneric("Coefficients"))
+if (!isGeneric("Coefficients"))
setGeneric("Coefficients", function(object, ...)
standardGeneric("Coefficients"),
package="VGAM")
@@ -341,15 +344,15 @@ setGeneric("Coefficients", function(object, ...)
-if(!isGeneric("logLik"))
+if (!isGeneric("logLik"))
setGeneric("logLik", function(object, ...) standardGeneric("logLik"),
package="VGAM")
-if(!isGeneric("plot"))
+if (!isGeneric("plot"))
setGeneric("plot", function(x, y, ...) standardGeneric("plot"),
package="VGAM")
-if(!isGeneric("vcov"))
+if (!isGeneric("vcov"))
setGeneric("vcov", function(object, ...) standardGeneric("vcov"),
package="VGAM")
@@ -373,11 +376,11 @@ setClass(Class="cao",
contains="vgam")
-if(!isGeneric("lvplot"))
+if (!isGeneric("lvplot"))
setGeneric("lvplot", function(object, ...) standardGeneric("lvplot"),
package="VGAM")
-if(!isGeneric("ccoef"))
+if (!isGeneric("ccoef"))
setGeneric("ccoef", function(object, ...) standardGeneric("ccoef"),
package="VGAM")
@@ -385,34 +388,34 @@ if(!isGeneric("ccoef"))
-if(!isGeneric("coef"))
+if (!isGeneric("coef"))
setGeneric("coef", function(object, ...) standardGeneric("coef"),
package="VGAM")
-if(!isGeneric("coefficients"))
+if (!isGeneric("coefficients"))
setGeneric("coefficients", function(object, ...)
standardGeneric("coefficients"),
package="VGAM")
-if(!isGeneric("df.residual"))
+if (!isGeneric("df.residual"))
setGeneric("df.residual", function(object, ...)
standardGeneric("df.residual"),
package="VGAM")
-if(!isGeneric("fitted"))
+if (!isGeneric("fitted"))
setGeneric("fitted", function(object, ...) standardGeneric("fitted"),
package="VGAM")
- if(!isGeneric("fitted.values"))
+ if (!isGeneric("fitted.values"))
setGeneric("fitted.values", function(object, ...)
standardGeneric("fitted.values"),
package="VGAM")
-if(!isGeneric("model.matrix"))
+if (!isGeneric("model.matrix"))
setGeneric("model.matrix", function(object, ...)
standardGeneric("model.matrix"))
-if(!isGeneric("model.frame"))
+if (!isGeneric("model.frame"))
setGeneric("model.frame", function(formula, ...)
standardGeneric("model.frame"))
@@ -420,19 +423,19 @@ if(!isGeneric("model.frame"))
-if(!isGeneric("predict"))
+if (!isGeneric("predict"))
setGeneric("predict", function(object, ...) standardGeneric("predict"))
-if(!isGeneric("resid"))
+if (!isGeneric("resid"))
setGeneric("resid", function(object, ...) standardGeneric("resid"))
-if(!isGeneric("residuals"))
+if (!isGeneric("residuals"))
setGeneric("residuals", function(object, ...) standardGeneric("residuals"),
package="VGAM")
-if(!isGeneric("weights"))
+if (!isGeneric("weights"))
setGeneric("weights", function(object, ...) standardGeneric("weights"),
package="VGAM")
@@ -440,23 +443,23 @@ if(!isGeneric("weights"))
-if(!isGeneric("AIC"))
+if (!isGeneric("AIC"))
setGeneric("AIC", function(object, ..., k=2) standardGeneric("AIC"),
package="VGAM")
- if(!isGeneric("formula"))
+ if (!isGeneric("formula"))
setGeneric("formula", function(x, ...) standardGeneric("formula"),
package="VGAM")
- if(!isGeneric("case.names"))
+ if (!isGeneric("case.names"))
setGeneric("case.names", function(object, ...)
standardGeneric("case.names"),
package="VGAM")
- if(!isGeneric("variable.names"))
+ if (!isGeneric("variable.names"))
setGeneric("variable.names", function(object, ...)
standardGeneric("variable.names"),
package="VGAM")
diff --git a/R/add1.vglm.q b/R/add1.vglm.q
index 14ac247..77388a5 100644
--- a/R/add1.vglm.q
+++ b/R/add1.vglm.q
@@ -1,5 +1,5 @@
# These functions are
-# Copyright (C) 1998-2009 T.W. Yee, University of Auckland. All rights reserved.
+# Copyright (C) 1998-2010 T.W. Yee, University of Auckland. All rights reserved.
diff --git a/R/attrassign.R b/R/attrassign.R
index d80e1c0..fc7806c 100644
--- a/R/attrassign.R
+++ b/R/attrassign.R
@@ -1,5 +1,5 @@
# These functions are
-# Copyright (C) 1998-2009 T.W. Yee, University of Auckland. All rights reserved.
+# Copyright (C) 1998-2010 T.W. Yee, University of Auckland. All rights reserved.
diff --git a/R/bAIC.q b/R/bAIC.q
index 1642d22..81bc7dc 100644
--- a/R/bAIC.q
+++ b/R/bAIC.q
@@ -1,5 +1,5 @@
# These functions are
-# Copyright (C) 1998-2009 T.W. Yee, University of Auckland. All rights reserved.
+# Copyright (C) 1998-2010 T.W. Yee, University of Auckland. All rights reserved.
@@ -8,46 +8,43 @@
-if(TRUE) {
+if (TRUE) {
AICvlm = function(object, ..., k=2) {
estdisp = object at misc$estimated.dispersion
- no.dpar = if(length(estdisp) && is.logical(estdisp) && estdisp)
+ no.dpar = if (length(estdisp) && is.logical(estdisp) && estdisp)
length(object at misc$dispersion) else 0
-2 * logLik.vlm(object, ...) + k * (length(coefvlm(object)) + no.dpar)
}
+
AICvgam = function(object, ..., k=2) {
estdisp = object at misc$estimated.dispersion
- no.dpar = if(length(estdisp) && is.logical(estdisp) && estdisp)
+ no.dpar = if (length(estdisp) && is.logical(estdisp) && estdisp)
length(object at misc$dispersion) else 0
- nldf = if(is.Numeric(object at nl.df)) sum(object at nl.df) else 0
+ nldf = if (is.Numeric(object at nl.df)) sum(object at nl.df) else 0
-2 * logLik.vlm(object, ...) + k * (length(coefvlm(object)) + no.dpar + nldf)
}
+
AICrrvglm = function(object, ..., k=2) {
- print("20090316; k in AICrrvglm(); zz")
- print( k )
estdisp = object at misc$estimated.dispersion
- no.dpar = if(length(estdisp) && is.logical(estdisp) && estdisp)
+ no.dpar = if (length(estdisp) && is.logical(estdisp) && estdisp)
length(object at misc$dispersion) else 0
Structural.zero = object at control$Structural.zero
MMM = object at misc$M
Rank = object at control$Rank
elts.tildeA = (MMM - Rank - length(Structural.zero)) * Rank
- print("object at control$Structural.zero")
- print("object at control$Structural.zero")
-2 * logLik.vlm(object, ...) +
k * (length(coefvlm(object)) + no.dpar + elts.tildeA)
}
+
AICqrrvglm = function(object, ..., k=2) {
- print("20090316; k in AICqrrvglm(); zz")
- print( k )
estdisp = object at misc$estimated.dispersion
- no.dpar = if(length(estdisp) && is.logical(estdisp) && estdisp)
+ no.dpar = if (length(estdisp) && is.logical(estdisp) && estdisp)
length(object at misc$dispersion) else 0
Structural.zero = object at control$Structural.zero
MMM = object at misc$M
@@ -56,21 +53,24 @@ AICqrrvglm = function(object, ..., k=2) {
EqualTolerances = object at control$EqualTolerances
ITolerances = object at control$ITolerances
- if(!(length(EqualTolerances) == 1 && is.logical(EqualTolerances)))
+ if (!(length(EqualTolerances) == 1 && is.logical(EqualTolerances)))
stop("could not determine whether the fitted object used an ",
"equal-tolerances assumption based on argument 'EqualTolerances'")
- if(!(length(ITolerances) == 1 && is.logical(ITolerances)))
+ if (!(length(ITolerances) == 1 && is.logical(ITolerances)))
stop("could not determine whether the fitted object used an ",
"equal-tolerances assumption based on argument 'ITolerances'")
- NOS = if(length(object at y)) ncol(object at y) else MMM
+ NOS = if (length(object at y)) ncol(object at y) else MMM
MSratio = MMM / NOS # First value is g(mean) = quadratic form in l
- if(round(MSratio) != MSratio) stop("'MSratio' is not an integer")
+ if (round(MSratio) != MSratio) stop("'MSratio' is not an integer")
elts.D = ifelse(ITolerances || EqualTolerances, 1, NOS) * Rank*(Rank+1)/2
deviance(object, ...) +
k * (length(coefvlm(object)) + no.dpar + elts.tildeA + elts.D)
}
+
+
+
setMethod("AIC", "vlm",
function(object, ..., k=2)
AICvlm(object, ..., k=k))
@@ -98,11 +98,7 @@ setMethod("AIC", "qrrvglm",
-
-
-
-
-if(FALSE) {
+if (FALSE) {
@@ -119,11 +115,11 @@ AICrrvglm = function(object, ..., k=2) {
stop("not working yet")
crit = logLik.vlm(object)
sign = -2
- if(!length(crit) || !is.numeric(crit)) {
+ if (!length(crit) || !is.numeric(crit)) {
crit = deviance(object)
sign = 1
}
- if(!length(crit) || !is.numeric(crit))
+ if (!length(crit) || !is.numeric(crit))
stop("cannot get at the deviance or loglikelihood of the object")
sign * crit + 2 * (length(coef(object)) +
diff --git a/R/build.terms.vlm.q b/R/build.terms.vlm.q
index b45f930..f70fcea 100644
--- a/R/build.terms.vlm.q
+++ b/R/build.terms.vlm.q
@@ -1,9 +1,9 @@
# These functions are
-# Copyright (C) 1998-2009 T.W. Yee, University of Auckland. All rights reserved.
+# Copyright (C) 1998-2010 T.W. Yee, University of Auckland. All rights reserved.
- if(!isGeneric("terms"))
+ if (!isGeneric("terms"))
setGeneric("terms", function(x, ...) standardGeneric("terms"))
@@ -12,10 +12,10 @@
terms.vlm = function(x, ...) {
v = x at terms
- if(!length(v))
+ if (!length(v))
stop("terms slot is empty")
v = v$terms
- if(!length(v))
+ if (!length(v))
stop("no terms component")
v
}
@@ -32,14 +32,14 @@ Build.terms.vlm = function(x, coefs, cov = NULL, assign, collapse = TRUE, M,
cov.true = !is.null(cov)
- if(collapse) {
+ if (collapse) {
fit = matrix(x %*% coefs, ncol=M, byrow=TRUE)
dimnames(fit) = dimname
- if(M==1)
+ if (M==1)
fit = c(fit)
- if(cov.true) {
+ if (cov.true) {
var = ((x %*% cov) * x) %*% rep(1, length(coefs))
- list(fitted.values = fit, se.fit = if(M==1) c(sqrt(var)) else
+ list(fitted.values = fit, se.fit = if (M==1) c(sqrt(var)) else
matrix(sqrt(var), ncol=M, byrow=TRUE, dimnames=dimname))
} else {
fit
@@ -47,42 +47,42 @@ Build.terms.vlm = function(x, coefs, cov = NULL, assign, collapse = TRUE, M,
} else {
constant = attr(x, "constant")
- if(!is.null(constant)) {
+ if (!is.null(constant)) {
constant = as.vector( t(coefmat) %*% constant )
}
- if(missing(assign))
+ if (missing(assign))
assign = attr(x, "assign")
- if(is.null(assign))
+ if (is.null(assign))
stop("Need an 'assign' list")
fit = array(0, c(nrow(x), length(assign)),
list(dimnames(x)[[1]], names(assign)))
- if(cov.true)
+ if (cov.true)
se = fit
TL = sapply(assign, length)
simple = TL == 1
complex = TL > 1
- if(any(simple)) {
+ if (any(simple)) {
asss = unlist(assign[simple])
ones = rep(1, nrow(x))
fit[, simple] = x[, asss] * outer(ones, coefs[asss])
- if(cov.true)
+ if (cov.true)
se[,simple] = abs(x[,asss]) * outer(ones, sqrt(diag(cov))[asss])
}
- if(any(complex)) {
+ if (any(complex)) {
assign = assign[complex]
for(term in names(assign)) {
TT = assign[[term]]
xt = x[, TT]
fit[, term] = xt %*% coefs[TT]
- if(cov.true)
+ if (cov.true)
se[, term] = sqrt(drop(((xt %*% cov[TT, TT]) * xt) %*%
rep(1, length(TT))))
}
}
attr(fit, "constant") = constant
- if(cov.true) list(fitted.values = fit, se.fit = se) else fit
+ if (cov.true) list(fitted.values = fit, se.fit = se) else fit
}
}
diff --git a/R/calibrate.q b/R/calibrate.q
index c6d9601..8acffda 100644
--- a/R/calibrate.q
+++ b/R/calibrate.q
@@ -1,5 +1,5 @@
# These functions are
-# Copyright (C) 1998-2009 T.W. Yee, University of Auckland. All rights reserved.
+# Copyright (C) 1998-2010 T.W. Yee, University of Auckland. All rights reserved.
@@ -11,13 +11,13 @@
calibrate.qrrvglm.control = function(object,
trace=FALSE, # passed into optim()
Method.optim="BFGS", # passed into optim(method=Method)
- gridSize = if(Rank==1) 9 else 5,
+ gridSize = if (Rank==1) 9 else 5,
varlvI = FALSE, ...) {
Rank = object at control$Rank
EqualTolerances = object at control$EqualTolerances
- if(!is.Numeric(gridSize, positive=TRUE, integer=TRUE, allow=1))
+ if (!is.Numeric(gridSize, positive=TRUE, integer=TRUE, allow=1))
stop("bad input for 'gridSize'")
- if(gridSize < 2)
+ if (gridSize < 2)
stop("gridSize must be >= 2")
list(# maxit=Maxit.optim, # Note the name change
trace=as.numeric(trace)[1],
@@ -35,67 +35,67 @@ calibrate.qrrvglm = function(object,
type=c("lv","predictors","response","vcov","all3or4"),
initial.vals=NULL, ...) {
- Quadratic = if(is.logical(object at control$Quadratic))
+ Quadratic = if (is.logical(object at control$Quadratic))
object at control$Quadratic else FALSE # T if CQO, F if CAO
- if(!length(newdata)) {
- if(!length(object at y)) stop("no newdata") else
+ if (!length(newdata)) {
+ if (!length(object at y)) stop("no newdata") else
newdata = data.frame(object at y)
}
- if(mode(type) != "character" && mode(type) != "name")
+ if (mode(type) != "character" && mode(type) != "name")
type <- as.character(substitute(type))
type <- match.arg(type, c("lv","predictors","response","vcov","all3or4"))[1]
- if(!Quadratic && type=="vcov")
+ if (!Quadratic && type=="vcov")
stop("cannot have 'type=\"vcov\"' when object is a \"cao\" object")
- if(is.vector(newdata))
+ if (is.vector(newdata))
newdata = rbind(newdata)
- if(!is.matrix(newdata))
+ if (!is.matrix(newdata))
newdata = as.matrix(newdata)
newdata = newdata[,object at misc$ynames,drop=FALSE]
obfunct = slot(object at family, object at misc$criterion) # Objective function
- minimize.obfunct = if(Quadratic) object at control$min.criterion else
+ minimize.obfunct = if (Quadratic) object at control$min.criterion else
TRUE # Logical; TRUE for CAO objects because deviance is minimized
- if(!is.logical(minimize.obfunct))
+ if (!is.logical(minimize.obfunct))
stop("object at control$min.criterion is not a logical")
optim.control = calibrate.qrrvglm.control(object=object, ...) # For cao too
- if((Rank <- object at control$Rank) > 2)
+ if ((Rank <- object at control$Rank) > 2)
stop("currently can only handle Rank=1 and 2")
- Coefobject = if(Quadratic) {
+ Coefobject = if (Quadratic) {
Coef(object, varlvI=optim.control$varlvI)
} else {
Coef(object)
}
- if(!length(initial.vals)) {
+ if (!length(initial.vals)) {
L = apply(Coefobject at lv, 2, min)
U = apply(Coefobject at lv, 2, max)
- initial.vals = if(Rank==1)
+ initial.vals = if (Rank==1)
cbind(seq(L, U, length=optim.control$gridSize)) else
expand.grid(seq(L[1], U[1], length=optim.control$gridSize),
seq(L[2], U[2], length=optim.control$gridSize))
}
ok = length(object at control$colx1.index)==1 &&
names(object at control$colx1.index) == "(Intercept)"
- if(!ok) stop("The x1 vector must be an intercept only")
+ if (!ok) stop("The x1 vector must be an intercept only")
nn = nrow(newdata)
BestOFpar = NULL # It may be more efficient not to append
BestOFvalues = NULL # Best OF objective function values
for(i1 in 1:nn) {
- if(optim.control$trace)
+ if (optim.control$trace)
cat("\nOptimizing for observation", i1, "-----------------\n")
OFvalues = OFpar = NULL # OF means objective function
for(ii in 1:nrow(initial.vals)) {
- if(optim.control$trace) {
+ if (optim.control$trace) {
cat("Starting from grid-point", ii, ":")
flush.console()
}
- ans = if(is.R()) {
- if(Quadratic)
+ ans = if (is.R()) {
+ if (Quadratic)
optim(par=initial.vals[ii,],
fn=.my.calib.objfunction.qrrvglm,
method=optim.control$Method.optim, # "BFGS", or "CG" or ...
@@ -124,26 +124,26 @@ calibrate.qrrvglm = function(object,
} else
stop("not implemented in S-PLUS yet")
- if(optim.control$trace) {
- if(ans$convergence == 0)
+ if (optim.control$trace) {
+ if (ans$convergence == 0)
cat("Successful convergence\n") else
cat("Unsuccessful convergence\n")
flush.console()
}
- if(ans$convergence == 0) {
+ if (ans$convergence == 0) {
OFvalues = c(OFvalues, ans$value)
OFpar = rbind(OFpar, ans$par)
}
}
- if(length(OFpar)) {
- index = if(minimize.obfunct)
+ if (length(OFpar)) {
+ index = if (minimize.obfunct)
(1:nrow(OFpar))[OFvalues==min(OFvalues)] else
(1:nrow(OFpar))[OFvalues==max(OFvalues)]
- if(length(index) > 1) {
+ if (length(index) > 1) {
warning(paste("multiple solutions found for observation ", i1,
". Choosing one randomly.", sep=""))
index = sample(index, size=1)
- } else if(length(index) == 0)
+ } else if (length(index) == 0)
stop("length(index) is zero")
BestOFpar = rbind(BestOFpar, OFpar[index,])
BestOFvalues = c(BestOFvalues, OFvalues[index])
@@ -154,25 +154,25 @@ calibrate.qrrvglm = function(object,
}
pretty = function(BestOFpar, newdata, Rank) {
- if(Rank==1) {
+ if (Rank==1) {
BestOFpar = c(BestOFpar)
names(BestOFpar) = dimnames(newdata)[[1]]
} else
dimnames(BestOFpar) = list(dimnames(newdata)[[1]],
- if(Rank==1) "lv" else paste("lv", 1:Rank, sep=""))
+ if (Rank==1) "lv" else paste("lv", 1:Rank, sep=""))
BestOFpar
}
- if(type=="lv") {
+ if (type=="lv") {
BestOFpar = pretty(BestOFpar, newdata, Rank)
attr(BestOFpar,"objectiveFunction")=pretty(BestOFvalues,newdata,Rank=1)
BestOFpar
} else {
etaValues = muValues = NULL #
- if(Quadratic)
+ if (Quadratic)
vcValues = array(0, c(Rank,Rank,nn))
for(i1 in 1:nn) {
- ans = if(Quadratic) .my.calib.objfunction.qrrvglm(BestOFpar[i1, ],
+ ans = if (Quadratic) .my.calib.objfunction.qrrvglm(BestOFpar[i1, ],
y=newdata[i1,],
extra=object at extra,
objfun=obfunct,
@@ -191,24 +191,24 @@ calibrate.qrrvglm = function(object,
mu.function = slot(object at family, "inverse"))
muValues = rbind(muValues, matrix(ans$mu, nrow=1))
etaValues = rbind(etaValues, matrix(ans$eta, nrow=1))
- if(Quadratic)
+ if (Quadratic)
vcValues[,,i1] = ans$vcmat # Can be NULL for "cao" objects
}
- if(type=="response") {
+ if (type=="response") {
dimnames(muValues) = dimnames(newdata)
muValues
- } else if(type=="predictors") {
+ } else if (type=="predictors") {
dimnames(etaValues) = list(dimnames(newdata)[[1]],
dimnames(object at predictors)[[2]])
etaValues
- } else if(type=="vcov") {
- if(Quadratic)
+ } else if (type=="vcov") {
+ if (Quadratic)
dimnames(vcValues) = list(as.character(1:Rank),
as.character(1:Rank),
dimnames(newdata)[[1]])
vcValues
- } else if(type=="all3or4") {
- if(Quadratic)
+ } else if (type=="all3or4") {
+ if (Quadratic)
dimnames(vcValues) = list(as.character(1:Rank),
as.character(1:Rank),
dimnames(newdata)[[1]])
@@ -221,7 +221,7 @@ calibrate.qrrvglm = function(object,
list(lv=BestOFpar,
predictors=etaValues,
response=muValues,
- vcov=if(Quadratic) vcValues else NULL)
+ vcov = if(Quadratic) vcValues else NULL)
} else stop("type not matched")
}
}
@@ -246,7 +246,7 @@ calibrate.qrrvglm = function(object,
value = objfun(mu=mu, y=y,
w=1, # ignore prior.weights on the object
residuals=FALSE, eta=eta, extra=extra)
- if(everything) {
+ if (everything) {
vcmat = matrix(0, Rank, Rank)
for(s in 1:M) {
vec1 = cbind(Coefs at A[s,]) + 2 *
@@ -255,7 +255,7 @@ calibrate.qrrvglm = function(object,
}
vcmat = solve(vcmat)
} else vcmat = NULL
- if(everything) list(eta=eta, mu=mu, value=value, vcmat=vcmat) else value
+ if (everything) list(eta=eta, mu=mu, value=value, vcmat=vcmat) else value
}
@@ -277,7 +277,7 @@ calibrate.qrrvglm = function(object,
w=1, # ignore prior.weights on the object
residuals=FALSE, eta=eta, extra=extra)
vcmat = NULL # No theory as of yet to compute the vcmat
- if(everything) list(eta=eta, mu=mu, value=value, vcmat=vcmat) else value
+ if (everything) list(eta=eta, mu=mu, value=value, vcmat=vcmat) else value
}
diff --git a/R/cao.R b/R/cao.R
index e66fe80..ae5a586 100644
--- a/R/cao.R
+++ b/R/cao.R
@@ -1,5 +1,5 @@
# These functions are
-# Copyright (C) 1998-2009 T.W. Yee, University of Auckland. All rights reserved.
+# Copyright (C) 1998-2010 T.W. Yee, University of Auckland. All rights reserved.
@@ -25,11 +25,11 @@ cao <- function(formula,
ocall <- match.call()
- if(smart)
+ if (smart)
setup.smart("write")
mt <- terms(formula, data = data)
- if(missing(data))
+ if (missing(data))
data <- environment(formula)
mf <- match.call(expand=FALSE)
@@ -40,7 +40,7 @@ cao <- function(formula,
mf$drop.unused.levels <- TRUE
mf[[1]] <- as.name("model.frame")
mf <- eval(mf, parent.frame())
- if(method == "model.frame")
+ if (method == "model.frame")
return(mf)
na.act <- attr(mf, "na.action")
@@ -56,25 +56,25 @@ cao <- function(formula,
x <- model.matrix(mt, mf, contrasts)
attr(x, "assign") = attrassigndefault(x, mt)
offset <- model.offset(mf)
- if(is.null(offset))
+ if (is.null(offset))
offset <- 0 # yyy ???
w <- model.weights(mf)
- if(!length(w))
+ if (!length(w))
w <- rep(1, nrow(mf))
- else if(ncol(as.matrix(w))==1 && any(w < 0))
+ else if (ncol(as.matrix(w))==1 && any(w < 0))
stop("negative weights not allowed")
- if(is.character(family))
+ if (is.character(family))
family <- get(family)
- if(is.function(family))
+ if (is.function(family))
family <- family()
- if(!inherits(family, "vglmff")) {
+ if (!inherits(family, "vglmff")) {
stop("'family=", family, "' is not a VGAM family function")
}
eval(vcontrol.expression)
- if(!is.null(family at first))
+ if (!is.null(family at first))
eval(family at first)
@@ -83,10 +83,10 @@ cao <- function(formula,
deviance.Bestof = rep(as.numeric(NA), len=control$Bestof)
for(tries in 1:control$Bestof) {
- if(control$trace && (control$Bestof>1)) {
+ if (control$trace && (control$Bestof>1)) {
cat(paste("\n========================= Fitting model",
tries, "=========================\n"))
- if(exists("flush.console"))
+ if (exists("flush.console"))
flush.console()
}
it <- cao.fitter(x=x, y=y, w=w, offset=offset,
@@ -99,14 +99,14 @@ cao <- function(formula,
qr.arg = qr.arg,
Terms=mt, function.name=function.name, ...)
deviance.Bestof[tries] = it$crit.list$deviance
- if(tries==1 || min(deviance.Bestof[1:(tries-1)])>deviance.Bestof[tries])
+ if (tries==1 || min(deviance.Bestof[1:(tries-1)])>deviance.Bestof[tries])
fit = it
}
fit$misc$deviance.Bestof = deviance.Bestof
fit$misc$dataname <- dataname
- if(smart) {
+ if (smart) {
fit$smart.prediction <- get.smart.prediction()
wrapup.smart()
}
@@ -120,37 +120,37 @@ cao <- function(formula,
"criterion" = fit$crit.list,
"family" = fit$family,
"misc" = fit$misc,
- "model" = if(model) mf else data.frame(),
+ "model" = if (model) mf else data.frame(),
"residuals" = as.matrix(fit$wresiduals),
"smart.prediction" = as.list(fit$smart.prediction),
"terms" = list(terms=mt))
- if(!smart) answer at smart.prediction <- list(smart.arg=FALSE)
+ if (!smart) answer at smart.prediction <- list(smart.arg=FALSE)
- if(qr.arg) {
+ if (qr.arg) {
class(fit$qr) = "list"
slot(answer, "qr") = fit$qr
}
- if(length(attr(x, "contrasts")))
+ if (length(attr(x, "contrasts")))
slot(answer, "contrasts") = attr(x, "contrasts")
- if(length(fit$fitted.values))
+ if (length(fit$fitted.values))
slot(answer, "fitted.values") = as.matrix(fit$fitted.values)
- slot(answer, "na.action") = if(length(na.act)) list(na.act) else list()
- if(length(offset))
+ slot(answer, "na.action") = if (length(na.act)) list(na.act) else list()
+ if (length(offset))
slot(answer, "offset") = as.matrix(offset)
- if(length(fit$weights))
+ if (length(fit$weights))
slot(answer, "weights") = as.matrix(fit$weights)
- if(x.arg)
+ if (x.arg)
slot(answer, "x") = fit$x # The 'small' design matrix
- if(length(xlev))
+ if (length(xlev))
slot(answer, "xlevels") = xlev
- if(y.arg)
+ 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 {
+ 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)
@@ -162,7 +162,7 @@ cao <- function(formula,
dimnames(fit$predictors) = list(dimnames(fit$predictors)[[1]],
fit$misc$predictors.names)
slot(answer, "predictors") = fit$predictors
- if(length(fit$prior.weights))
+ if (length(fit$prior.weights))
slot(answer, "prior.weights") = fit$prior.weights
diff --git a/R/cao.fit.q b/R/cao.fit.q
index cc2802e..894098c 100644
--- a/R/cao.fit.q
+++ b/R/cao.fit.q
@@ -1,5 +1,5 @@
# These functions are
-# Copyright (C) 1998-2009 T.W. Yee, University of Auckland. All rights reserved.
+# Copyright (C) 1998-2010 T.W. Yee, University of Auckland. All rights reserved.
@@ -40,7 +40,7 @@ cao.fit <- function(x, y, w=rep(1, length(x[, 1])),
Rank <- control$Rank
rrcontrol <- control #
- if(length(family at initialize))
+ if (length(family at initialize))
eval(family at initialize) # Initialize mu and M (and optionally w)
n <- n.save
@@ -49,25 +49,25 @@ cao.fit <- function(x, y, w=rep(1, length(x[, 1])),
"negbinomial"=3,
"gamma2"=5, "gaussianff"=8,
0) # stop("cannot fit this model using fast algorithm")
- if(!modelno) stop("the family function does not work with cao()")
- if(modelno == 1) modelno = get("modelno", envir = VGAMenv)
+ if (!modelno) stop("the family function does not work with cao()")
+ if (modelno == 1) modelno = get("modelno", envir = VGAMenv)
eval(rrr.init.expression)
- if(length(etastart)) {
+ if (length(etastart)) {
eta <- etastart
- mu <- if(length(mustart)) mustart else family at inverse(eta, extra)
+ mu <- if (length(mustart)) mustart else family at inverse(eta, extra)
} else {
- if(length(mustart))
+ if (length(mustart))
mu <- mustart
eta <- family at link(mu, extra)
}
- M <- if(is.matrix(eta)) ncol(eta) else 1
+ M <- if (is.matrix(eta)) ncol(eta) else 1
- if(length(family at constraints))
+ if (length(family at constraints))
eval(family at constraints)
@@ -77,14 +77,14 @@ cao.fit <- function(x, y, w=rep(1, length(x[, 1])),
tc1 = trivial.constraints(constraints)
- if(all(findex == 1))
+ if (all(findex == 1))
stop("No covariates to form latent variables from.")
colx1.index = names.colx1.index = NULL
dx2 = dimnames(x)[[2]]
- if(sum(findex)) {
+ if (sum(findex)) {
asx = attr(x, "assign")
for(ii in names(findex))
- if(findex[ii]) {
+ if (findex[ii]) {
names.colx1.index = c(names.colx1.index, dx2[asx[[ii]]])
colx1.index = c(colx1.index, asx[[ii]])
}
@@ -99,8 +99,8 @@ cao.fit <- function(x, y, w=rep(1, length(x[, 1])),
- Cmat = if(length(rrcontrol$Cinit)) matrix(rrcontrol$Cinit,p2,Rank) else {
- if(!rrcontrol$Use.Init.Poisson.QO) {
+ Cmat = if (length(rrcontrol$Cinit)) matrix(rrcontrol$Cinit,p2,Rank) else {
+ if (!rrcontrol$Use.Init.Poisson.QO) {
matrix(rnorm(p2 * Rank, sd=rrcontrol$SD.Cinit), p2, Rank)
} else {
.Init.Poisson.QO(ymat=as.matrix(y),
@@ -121,7 +121,7 @@ cao.fit <- function(x, y, w=rep(1, length(x[, 1])),
Blist <- process.constraints(constraints, x, M, specialCM=specialCM)
nice31 = checkCMCO(Blist, control=control, modelno=modelno)
- if(nice31 != 1) stop("not nice")
+ if (nice31 != 1) stop("not nice")
ncolBlist <- unlist(lapply(Blist, ncol))
lv.mat = x[,colx2.index,drop=FALSE] %*% Cmat
@@ -130,12 +130,12 @@ cao.fit <- function(x, y, w=rep(1, length(x[, 1])),
rmfromVGAMenv(c("etamat", "beta"), prefix=".VGAM.CAO.")
Nice21 = length(names.colx1.index)==1 && names.colx1.index == "(Intercept)"
- if(!Nice21) stop("Norrr = ~ 1 is supported only, without constraints")
+ if (!Nice21) stop("Norrr = ~ 1 is supported only, without constraints")
NOS = ifelse(modelno==3 || modelno==5, M/2, M)
- p1star. = if(Nice21) ifelse(modelno==3 || modelno==5,2,1) else M
- p2star. = if(Nice21) Rank else stop("not Nice21")
+ p1star. = if (Nice21) ifelse(modelno==3 || modelno==5,2,1) else M
+ p2star. = if (Nice21) Rank else stop("not Nice21")
pstar. = p1star. + p2star.
- nstar = if(Nice21) ifelse(modelno==3 || modelno==5,n*2,n) else n*M
+ nstar = if (Nice21) ifelse(modelno==3 || modelno==5,n*2,n) else n*M
lenbeta = pstar. * ifelse(Nice21, NOS, 1)
othint = c(Rank,control$EqualTol, pstar. , dimw=1, inited=0, # w(,dimw) cols
@@ -149,13 +149,13 @@ cao.fit <- function(x, y, w=rep(1, length(x[, 1])),
resss=0, bfeps=control$bf.epsilon, hstep=0.1)
for(iter in 1:optim.maxit) {
- if(control$trace) {
+ if (control$trace) {
cat("\nIteration", iter, "\n")
flush.console()
}
conjgrad = optim(par=c(Cmat), fn=callcaof,
- gr=if(control$GradientFunction) calldcaof else NULL,
+ gr = if (control$GradientFunction) calldcaof else NULL,
method="BFGS",
control=list(fnscale=1, trace=as.integer(control$trace),
maxit=control$Maxit.optim, REPORT=10),
@@ -173,11 +173,11 @@ cao.fit <- function(x, y, w=rep(1, length(x[, 1])),
# Cmat <- Cmat %*% Ut # Normalized
- if(converged <- (conjgrad$convergence == 0)) break
+ if (converged <- (conjgrad$convergence == 0)) break
}
- if(!converged) {
- if(maxitl > 1) {
+ if (!converged) {
+ if (maxitl > 1) {
warning(paste("convergence not obtained in", maxitl, "iterations."))
} else {
warning(paste("convergence not obtained"))
@@ -196,7 +196,7 @@ cao.fit <- function(x, y, w=rep(1, length(x[, 1])),
n=n, M=M,
othint=othint, othdbl=othdbl,
alldump=TRUE)
- if(!is.list(extra))
+ if (!is.list(extra))
extra = list()
extra$Cmat = temp9$Cmat
ynames = dimnames(y)[[2]]
@@ -204,7 +204,7 @@ cao.fit <- function(x, y, w=rep(1, length(x[, 1])),
extra$spar1 = temp9$spar1
names(extra$spar1) = ynames
names(extra$df1.nl) = ynames
- if(Rank == 2) {
+ if (Rank == 2) {
extra$spar2 = temp9$spar2
extra$df2.nl = temp9$df2.nl
names(extra$spar2) = ynames
@@ -227,11 +227,11 @@ cao.fit <- function(x, y, w=rep(1, length(x[, 1])),
yn <- dn[[1]]
- if(is.matrix(mu)) {
- if(length(dimnames(y)[[2]])) {
+ if (is.matrix(mu)) {
+ if (length(dimnames(y)[[2]])) {
y.names <- dimnames(y)[[2]]
}
- if(length(dimnames(mu)[[2]])) {
+ if (length(dimnames(mu)[[2]])) {
y.names <- dimnames(mu)[[2]]
}
dimnames(mu) <- list(yn, y.names)
@@ -264,10 +264,10 @@ cao.fit <- function(x, y, w=rep(1, length(x[, 1])),
- if(w[1] != 1 || any(w != w[1]))
+ if (w[1] != 1 || any(w != w[1]))
fit$prior.weights <- w
- if(length(family at last))
+ if (length(family at last))
eval(family at last)
structure(c(fit,
@@ -304,7 +304,7 @@ cao.control = function(Rank=1,
SmallNo = 5.0e-13,
Use.Init.Poisson.QO=TRUE,
- Bestof = if(length(Cinit)) 1 else 10,
+ Bestof = if (length(Cinit)) 1 else 10,
maxitl = 40,
method.init = 1,
bf.epsilon = 1.0e-7,
@@ -320,57 +320,57 @@ cao.control = function(Rank=1,
spar2 = 0, # 0 means df2.nl is used
...)
{
- if(!is.Numeric(iShape, posit=TRUE)) stop("bad input for 'iShape'")
- if(!is.Numeric(iKvector, posit=TRUE)) stop("bad input for 'iKvector'")
- if(!is.Numeric(method.init, posit=TRUE, allow=1, integer=TRUE))
+ if (!is.Numeric(iShape, posit=TRUE)) stop("bad input for 'iShape'")
+ if (!is.Numeric(iKvector, posit=TRUE)) stop("bad input for 'iKvector'")
+ if (!is.Numeric(method.init, posit=TRUE, allow=1, integer=TRUE))
stop("bad input for 'method.init'")
- if(criterion != "deviance") stop("'criterion' must be \"deviance\"")
- if(GradientFunction) stop("14/1/05; GradientFunction=TRUE not working yet")
+ if (criterion != "deviance") stop("'criterion' must be \"deviance\"")
+ if (GradientFunction) stop("14/1/05; GradientFunction=TRUE not working yet")
se.fit = as.logical(FALSE)
- if(se.fit) stop("se.fit = FALSE handled only")
+ if (se.fit) stop("se.fit = FALSE handled only")
- if(length(Cinit) && !is.Numeric(Cinit))
+ if (length(Cinit) && !is.Numeric(Cinit))
stop("Bad input for 'Cinit'")
- if(!is.Numeric(Bestof, allow=1, integ=TRUE, posit=TRUE))
+ if (!is.Numeric(Bestof, allow=1, integ=TRUE, posit=TRUE))
stop("Bad input for 'Bestof'")
- if(!is.Numeric(maxitl, allow=1, integ=TRUE, posit=TRUE))
+ if (!is.Numeric(maxitl, allow=1, integ=TRUE, posit=TRUE))
stop("Bad input for 'maxitl'")
- if(!is.Numeric(bf.epsilon, allow=1, posit=TRUE))
+ if (!is.Numeric(bf.epsilon, allow=1, posit=TRUE))
stop("Bad input for 'bf.epsilon'")
- if(!is.Numeric(bf.maxit, integ=TRUE, posit=TRUE, allow=1))
+ if (!is.Numeric(bf.maxit, integ=TRUE, posit=TRUE, allow=1))
stop("Bad input for 'bf.maxit'")
- if(!is.Numeric(Etamat.colmax, posit=TRUE, allow=1) || Etamat.colmax < Rank)
+ if (!is.Numeric(Etamat.colmax, posit=TRUE, allow=1) || Etamat.colmax < Rank)
stop("bad input for 'Etamat.colmax'")
- if(!is.Numeric(Maxit.optim, integ=TRUE, posit=TRUE, allow=1))
+ if (!is.Numeric(Maxit.optim, integ=TRUE, posit=TRUE, allow=1))
stop("Bad input for 'Maxit.optim'")
- if(!is.Numeric(optim.maxit, allow=1, integ=TRUE, posit=TRUE))
+ if (!is.Numeric(optim.maxit, allow=1, integ=TRUE, posit=TRUE))
stop("Bad input for 'optim.maxit'")
- if(!is.Numeric(SD.sitescores, allow=1, posit=TRUE))
+ if (!is.Numeric(SD.sitescores, allow=1, posit=TRUE))
stop("Bad input for 'SD.sitescores'")
- if(!is.Numeric(SD.Cinit, allow=1, posit=TRUE))
+ if (!is.Numeric(SD.Cinit, allow=1, posit=TRUE))
stop("Bad input for 'SD.Cinit'")
- if(!is.Numeric(df1.nl) || any(df1.nl < 0))
+ if (!is.Numeric(df1.nl) || any(df1.nl < 0))
stop("Bad input for 'df1.nl'")
- if(any(df1.nl >= 0 & df1.nl < 0.05)) {
+ if (any(df1.nl >= 0 & df1.nl < 0.05)) {
warning("df1.nl values between 0 and 0.05 converted to 0.05")
df1.nl[df1.nl < 0.05] = 0.05
}
- if(!is.Numeric(df2.nl) || any(df2.nl < 0))
+ if (!is.Numeric(df2.nl) || any(df2.nl < 0))
stop("Bad input for 'df2.nl'")
- if(any(df2.nl >= 0 & df2.nl < 0.05)) {
+ if (any(df2.nl >= 0 & df2.nl < 0.05)) {
warning("df2.nl values between 0 and 0.05 converted to 0.05")
df2.nl[df2.nl < 0.05] = 0.05
}
- if(!is.Numeric(spar1) || any(spar1 < 0))
+ if (!is.Numeric(spar1) || any(spar1 < 0))
stop("Bad input for 'spar1'")
- if(!is.Numeric(spar2) || any(spar2 < 0))
+ if (!is.Numeric(spar2) || any(spar2 < 0))
stop("Bad input for 'spar2'")
- if(!is.Numeric(epsilon, posit=TRUE, allow=1))
+ if (!is.Numeric(epsilon, posit=TRUE, allow=1))
stop("Bad input for 'epsilon'")
- if(!is.Numeric(SmallNo, posit=TRUE, allow=1))
+ if (!is.Numeric(SmallNo, posit=TRUE, allow=1))
stop("Bad input for 'SmallNo'")
- if((SmallNo < .Machine$double.eps) ||
+ if ((SmallNo < .Machine$double.eps) ||
(SmallNo > .0001)) stop("SmallNo is out of range")
ans = list(
@@ -417,12 +417,12 @@ cao.control = function(Rank=1,
create.cms <- function(Rank=1, M, MSratio=1, which, p1=1) {
- if(!is.Numeric(p1, allow=1, integ=TRUE, pos=TRUE)) stop("bad input for p1")
+ if (!is.Numeric(p1, allow=1, integ=TRUE, pos=TRUE)) stop("bad input for p1")
Blist. = vector("list", p1+Rank)
for(r in 1:(p1+Rank))
Blist.[[r]] = diag( M )
- names(Blist.) = if(p1 == 1) c("(Intercept)", names(which)) else stop()
- if(MSratio == 2) {
+ names(Blist.) = if (p1 == 1) c("(Intercept)", names(which)) else stop()
+ if (MSratio == 2) {
for(r in 1:Rank)
Blist.[[p1+r]] = eij(1, M)
}
@@ -435,7 +435,7 @@ create.cms <- function(Rank=1, M, MSratio=1, which, p1=1) {
callcaof = function(cmatrix,
etamat, xmat, ymat, wvec, modelno,
Control, Nice21=TRUE,
- p1star. = if(any(modelno==c(3,5))) 2 else 1, p2star. =Rank,
+ p1star. = if (any(modelno==c(3,5))) 2 else 1, p2star. =Rank,
n, M,
othint, othdbl,
alldump=FALSE) {
@@ -446,21 +446,21 @@ callcaof = function(cmatrix,
p1 = length(control$colx1.index)
p2 = length(control$colx2.index)
yn = dimnames(ymat)[[2]]
- if(length(yn) != ncol(ymat)) stop("the column names of ymat must be given")
+ if (length(yn) != ncol(ymat)) stop("the column names of ymat must be given")
queue = qbig = Rank # 19/10/05; number of smooths per species
- NOS = if(any(modelno==c(3,5))) M/2 else M
+ NOS = if (any(modelno==c(3,5))) M/2 else M
df1.nl = procVec(control$df1.nl, yn= yn , Def=control$DF1)
spar1 = procVec(control$spar1, yn= yn , Def= control$SPAR1)
df2.nl = procVec(control$df2.nl, yn= yn , Def=control$DF2)
spar2 = procVec(control$spar2, yn= yn , Def= control$SPAR2)
- if(any(c(length(spar1),length(spar2),length(df1.nl),length(df2.nl)) != NOS))
+ if (any(c(length(spar1),length(spar2),length(df1.nl),length(df2.nl)) != NOS))
stop("wrong length in at least one of df1.nl, df2.nl, spar1, spar2")
cmatrix = matrix(cmatrix, p2, Rank) # crow1C() needs a matrix as input
cmatrix = crow1C(cmatrix, crow=control$Crow1positive)
numat = xmat[,control$colx2.index,drop=FALSE] %*% cmatrix
evnu = eigen(var(numat))
- temp7 = if(Rank > 1) evnu$vector %*% diag(evnu$value^(-0.5)) else
+ temp7 = if (Rank > 1) evnu$vector %*% diag(evnu$value^(-0.5)) else
evnu$vector %*% evnu$value^(-0.5)
cmatrix = cmatrix %*% temp7
cmatrix = crow1C(cmatrix, crow=control$Crow1positive)
@@ -468,7 +468,7 @@ callcaof = function(cmatrix,
dim(numat) = c(n, Rank)
- mynames5 = if(Rank==1) "lv" else paste("lv", 1:Rank, sep="")
+ mynames5 = if (Rank==1) "lv" else paste("lv", 1:Rank, sep="")
nu1mat = cbind("(Intercept)"=1, lv=numat)
dimnames(nu1mat) = list(dimnames(xmat)[[1]], c("(Intercept)", mynames5))
@@ -484,23 +484,23 @@ callcaof = function(cmatrix,
}
pstar. = p1star. + p2star. # = Mdot + Rank
- nstar = if(Nice21) ifelse(modelno==3 || modelno==5,n*2,n) else n*M
+ nstar = if (Nice21) ifelse(modelno==3 || modelno==5,n*2,n) else n*M
lenbeta = pstar. * ifelse(Nice21, NOS, 1) # Holds the linear coeffs
- inited = if(exists(".VGAM.CAO.etamat", envir=VGAMenv)) 1 else 0
- usethiseta = if(inited==1)
+ inited = if (exists(".VGAM.CAO.etamat", envir=VGAMenv)) 1 else 0
+ usethiseta = if (inited==1)
getfromVGAMenv("etamat", prefix = ".VGAM.CAO.") else t(etamat)
- if(any(is.na(usethiseta))) {
+ if (any(is.na(usethiseta))) {
usethiseta = t(etamat) # So that dim(usethiseta)==c(M,n)
rmfromVGAMenv("etamat", prefix=".VGAM.CAO.")
}
- usethisbeta = if(inited==2)
+ usethisbeta = if (inited==2)
getfromVGAMenv("beta", prefix = ".VGAM.CAO.") else double(lenbeta)
othint[5] = inited # Refine initialization within FORTRAN
pstar = NOS * pstar.
- bnumat=if(Nice21) matrix(0,nstar,pstar.) else stop("code not written here")
+ bnumat = if (Nice21) matrix(0,nstar,pstar.) else stop("code not written here")
M. = MSratio = M / NOS # 1 or 2 usually
which = p1 + (1:Rank) # These columns are smoothed
@@ -527,7 +527,7 @@ callcaof = function(cmatrix,
dimu. = M.
wz. = matrix(0, n, dimw. )
U. = matrix(0, dimu. , n)
- if(names(Blist.)[1] != "(Intercept)") stop("something wrong here")
+ if (names(Blist.)[1] != "(Intercept)") stop("something wrong here")
Blist.[[1]] <- NULL
trivc = rep(2 - M. , len=queue) # All of queue smooths are basic smooths
@@ -538,7 +538,7 @@ callcaof = function(cmatrix,
size.twk <- max(size.twk, M*smooth.frame$n)
qbig. = NOS * qbig # == NOS * Rank; holds all the smooths
- if(!all.equal(as.vector(ncbvec), rep(1, len=queue)))
+ if (!all.equal(as.vector(ncbvec), rep(1, len=queue)))
stop("ncbvec not right---should be a queue-vector of ones")
pbig = pstar. #
@@ -552,7 +552,7 @@ callcaof = function(cmatrix,
- if(Rank == 2) {
+ if (Rank == 2) {
spardf = (c(spar1,1+df1.nl,spar2,1+df2.nl))[interleave.VGAM(4*NOS,M=2)]
} else {
spardf = c(spar1, 1.0+df1.nl)
@@ -603,7 +603,7 @@ callcaof = function(cmatrix,
flush.console()
- if(ans1$errcode == 0) {
+ if (ans1$errcode == 0) {
assign2VGAMenv(c("etamat", "beta"), ans1, prefix=".VGAM.CAO.")
assign(".VGAM.CAO.cmatrix", matrix(cmatrix,p2,Rank), envir=VGAMenv)
} else {
@@ -613,7 +613,7 @@ flush.console()
rmfromVGAMenv(c("etamat", "beta"), prefix=".VGAM.CAO.")
}
- returnans = if(alldump) {
+ returnans = if (alldump) {
bindex = ans1$bindex
ncolBlist = ncbvec
Bspline2 <- vector("list", NOS)
@@ -638,7 +638,7 @@ flush.console()
qrank = npetc[7] # Assume all species have the same qrank value
dim(ans1$etamat) = c(M,n) # was c(n,M) prior to 22/8/06
- if(Rank == 2) {
+ if (Rank == 2) {
spardf = array(ans1$spardf, c(Rank,NOS,2))
df1.nl = spardf[1,,2] - 1
df2.nl = spardf[2,,2] - 1
@@ -656,14 +656,14 @@ flush.console()
names(control$colx2.index), mynames5)),
coefficients = ans1$beta,
df1.nl = df1.nl,
- df2.nl = if(Rank == 2) df2.nl else NULL,
+ df2.nl = if (Rank == 2) df2.nl else NULL,
df.residual = n*M - qrank - sum(ans1$df - 1),
fitted = ans1$fv, # NOS x n
kindex = ans1$kindex,
predictors = matrix(ans1$etamat, n, M, byrow=TRUE),
wresiduals = ans1$z - t(ans1$etamat), # n x M
- spar1=spar1,
- spar2=if(Rank == 2) spar2 else NULL)
+ spar1 = spar1,
+ spar2 = if (Rank == 2) spar2 else NULL)
} else
ans1$deviance
flush.console()
@@ -675,21 +675,21 @@ flush.console()
calldcaof = function(cmatrix,
etamat, xmat, ymat, wvec, modelno,
Control, Nice21=TRUE,
- p1star. = if(any(modelno==c(3,5))) 2 else 1, p2star. =Rank,
+ p1star. = if (any(modelno==c(3,5))) 2 else 1, p2star. =Rank,
n, M,
othint, othdbl,
alldump=FALSE) {
- if(alldump) stop("really used?")
+ if (alldump) stop("really used?")
flush.console()
- if(!Nice21) stop("Nice21 must be TRUE")
+ if (!Nice21) stop("Nice21 must be TRUE")
control = Control
Rank = control$Rank
p2 = length(control$colx2.index)
yn = dimnames(ymat)[[2]]
- if(!length( yn )) yn = paste("Y", 1:ncol(ymat), sep="")
+ if (!length( yn )) yn = paste("Y", 1:ncol(ymat), sep="")
cmatrix = scale(cmatrix)
@@ -698,7 +698,7 @@ calldcaof = function(cmatrix,
numat <- xmat2 %*% matrix(cmatrix, p2, Rank)
dim(numat) <- c(nrow(xmat), Rank)
temp.smooth.frame = vector("list", 1+Rank) # A temporary makeshift frame
- mynames5 = if(Rank==1) "lv" else paste("lv",1:Rank,sep="")
+ mynames5 = if (Rank==1) "lv" else paste("lv",1:Rank,sep="")
names(temp.smooth.frame) = c("(Intercept)", mynames5)
temp.smooth.frame[[1]] = rep(1, len=n)
for(uu in 1:Rank) {
@@ -710,16 +710,16 @@ calldcaof = function(cmatrix,
attr(temp.smooth.frame[,uu+1], "df") = 4 # any old value
}
pstar. = p1star. + p2star.
- nstar = if(Nice21) ifelse(modelno==3 || modelno==5,n*2,n) else n*M
+ nstar = if (Nice21) ifelse(modelno==3 || modelno==5,n*2,n) else n*M
NOS = ifelse(modelno == 3 || modelno==5, M/2, M)
lenbeta = pstar. * ifelse(Nice21, NOS, 1)
- if(TRUE) {
- inited = if(exists(".VGAM.CAO.etamat", envir = VGAMenv)) 1 else 0
- usethiseta = if(inited==1) get(".VGAM.CAO.etamat",
+ if (TRUE) {
+ inited = if (exists(".VGAM.CAO.etamat", envir = VGAMenv)) 1 else 0
+ usethiseta = if (inited==1) get(".VGAM.CAO.etamat",
envir = VGAMenv) else t(etamat)
}
- usethisbeta = if(inited==2) get(".VGAM.CAO.beta",
+ usethisbeta = if (inited==2) get(".VGAM.CAO.beta",
envir = VGAMenv) else double(lenbeta)
@@ -727,7 +727,7 @@ calldcaof = function(cmatrix,
pstar = NOS * pstar.
- bnumat = if(Nice21) matrix(0,nstar,pstar) else stop("need Nice21")
+ bnumat = if (Nice21) matrix(0,nstar,pstar) else stop("need Nice21")
M. = MSratio = M / NOS # 1 or 2 usually
which = p1 + (1:Rank) # The first 1 is the intercept term
@@ -758,8 +758,8 @@ calldcaof = function(cmatrix,
wz. = matrix(0, n, M. ) # not sure
U. = matrix(0, M. , n)
- dimw. = if(is.matrix( wz. )) ncol( wz. ) else 1
- dimu. <- if(is.matrix( U. )) nrow( U. ) else 1
+ dimw. = if (is.matrix( wz. )) ncol( wz. ) else 1
+ dimu. <- if (is.matrix( U. )) nrow( U. ) else 1
Blist.[[1]] <- NULL
trivc = rep(2 - M. , len=queue) # All of queue smooths are basic smooths
ncbvec <- ncolBlist.[nwhich]
@@ -772,7 +772,7 @@ calldcaof = function(cmatrix,
qbig. = NOS * qbig # == NOS * Rank
pbig = pstar. # Not sure
- if(FALSE) {
+ if (FALSE) {
df1.nl = rep(control$df1.nl, len=NOS) # This is used
spar1 = rep(control$spar1, len=NOS) # This is used
} else {
@@ -790,7 +790,7 @@ calldcaof = function(cmatrix,
flush.console()
ans1 <-
- dotFortran(name = if(Nice21) "vdcaof" else stop("need Nice21"),
+ dotFortran(name = if (Nice21) "vdcaof" else stop("need Nice21"),
numat=as.double(numat),
as.double(ymat), as.double(wvec),
etamat=as.double(usethiseta),
@@ -840,13 +840,13 @@ calldcaof = function(cmatrix,
assign(".VGAM.CAO.etamat", ans1$etamat, envir = VGAMenv)
assign(".VGAM.CAO.z", ans1$z, envir=VGAMenv) # z; minus any offset
assign(".VGAM.CAO.U", ans1$U, envir=VGAMenv) # U
- if(ans1$errcode == 0) {
+ if (ans1$errcode == 0) {
} else {
cat("warning in calldcaof: error code =", ans1$errcode, "\n")
flush.console()
}
- returnans = if(alldump) {
+ returnans = if (alldump) {
bindex = ans1$bindex
ncolBlist = ncbvec
Bspline2 <- vector("list", NOS)
@@ -924,44 +924,44 @@ Coef.cao = function(object,
smallno = 0.05,
...) {
- if(!is.Numeric(epsOptimum, posit=TRUE, allow=1))
+ if (!is.Numeric(epsOptimum, posit=TRUE, allow=1))
stop("bad input for argument 'epsOptimum'")
- if(!is.Numeric(gridlen, posit=TRUE, integer=TRUE) || gridlen < 5)
+ if (!is.Numeric(gridlen, posit=TRUE, integer=TRUE) || gridlen < 5)
stop("bad input for argument 'gridlen'")
- if(!is.Numeric(maxgriditer, posit=TRUE, allow=1, int=TRUE) || maxgriditer<3)
+ if (!is.Numeric(maxgriditer, posit=TRUE, allow=1, int=TRUE) || maxgriditer<3)
stop("bad input for argument 'maxgriditer'")
- if(!is.logical(ConstrainedO <- object at control$ConstrainedO))
+ if (!is.logical(ConstrainedO <- object at control$ConstrainedO))
stop("cannot determine whether the model is constrained or not")
- if(!is.Numeric(smallno, posit=TRUE, allow=1) ||
+ if (!is.Numeric(smallno, posit=TRUE, allow=1) ||
smallno > 0.5 || smallno < 0.0001)
stop("bad input for argument 'smallno'")
ocontrol = object at control
- if((Rank <- ocontrol$Rank) > 2) stop("Rank must be 1 or 2")
+ if ((Rank <- ocontrol$Rank) > 2) stop("Rank must be 1 or 2")
gridlen = rep(gridlen, length=Rank)
- M = if(any(slotNames(object) == "predictors") &&
+ M = if (any(slotNames(object) == "predictors") &&
is.matrix(object at predictors)) ncol(object at predictors) else
object at misc$M
- NOS = if(length(object at y)) ncol(object at y) else M
+ NOS = if (length(object at y)) ncol(object at y) else M
MSratio = M / NOS # 1 or 2; First value is g(mean) = quadratic form in lv
nice21 = (length(ocontrol$colx1.index) == 1) &&
(names(ocontrol$colx1.index) == "(Intercept)")
- if(!nice21) stop("Can only handle Norrr = ~ 1")
+ if (!nice21) stop("Can only handle Norrr = ~ 1")
p1 = length(ocontrol$colx1.index)
p2 = length(ocontrol$colx2.index)
modelno = object at control$modelno # 1,2,3,... or 0
ynames = object at misc$ynames
- if(!length(ynames)) ynames = object at misc$predictors.names
- if(!length(ynames)) ynames = object at misc$ynames
- if(!length(ynames)) ynames = paste("Y", 1:NOS, sep="")
+ if (!length(ynames)) ynames = object at misc$predictors.names
+ if (!length(ynames)) ynames = object at misc$ynames
+ if (!length(ynames)) ynames = paste("Y", 1:NOS, sep="")
lp.names = object at misc$predictors.names
- if(!length(lp.names)) lp.names = NULL
+ if (!length(lp.names)) lp.names = NULL
- lv.names = if(Rank==1) "lv" else paste("lv", 1:Rank, sep="")
+ lv.names = if (Rank==1) "lv" else paste("lv", 1:Rank, sep="")
Cmat = object at extra$Cmat # p2 x Rank (provided maxitl > 1)
- if(ConstrainedO)
+ if (ConstrainedO)
dimnames(Cmat) = list(names(ocontrol$colx2.index), lv.names)
- lv.mat = if(ConstrainedO) {
+ lv.mat = if (ConstrainedO) {
object at x[,ocontrol$colx2.index,drop=FALSE] %*% Cmat
} else {
object at lv
@@ -973,7 +973,7 @@ Coef.cao = function(object,
maximum = rep(as.numeric(NA), len=NOS)
whichSpecies = 1:NOS # Do it for all species
- if(Rank == 1) {
+ if (Rank == 1) {
gridd = cbind(seq(extents[1,1], extents[2,1], len=gridlen))
} else {
gridd = expand.grid(seq(extents[1,1], extents[2,1], len=gridlen[1]),
@@ -981,18 +981,18 @@ Coef.cao = function(object,
eta2matrix = matrix(0, NOS, 1)
}
gridd.orig = gridd
- # if(Rank == 2) then this is for initial values
+ # if (Rank == 2) then this is for initial values
for(sppno in 1:length(whichSpecies)) {
gridd = gridd.orig
gridres1 = gridd[2,1] - gridd[1,1]
- gridres2 = if(Rank==2) gridd[2,2] - gridd[1,2] else 0
+ gridres2 = if (Rank==2) gridd[2,2] - gridd[1,2] else 0
griditer = 1
thisSpecies = whichSpecies[sppno]
- indexSpecies = if(is.character(whichSpecies))
+ indexSpecies = if (is.character(whichSpecies))
match(whichSpecies[sppno], ynames) else whichSpecies[sppno]
- if(is.na(indexSpecies))
+ if (is.na(indexSpecies))
stop("mismatch found in 'whichSpecies'")
while(griditer == 1 ||
@@ -1002,25 +1002,25 @@ Coef.cao = function(object,
Rank=Rank, deriv=0, MSratio=MSratio)
yvals = temp$yvals # gridlen-vector
xvals = temp$xvals # gridlen x Rank; gridd
- if(length(temp$eta2)) eta2matrix[sppno,1] = temp$eta2
+ if (length(temp$eta2)) eta2matrix[sppno,1] = temp$eta2
nnn = length(yvals)
index = (1:nnn)[yvals==max(yvals)]
- if(length(index)!=1) warning("could not find a single maximum")
- if(Rank == 2) {
+ if (length(index)!=1) warning("could not find a single maximum")
+ if (Rank == 2) {
initvalue = rep(xvals[index,], length=Rank) # for optim()
# Make sure initvalue is in the interior
- if(abs(initvalue[1] - extents[1,1]) < smallno)
+ if (abs(initvalue[1] - extents[1,1]) < smallno)
initvalue[1] = extents[1,1] + smallno
- if(abs(initvalue[1] - extents[2,1]) < smallno)
+ if (abs(initvalue[1] - extents[2,1]) < smallno)
initvalue[1] = extents[2,1] - smallno
- if(abs(initvalue[2] - extents[1,2]) < smallno)
+ if (abs(initvalue[2] - extents[1,2]) < smallno)
initvalue[2] = extents[1,2] + smallno
- if(abs(initvalue[2] - extents[2,2]) < smallno)
+ if (abs(initvalue[2] - extents[2,2]) < smallno)
initvalue[2] = extents[2,2] - smallno
break
}
- if(index == 1 || index == nnn) {
+ if (index == 1 || index == nnn) {
maximum[sppno] = optimum[1,sppno] = NA
gridres1 = epsOptimum + 1 # equivalent to a break
break # just in case
@@ -1036,7 +1036,7 @@ Coef.cao = function(object,
}
} # of while
- if(Rank == 2) {
+ if (Rank == 2) {
# Rank = 2, so use optim(). The above was to get initial values.
myfun = function(x, object, sppno, Rank=1, deriv=0, MSratio=1) {
# x is a 2-vector
@@ -1052,7 +1052,7 @@ Coef.cao = function(object,
deriv=0, MSratio=MSratio)
# Check to see if the soln is at the boundary. If not, assign it.
for(rindex in 1:Rank)
- if(abs(answer$par[rindex] - extents[1,rindex]) > smallno &&
+ if (abs(answer$par[rindex] - extents[1,rindex]) > smallno &&
abs(answer$par[rindex] - extents[2,rindex]) > smallno) {
optimum[rindex,sppno] = answer$par[rindex]
maximum[sppno] = answer$value
@@ -1060,7 +1060,7 @@ Coef.cao = function(object,
} # end of Rank=2
} # end of sppno
myetamat = rbind(maximum)
- if(MSratio == 2) myetamat = kronecker(myetamat, matrix(1:0, 1, 2))
+ if (MSratio == 2) myetamat = kronecker(myetamat, matrix(1:0, 1, 2))
maximum = object at family@inverse(eta=myetamat, extra=object at extra)
maximum = c(maximum) # Convert from matrix to vector
names(maximum) = ynames
@@ -1078,8 +1078,8 @@ Coef.cao = function(object,
OptimumOrder=optimum,
Rank = Rank,
spar1 = object at extra$spar1)
- if(ConstrainedO) {ans at C = Cmat} else {Cmat = NULL}
- if(Rank == 2) {
+ if (ConstrainedO) {ans at C = Cmat} else {Cmat = NULL}
+ if (Rank == 2) {
dimnames(eta2matrix) = list(
object at misc$predictors.names[c(FALSE,TRUE)], " ")
ans at eta2 = eta2matrix
@@ -1092,18 +1092,18 @@ Coef.cao = function(object,
ans at lvOrder[,rindex] = order(ans at lv[,rindex])
}
- if(length(object at misc$estimated.dispersion) &&
+ if (length(object at misc$estimated.dispersion) &&
object at misc$estimated.dispersion) {
p = length(object at coefficients)
n = object at misc$n
M = object at misc$M
- NOS = if(length(object at y)) ncol(object at y) else M
+ NOS = if (length(object at y)) ncol(object at y) else M
pstar = p + length(Cmat) # Adjustment
adjusted.dispersion = object at misc$dispersion * (n*M - p) /
(n*M - pstar)
ans at dispersion = adjusted.dispersion
}
- if(MSratio == 2) {
+ if (MSratio == 2) {
lcoef = object at coefficients
temp = lcoef[((1:NOS)-1)*(2+Rank)+2]
names(temp) = object at misc$predictors.names[2*(1:NOS)]
@@ -1119,13 +1119,13 @@ printCoef.cao = function(object, digits = max(2, options()$digits-2), ...) {
NOS = object at NOS
M = object at M
- Maximum = if(length(object at Maximum)) cbind(Maximum=object at Maximum) else NULL
+ Maximum = if (length(object at Maximum)) cbind(Maximum=object at Maximum) else NULL
optmat = cbind(t(object at Optimum))
dimnames(optmat) = list(dimnames(optmat)[[1]],
- if(Rank > 1) paste("Optimum", dimnames(optmat)[[2]], sep=".")
+ if (Rank > 1) paste("Optimum", dimnames(optmat)[[2]], sep=".")
else "Optimum")
- if( object at Constrained ) {
+ if ( object at Constrained ) {
cat("\nC matrix (constrained/canonical coefficients)\n")
print(object at C, digits=digits, ...)
}
@@ -1133,7 +1133,7 @@ printCoef.cao = function(object, digits = max(2, options()$digits-2), ...) {
print(cbind(Optimum=optmat,
Maximum), digits = max(1, digits-1))
cat("\nNonlinear degrees of freedom\n")
- if(Rank == 1) {
+ if (Rank == 1) {
print(cbind(df1.nl = object at df1.nl), digits=max(2, digits-1), ...)
} else {
print(cbind(df1.nl = object at df1.nl,
@@ -1161,8 +1161,8 @@ setMethod("Coef", "cao", function(object, ...) Coef.cao(object, ...))
lvplot.cao = function(object,
add= FALSE, plot.it= TRUE, rugplot = TRUE, y = FALSE,
type=c("fitted.values", "predictors"),
- xlab=paste("Latent Variable", if(Rank==1) "" else " 1", sep=""),
- ylab=if(Rank==1) switch(type, predictors="Predictors",
+ 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,
llty=par()$lty, lcol=par()$col, llwd=par()$lwd,
@@ -1174,9 +1174,9 @@ lvplot.cao = function(object,
{
type <- match.arg(type, c("fitted.values", "predictors"))[1]
- if((Rank <- object at control$Rank) > 2)
+ if ((Rank <- object at control$Rank) > 2)
stop("can only handle rank 1 or 2 models")
- M = if(any(slotNames(object) == "predictors") &&
+ M = if (any(slotNames(object) == "predictors") &&
is.matrix(object at predictors)) ncol(object at predictors) else
object at misc$M
NOS = ncol(object at y)
@@ -1184,25 +1184,25 @@ lvplot.cao = function(object,
n = object at misc$n
colx2.index = object at control$colx2.index
cx1i = object at control$colx1.index
- if(!length(whichSpecies)) whichSpecies = 1:NOS
- if(check.ok)
- if(!(length(cx1i)==1 && names(cx1i)=="(Intercept)"))
+ if (!length(whichSpecies)) whichSpecies = 1:NOS
+ if (check.ok)
+ if (!(length(cx1i)==1 && names(cx1i)=="(Intercept)"))
stop("latent variable plots allowable only for Norrr = ~ 1 models")
Coeflist = Coef(object)
Cmat = Coeflist at C
lvmat = Coeflist at lv # n x Rank
- if(!plot.it) return(lvmat)
+ if (!plot.it) return(lvmat)
r.curves = slot(object, type) # n times (M or S) (\boldeta or \boldmu)
- if(MSratio != 1 && type == "predictors")
+ if (MSratio != 1 && type == "predictors")
stop("can only plot the predictors if M = S")
MorS = ncol(r.curves) # Actually, here, the value is S always.
- if(!add) {
- if(Rank==1) {
+ if (!add) {
+ if (Rank==1) {
matplot(lvmat,
- if( y && type=="fitted.values")
+ if ( y && type=="fitted.values")
object at y[,whichSpecies,drop=FALSE] else
r.curves[,whichSpecies,drop=FALSE],
type="n", xlab=xlab, ylab=ylab, ...)
@@ -1222,14 +1222,14 @@ lvplot.cao = function(object,
llwd <- rep(llwd, leng=length(whichSpecies))
adj.arg <- rep(adj.arg, leng=length(whichSpecies))
- sppnames = if(type=="predictors") dimnames(r.curves)[[2]] else
+ sppnames = if (type=="predictors") dimnames(r.curves)[[2]] else
dimnames(object at y)[[2]]
- if(Rank==1) {
+ if (Rank==1) {
for(sppno in 1:length(whichSpecies)) {
thisSpecies = whichSpecies[sppno]
- indexSpecies = if(is.character(whichSpecies))
+ indexSpecies = if (is.character(whichSpecies))
match(whichSpecies[sppno], sppnames) else whichSpecies[sppno]
- if(is.na(indexSpecies))
+ if (is.na(indexSpecies))
stop("mismatch found in 'whichSpecies'")
xx = lvmat
yy = r.curves[,indexSpecies]
@@ -1237,34 +1237,34 @@ lvplot.cao = function(object,
xx = xx[ o ]
yy = yy[ o ]
lines(xx, yy, col=lcol[sppno], lwd=llwd[sppno], lty=llty[sppno])
- if( y && type=="fitted.values") {
+ if ( y && type=="fitted.values") {
ypts = object at y
- if(ncol(as.matrix(ypts)) == ncol(r.curves))
+ if (ncol(as.matrix(ypts)) == ncol(r.curves))
points(xx, ypts[o,sppno], col=pcol[sppno],
cex=pcex[sppno], pch=pch[sppno])
}
}
- if(rugplot) rug(xx)
+ if (rugplot) rug(xx)
} else {
- if(sites) {
+ if (sites) {
text(lvmat[,1], lvmat[,2], adj=0.5,
- labels=if(is.null(spch)) dimnames(lvmat)[[1]] else
+ labels = if (is.null(spch)) dimnames(lvmat)[[1]] else
rep(spch, length=nrow(lvmat)), col=scol, cex=scex, font=sfont)
}
for(sppno in 1:length(whichSpecies)) {
thisSpecies = whichSpecies[sppno]
- indexSpecies = if(is.character(whichSpecies))
+ indexSpecies = if (is.character(whichSpecies))
match(whichSpecies[sppno], sppnames) else whichSpecies[sppno]
- if(is.na(indexSpecies))
+ if (is.na(indexSpecies))
stop("mismatch found in 'whichSpecies'")
points(Coeflist at Optimum[1,indexSpecies],
Coeflist at Optimum[2,indexSpecies],
col=pcol[sppno], cex=pcex[sppno], pch=pch[sppno])
}
- if(label.arg) {
+ if (label.arg) {
for(sppno in 1:length(whichSpecies)) {
thisSpecies = whichSpecies[sppno]
- indexSpecies = if(is.character(whichSpecies))
+ indexSpecies = if (is.character(whichSpecies))
match(whichSpecies[sppno], sppnames) else whichSpecies[sppno]
text(Coeflist at Optimum[1,indexSpecies],
Coeflist at Optimum[2,indexSpecies],
@@ -1287,52 +1287,52 @@ predict.cao <- function (object, newdata=NULL,
type = c("link", "response", "terms"),
deriv = 0, ...) {
type <- match.arg(type, c("link", "response", "terms"))[1]
- if(type != "link" && deriv != 0)
+ if (type != "link" && deriv != 0)
stop("Setting deriv=<positive integer> requires type=\"link\"")
na.act = object at na.action
object at na.action = list()
ocontrol = object at control
nice21 = (length(ocontrol$colx1.index) == 1) &&
(names(ocontrol$colx1.index) == "(Intercept)")
- if(!nice21) stop("Can only handle Norrr = ~ 1")
+ if (!nice21) stop("Can only handle Norrr = ~ 1")
- if(!length(newdata) && type=="response" && length(object at fitted.values)) {
- if(length(na.act)) {
+ if (!length(newdata) && type=="response" && length(object at fitted.values)) {
+ if (length(na.act)) {
return(napredict(na.act[[1]], object at fitted.values))
} else {
return(object at fitted.values)
}
}
- if(!length(newdata)) {
+ if (!length(newdata)) {
X <- model.matrixvlm(object, type="lm", ...)
offset <- object at offset
tt <- terms(object)
- if(!length(object at x))
+ if (!length(object at x))
attr(X, "assign") <- attrassignlm(X, tt)
} else {
- if(is.smart(object) && length(object at smart.prediction)) {
+ if (is.smart(object) && length(object at smart.prediction)) {
setup.smart("read", smart.prediction=object at smart.prediction)
}
tt <- terms(object) # 11/8/03; object at terms$terms
X <- model.matrix(delete.response(tt), newdata, contrasts =
- if(length(object at contrasts)) object at contrasts else NULL,
+ if (length(object at contrasts)) object at contrasts else NULL,
xlev = object at xlevels)
- if(nice21 && nrow(X)!=nrow(newdata)) {
+ if (nice21 && nrow(X)!=nrow(newdata)) {
as.save = attr(X, "assign")
X = X[rep(1, nrow(newdata)),,drop=FALSE]
dimnames(X) = list(dimnames(newdata)[[1]], "(Intercept)")
attr(X, "assign") = as.save # Restored
}
- offset = if(!is.null(off.num <- attr(tt, "offset"))) {
+ offset = if (!is.null(off.num <- attr(tt, "offset"))) {
eval(attr(tt, "variables")[[off.num+1]], newdata)
- } else if(!is.null(object at offset))
+ } else if (!is.null(object at offset))
eval(object at call$offset, newdata)
- if(is.smart(object) && length(object at smart.prediction)) {
+ if (is.smart(object) && length(object at smart.prediction)) {
wrapup.smart()
}
@@ -1347,11 +1347,11 @@ predict.cao <- function (object, newdata=NULL,
NOS = ncol(object at y)
sppnames = dimnames(object at y)[[2]]
modelno = ocontrol$modelno # 1,2,3,5 or 0
- M = if(any(slotNames(object) == "predictors") &&
+ M = if (any(slotNames(object) == "predictors") &&
is.matrix(object at predictors)) ncol(object at predictors) else
object at misc$M
MSratio = M / NOS # First value is g(mean) = quadratic form in lv
- if(type == "terms") {
+ if (type == "terms") {
terms.mat = matrix(0, nrow(X), Rank*NOS) # 1st R colns for spp.1, etc.
interceptvector = rep(0, len=NOS)
} else {
@@ -1361,16 +1361,16 @@ predict.cao <- function (object, newdata=NULL,
whichSpecies = 1:NOS # Do it all for all species
for(sppno in 1:length(whichSpecies)) {
thisSpecies = whichSpecies[sppno]
- indexSpecies = if(is.character(whichSpecies))
+ indexSpecies = if (is.character(whichSpecies))
match(whichSpecies[sppno], sppnames) else whichSpecies[sppno]
- if(is.na(indexSpecies))
+ if (is.na(indexSpecies))
stop("mismatch found in 'whichSpecies'")
temp345 = predictcao(object, grid=lvmat, sppno=thisSpecies,
Rank=Rank, deriv=deriv, MSratio=MSratio,
type=ifelse(type=="response", "link", type))
- if(MSratio == 2) {
- if(any(type == c("link", "response"))) {
+ if (MSratio == 2) {
+ if (any(type == c("link", "response"))) {
etamat[,2*sppno-1] = temp345$yvals
etamat[,2*sppno ] = temp345$eta2
} else {
@@ -1378,7 +1378,7 @@ predict.cao <- function (object, newdata=NULL,
interceptvector[sppno] = attr(temp345, "constant")
}
} else {
- if(any(type == c("link", "response"))) {
+ if (any(type == c("link", "response"))) {
etamat[,sppno] = temp345$yvals
} else {
terms.mat[,ind8] = temp345
@@ -1388,14 +1388,14 @@ predict.cao <- function (object, newdata=NULL,
ind8 = ind8 + Rank
}
- if(length(offset) && any(offset != 0))
+ if (length(offset) && any(offset != 0))
etamat <- etamat + offset
- if(type == "link") {
- dimnames(etamat) = list(dimnames(X)[[1]], if(deriv == 0)
+ if (type == "link") {
+ dimnames(etamat) = list(dimnames(X)[[1]], if (deriv == 0)
object at misc$predictors.names else NULL)
return(etamat)
- } else if(type == "response") {
+ } else if (type == "response") {
fv <- object at family@inverse(etamat, extra=object at extra)
dimnames(fv) = list(dimnames(fv)[[1]],
dimnames(object at fitted.values)[[2]])
@@ -1414,17 +1414,17 @@ setMethod("predict", "cao", function(object, ...)
predictcao <- function(object, grid, sppno, Rank=1, deriv=0, MSratio=1,
type="link") {
- if(type != "link" && type != "terms")
+ if (type != "link" && type != "terms")
stop("'link' must be \"link\" or \"terms\"")
- if(ncol(grid <- as.matrix(grid)) != Rank)
+ if (ncol(grid <- as.matrix(grid)) != Rank)
stop("'grid' must have ", Rank, " columns")
- if(!is.Numeric(1+deriv, allow=1, positive=TRUE, integ=TRUE))
+ if (!is.Numeric(1+deriv, allow=1, positive=TRUE, integ=TRUE))
stop("'deriv' must be a non-negative integer")
- if(type == "terms" && deriv != 0)
+ if (type == "terms" && deriv != 0)
stop("'deriv' must be 0 when type=\"terms\"")
temp.b = object at Bspline[[sppno]]
- if(type == "terms") {
+ if (type == "terms") {
meanlv = colMeans(grid)
answer = matrix(0, nrow(grid), Rank)
} else {
@@ -1434,7 +1434,7 @@ predictcao <- function(object, grid, sppno, Rank=1, deriv=0, MSratio=1,
temp = temp.b[[rindex]] # temp is of class "vsmooth.spline.fit"
nlpart = predict(temp, grid[,rindex], deriv=deriv)
yvals = nlpart$y
- if(type == "terms") {
+ if (type == "terms") {
answer[,rindex] = yvals
} else {
nlfunvalues = nlfunvalues + yvals
@@ -1444,7 +1444,7 @@ predictcao <- function(object, grid, sppno, Rank=1, deriv=0, MSratio=1,
# Get the linear part of the additive predictor (intercept and slopes)
lcoef = object at coefficients # linear coeffs; dont use coef() (==Coef)
llcoef = lcoef[(1+(sppno-1)*(MSratio+Rank)):(sppno*(MSratio+Rank))]
- if(type == "terms") {
+ if (type == "terms") {
interceptvector = llcoef[1]
for(rindex in 1:Rank) {
answer[,rindex] = answer[,rindex] +
@@ -1453,17 +1453,17 @@ predictcao <- function(object, grid, sppno, Rank=1, deriv=0, MSratio=1,
meanlv[rindex] * llcoef[MSratio+rindex]
}
} else {
- linpar = if(deriv==0) {llcoef[1]+grid %*% llcoef[-(1:MSratio)]} else
+ linpar = if (deriv==0) {llcoef[1]+grid %*% llcoef[-(1:MSratio)]} else
{if(deriv==1) llcoef[MSratio+rindex] else 0}
nlfunvalues = nlfunvalues + linpar # Now complete
}
- if(type == "terms") {
+ if (type == "terms") {
attr(answer, "constant") = interceptvector
answer
} else {
list(xvals = grid,
yvals = c(nlfunvalues),
- eta2 = if(MSratio == 2) llcoef[MSratio] else NULL)
+ eta2 = if (MSratio == 2) llcoef[MSratio] else NULL)
}
}
@@ -1471,7 +1471,7 @@ predictcao <- function(object, grid, sppno, Rank=1, deriv=0, MSratio=1,
plot.cao = function(x,
- xlab=if(Rank==1) "Latent Variable" else
+ xlab = if (Rank == 1) "Latent Variable" else
paste("Latent Variable", 1:Rank),
ylab=NULL, residuals.arg=FALSE,
pcol=par()$col, pcex=par()$cex, pch=par()$pch,
@@ -1486,16 +1486,16 @@ plot.cao = function(x,
overlay = FALSE, ...)
{
Rank = x at control$Rank
- if(!is.logical(center.cf) || length(center.cf) != 1)
+ if (!is.logical(center.cf) || length(center.cf) != 1)
stop("bad input for argument 'center.cf'")
- if(Rank > 1 && !center.cf)
+ if (Rank > 1 && !center.cf)
stop("center.cf=TRUE is needed for models with Rank>1")
NOS = ncol(x at y)
sppnames = dimnames(x at y)[[2]]
modelno = x at control$modelno # 1,2,3, or 0
- M = if(any(slotNames(x) == "predictors") &&
+ M = if (any(slotNames(x) == "predictors") &&
is.matrix(x at predictors)) ncol(x at predictors) else x at misc$M
- if(all((MSratio <- M / NOS) != c(1,2))) stop("bad value for 'MSratio'")
+ if (all((MSratio <- M / NOS) != c(1,2))) stop("bad value for 'MSratio'")
pcol = rep(pcol, length=Rank*NOS)
pcex = rep(pcex, length=Rank*NOS)
pch = rep(pch, length=Rank*NOS)
@@ -1503,22 +1503,22 @@ plot.cao = function(x,
lwd = rep(lwd, length=Rank*NOS)
lty = rep(lty, length=Rank*NOS)
xlab = rep(xlab, length=Rank)
- if(!length(whichSpecies)) whichSpecies = 1:NOS
- if(length(ylab))
+ if (!length(whichSpecies)) whichSpecies = 1:NOS
+ if (length(ylab))
ylab = rep(ylab, len=length(whichSpecies)) # Too long if overlay
- if(length(main))
+ if (length(main))
main = rep(main, len=length(whichSpecies)) # Too long if overlay
lvmat = lv(x)
nice21 = length(x at control$colx1.index) == 1 &&
names(x at control$colx1.index) == "(Intercept)"
- if(!nice21)
+ if (!nice21)
stop("can only handle intercept-only models")
counter = 0
for(sppno in 1:length(whichSpecies)) {
thisSpecies = whichSpecies[sppno]
- indexSpecies = if(is.character(whichSpecies))
+ indexSpecies = if (is.character(whichSpecies))
match(whichSpecies[sppno], sppnames) else whichSpecies[sppno]
- if(is.na(indexSpecies))
+ if (is.na(indexSpecies))
stop("mismatch found in 'whichSpecies'")
terms.mat = predictcao(object=x, grid=lvmat, type="terms",
sppno=indexSpecies, Rank=Rank,
@@ -1529,27 +1529,27 @@ plot.cao = function(x,
o = sort.list(xvals)
xvals = xvals[ o ]
yvals = yvals[ o ]
- if(!center.cf) yvals = yvals + attr(terms.mat, "constant")
- if(!add)
- if(sppno==1 || !overlay) {
- ylim.use = if(length(ylim)) ylim else
+ if (!center.cf) yvals = yvals + attr(terms.mat, "constant")
+ if (!add)
+ if (sppno==1 || !overlay) {
+ ylim.use = if (length(ylim)) ylim else
ylim.scale(range(yvals), scale)
matplot(xvals, yvals, type="n",
xlab=xlab[rindex],
- ylab=if(length(ylab)) ylab[sppno] else
+ ylab = if (length(ylab)) ylab[sppno] else
ifelse(overlay, "Fitted functions", "Fitted function"),
- main=if(length(main)) main[sppno] else
+ main = if (length(main)) main[sppno] else
ifelse(overlay, "", sppnames[thisSpecies]),
ylim=ylim.use,
...)
}
- if(residuals.arg) {
+ if (residuals.arg) {
stop("cannot handle residuals=TRUE yet")
}
counter = counter + 1
lines(xvals, yvals,
col=lcol[counter], lwd=lwd[counter], lty=lty[counter])
- if(rugplot) rug(xvals)
+ if (rugplot) rug(xvals)
}
}
invisible(x)
@@ -1560,7 +1560,7 @@ plot.cao = function(x,
setMethod("plot", "cao",
function(x, y, ...) {
- if(!missing(y)) stop("cannot process the 'y' argument")
+ if (!missing(y)) stop("cannot process the 'y' argument")
invisible(plot.cao(x, ...))})
@@ -1568,48 +1568,48 @@ setMethod("plot", "cao",
persp.cao = function(x,
plot.it=TRUE,
xlim=NULL, ylim=NULL, zlim=NULL, # zlim ignored if Rank==1
- gridlength=if(Rank==1) 301 else c(51,51),
+ gridlength = if (Rank==1) 301 else c(51,51),
whichSpecies = NULL,
- xlab=if(Rank==1) "Latent Variable" else "Latent Variable 1",
- ylab=if(Rank==1) "Expected Value" else "Latent Variable 2",
+ xlab= if (Rank==1) "Latent Variable" else "Latent Variable 1",
+ ylab= if (Rank==1) "Expected Value" else "Latent Variable 2",
zlab="Expected value",
labelSpecies = FALSE, # For Rank==1 only
stretch = 1.05, # quick and dirty, Rank==1 only
main="",
ticktype = "detailed",
- col = if(Rank==1) par()$col else "white",
+ col = if (Rank==1) par()$col else "white",
lty=par()$lty,
lwd=par()$lwd,
rugplot=FALSE,
...) {
object = x # don't like x as the primary argument
coefobj = Coef(object)
- if((Rank <- coefobj at Rank) > 2)
+ if ((Rank <- coefobj at Rank) > 2)
stop("object must be a rank-1 or rank-2 model")
fvmat = fitted(object)
NOS = ncol(fvmat) # Number of species
- M = if(any(slotNames(object) == "predictors") &&
+ M = if (any(slotNames(object) == "predictors") &&
is.matrix(object at predictors)) ncol(object at predictors) else
object at misc$M
MSratio = M / NOS # First value is g(mean) = quadratic form in lv
- xlim = if(length(xlim)) xlim else range(coefobj at lv[,1])
- if(!length(ylim.orig <- ylim)) {
- ylim = if(Rank==1) c(0, max(fvmat)*stretch) else range(coefobj at lv[,2])
+ xlim = if (length(xlim)) xlim else range(coefobj at lv[,1])
+ if (!length(ylim.orig <- ylim)) {
+ ylim = if (Rank==1) c(0, max(fvmat)*stretch) else range(coefobj at lv[,2])
}
xlim = rep(xlim, length=2)
ylim = rep(ylim, length=2)
gridlength = rep(gridlength, length=Rank)
lv1 = seq(xlim[1], xlim[2], length=gridlength[1])
- lv2 = if(Rank == 2) seq(ylim[1], ylim[2], len=gridlength[2]) else NULL
- lvmat = if(Rank == 2) expand.grid(lv1, lv2) else cbind(lv1)
+ lv2 = if (Rank == 2) seq(ylim[1], ylim[2], len=gridlength[2]) else NULL
+ lvmat = if (Rank == 2) expand.grid(lv1, lv2) else cbind(lv1)
sppNames = dimnames(object at y)[[2]]
- if(!length(whichSpecies)) {
+ if (!length(whichSpecies)) {
whichSpecies = sppNames[1:NOS]
whichSpecies.numer = 1:NOS
} else
- if(is.numeric(whichSpecies)) {
+ if (is.numeric(whichSpecies)) {
whichSpecies.numer = whichSpecies
whichSpecies = sppNames[whichSpecies.numer] # Convert to character
} else
@@ -1621,27 +1621,27 @@ persp.cao = function(x,
Rank=Rank, deriv=0, MSratio=MSratio)
LP[,sppno] = temp$yval
}
- if(MSratio == 2) {
+ if (MSratio == 2) {
LP = kronecker(LP, matrix(1:0, 1, 2)) # n x M
}
fitvals = object at family@inverse(LP, extra=object at extra) # n by NOS
dimnames(fitvals) = list(NULL, dimnames(fvmat)[[2]])
- if(Rank==1) {
- if(plot.it) {
- if(!length(ylim.orig))
+ if (Rank==1) {
+ if (plot.it) {
+ if (!length(ylim.orig))
ylim = c(0, max(fitvals[,whichSpecies.numer])*stretch) # A revision
col = rep(col, len=length(whichSpecies.numer))
lty = rep(lty, len=length(whichSpecies.numer))
lwd = rep(lwd, len=length(whichSpecies.numer))
matplot(lv1, fitvals, xlab=xlab, ylab=ylab,
type="n", main=main, xlim=xlim, ylim=ylim, ...)
- if(rugplot) rug(lv(object))
+ if (rugplot) rug(lv(object))
for(sppno in 1:length(whichSpecies.numer)) {
ptr2 = whichSpecies.numer[sppno] # points to species column
lines(lv1, fitvals[,ptr2], col=col[sppno],
lty=lty[sppno], lwd=lwd [sppno], ...)
- if(labelSpecies) {
+ if (labelSpecies) {
ptr1=(1:nrow(fitvals))[max(fitvals[,ptr2])==fitvals[,ptr2]]
ptr1 = ptr1[1]
text(lv1[ptr1], fitvals[ptr1,ptr2]+(stretch-1) *
@@ -1652,24 +1652,24 @@ persp.cao = function(x,
}
} else {
maxfitted = matrix(fitvals[,whichSpecies[1]], length(lv1), length(lv2))
- if(length(whichSpecies) > 1)
+ if (length(whichSpecies) > 1)
for(sppno in whichSpecies[-1]) {
maxfitted = pmax(maxfitted, matrix(fitvals[,sppno],
length(lv1), length(lv2)))
}
- if(!length(zlim))
+ if (!length(zlim))
zlim = range(maxfitted, na.rm = TRUE)
- if(plot.it)
+ if (plot.it)
graphics:::persp.default(lv1, lv2, maxfitted,
zlim=zlim,
xlab=xlab, ylab=ylab, zlab=zlab,
ticktype = ticktype, col = col, main=main, ...)
}
- invisible(list(fitted=fitvals,
- lv1grid=lv1,
- lv2grid=if(Rank==2) lv2 else NULL,
- maxfitted=if(Rank==2) maxfitted else NULL))
+ invisible(list(fitted = fitvals,
+ lv1grid = lv1,
+ lv2grid = if (Rank == 2) lv2 else NULL,
+ maxfitted = if (Rank == 2) maxfitted else NULL))
}
@@ -1731,9 +1731,9 @@ printsummary.cao = function(x, ...) {
cat("\nNumber of species: ", x at NOS, "\n")
- if(length(x at misc$dispersion) == 1) {
+ if (length(x at misc$dispersion) == 1) {
cat("\nDispersion parameter(s): ", x at misc$dispersion, "\n")
- } else if(is.Numeric(x at dispersion)) {
+ } else if (is.Numeric(x at dispersion)) {
cat("\nDispersion parameter(s)\n")
print( x at dispersion, ... )
}
@@ -1756,7 +1756,7 @@ ccoef.cao = function(object, ...) {
}
ccoef.Coef.cao = function(object, ...) {
- if(length(list(...))) warning("Too late! Ignoring the extra arguments")
+ if (length(list(...))) warning("Too late! Ignoring the extra arguments")
object at C
}
diff --git a/R/coef.vlm.q b/R/coef.vlm.q
index 8f8fff1..678fdb6 100644
--- a/R/coef.vlm.q
+++ b/R/coef.vlm.q
@@ -1,5 +1,5 @@
# These functions are
-# Copyright (C) 1998-2009 T.W. Yee, University of Auckland. All rights reserved.
+# Copyright (C) 1998-2010 T.W. Yee, University of Auckland. All rights reserved.
@@ -9,9 +9,9 @@
coefvlm <- function(object, matrix.out=FALSE, label=TRUE) {
ans <- object at coefficients
- if(!label)
+ if (!label)
names(ans) <- NULL
- if(!matrix.out)
+ if (!matrix.out)
return(ans)
@@ -19,12 +19,12 @@ coefvlm <- function(object, matrix.out=FALSE, label=TRUE) {
M <- object at misc$M
Blist <- object at constraints
- if(all(trivial.constraints(Blist) == 1)) {
+ if (all(trivial.constraints(Blist) == 1)) {
Bmat <- matrix(ans, nrow=ncolx, ncol=M, byrow=TRUE)
} else {
Bmat <- matrix(as.numeric(NA), nrow=ncolx, ncol=M)
- if(!matrix.out)
+ if (!matrix.out)
return(ans)
ncolBlist <- unlist(lapply(Blist, ncol))
@@ -37,7 +37,7 @@ coefvlm <- function(object, matrix.out=FALSE, label=TRUE) {
}
}
- if(label) {
+ if (label) {
d1 <- object at misc$colnames.x
d2 = object at misc$predictors.names # Could be NULL
dimnames(Bmat) <- list(d1, d2)
@@ -60,18 +60,28 @@ setMethod("coef", "vglm", function(object, ...)
+
+setMethod("coefficients", "summary.vglm", function(object, ...) object at coef3)
+setMethod("coef", "summary.vglm", function(object, ...) object at coef3)
+
+
+
+
+
+
+
Coef.vlm <- function(object, ...) {
LL <- length(object at family@vfamily)
funname = paste("Coef.", object at family@vfamily[LL], sep="")
- if(exists(funname)) {
+ if (exists(funname)) {
newcall = paste("Coef.", object at family@vfamily[LL],
"(object, ...)", sep="")
newcall = parse(text=newcall)[[1]]
eval(newcall)
} else
- if(length(tmp2 <- object at misc$link) &&
+ if (length(tmp2 <- object at misc$link) &&
object at misc$intercept.only &&
trivial.constraints(object at constraints)) {
@@ -79,7 +89,7 @@ Coef.vlm <- function(object, ...) {
link = object at misc$link,
earg = object at misc$earg)
answer = c(answer)
- if(length(ntmp2 <- names(tmp2)) == object at misc$M)
+ if (length(ntmp2 <- names(tmp2)) == object at misc$M)
names(answer) = ntmp2
answer
} else {
diff --git a/R/cqo.R b/R/cqo.R
index 3b8c8de..277b155 100644
--- a/R/cqo.R
+++ b/R/cqo.R
@@ -1,5 +1,6 @@
# These functions are
-# Copyright (C) 1998-2009 T.W. Yee, University of Auckland. All rights reserved.
+# Copyright (C) 1998-2010 T.W. Yee, University of Auckland. All rights reserved.
+
cqo <- function(formula,
diff --git a/R/cqo.fit.q b/R/cqo.fit.q
index 22e454f..adacadd 100644
--- a/R/cqo.fit.q
+++ b/R/cqo.fit.q
@@ -1,5 +1,5 @@
# These functions are
-# Copyright (C) 1998-2009 T.W. Yee, University of Auckland. All rights reserved.
+# Copyright (C) 1998-2010 T.W. Yee, University of Auckland. All rights reserved.
@@ -7,6 +7,9 @@
callcqof = function(cmatrix, etamat, xmat, ymat, wvec,
X_vlm_1save, modelno, Control,
n, M, p1star, p2star, nice31, allofit=FALSE) {
+ print("in callcqof 20090729")
+ print("cmatrix")
+ print( cmatrix )
ocmatrix = cmatrix
control = Control
Rank = control$Rank
@@ -14,27 +17,29 @@ callcqof = function(cmatrix, etamat, xmat, ymat, wvec,
dim(cmatrix) = c(p2, Rank) # for crow1C
pstar = p1star + p2star
maxMr = max(M, Rank)
- nstar = if(nice31) ifelse(modelno==3 || modelno==5,n*2,n) else n*M
+ nstar = if (nice31) ifelse(modelno==3 || modelno==5,n*2,n) else n*M
NOS = ifelse(modelno == 3 || modelno==5, M/2, M)
lenbeta = pstar * ifelse(nice31, NOS, 1)
- if(itol <- control$ITolerances) {
- if(Rank > 1) {
+ if (itol <- control$ITolerances) {
+ if (Rank > 1) {
numat = xmat[,control$colx2.index,drop=FALSE] %*% cmatrix
evnu = eigen(var(numat))
cmatrix = cmatrix %*% evnu$vector
}
+ print("control$isdlv")
+ print( control$isdlv )
cmatrix = crow1C(cmatrix, control$Crow1positive)
numat = xmat[,control$colx2.index,drop=FALSE] %*% cmatrix
sdnumat = sd(numat)
for(lookat in 1:Rank)
- if(sdnumat[lookat]>control$MUXfactor[lookat]*control$isdlv[lookat]){
+ if (sdnumat[lookat]>control$MUXfactor[lookat]*control$isdlv[lookat]){
muxer = control$isdlv[lookat] * control$MUXfactor[lookat] /
sdnumat[lookat]
numat[,lookat] = numat[,lookat] * muxer
cmatrix[,lookat] = cmatrix[,lookat]*muxer # unneeded in callcqof
- if(control$trace) {
+ if (control$trace) {
cat(paste("Taking evasive action for latent variable ",
lookat, ".\n", sep=""))
flush.console()
@@ -45,38 +50,57 @@ callcqof = function(cmatrix, etamat, xmat, ymat, wvec,
} else {
numat = xmat[,control$colx2.index,drop=FALSE] %*% cmatrix
evnu = eigen(var(numat))
- temp7 = if(Rank > 1) evnu$vector %*% diag(evnu$value^(-0.5)) else
+ temp7 = if (Rank > 1) evnu$vector %*% diag(evnu$value^(-0.5)) else
evnu$vector %*% evnu$value^(-0.5)
cmatrix = cmatrix %*% temp7
cmatrix = crow1C(cmatrix, control$Crow1positive)
numat = xmat[,control$colx2.index,drop=FALSE] %*% cmatrix
+ print("var(numat) 20090729nn")
+ print( var(numat) )
}
- inited = if(is.R()) {
- if(exists(".VGAM.CQO.etamat", envir = VGAMenv)) 1 else 0
+ inited = if (is.R()) {
+ if (exists(".VGAM.CQO.etamat", envir = VGAMenv)) 1 else 0
} else 0
- usethiseta = if(inited==1)
+ usethiseta = if (inited==1)
getfromVGAMenv("etamat", prefix = ".VGAM.CQO.") else t(etamat)
- usethisbeta = if(inited==2)
+ usethisbeta = if (inited==2)
getfromVGAMenv("beta", prefix = ".VGAM.CQO.") else double(lenbeta)
- othint = c(Rank, control$EqualTol, pstar, dimw=1, inited=inited,
- modelno, maxitl=control$maxitl, actnits=0, twice=0,
- p1star=p1star, p2star=p2star, nice31=nice31, lenbeta,
- itol=itol, control$trace, p1, p2, control$method.init)
- bnumat = if(nice31) matrix(0,nstar,pstar) else
+ othint = c(Rank=Rank, control$EqualTol, pstar=pstar, dimw=1, inited=inited,
+ modelno=modelno, maxitl=control$maxitl, actnits=0, twice=0,
+ p1star=p1star, p2star=p2star, nice31=nice31, lenbeta=lenbeta,
+ itol=itol, control$trace, p1=p1, p2=p2, control$method.init)
+ print("X_vlm_1save 20090729")
+ print( X_vlm_1save )
+ bnumat = if (nice31) matrix(0,nstar,pstar) else
cbind(matrix(0,nstar,p2star), X_vlm_1save)
-if(TRUE) {
+ print("M")
+ print( M )
+ print("NOS")
+ print( NOS )
+ print("othint")
+ print( othint )
+ if (TRUE) {
}
+ print("usethiseta")
+ print( usethiseta )
+ print("c(p1,p2,p1star,p2star,pstar)")
+ print( c(p1,p2,p1star,p2star,pstar) )
+ print('in callcqof: nice31')
+ print( nice31 )
+ print('if (nice31) "cqo1f" else "cqo2f"')
+ print( if (nice31) "cqo1f" else "cqo2f" )
+
ans1 <-
- dotFortran(name=if(nice31) "cqo1f" else "cqo2f",
+ dotFortran(name=if (nice31) "cqo1f" else "cqo2f",
numat=as.double(numat), as.double(ymat),
- as.double(if(p1) xmat[,control$colx1.index] else 999),
+ as.double(if (p1) xmat[,control$colx1.index] else 999),
as.double(wvec), etamat=as.double(usethiseta),
- moff=double(if(itol) n else 1),
+ moff=double(if (itol) n else 1),
fv=double(NOS*n), z=double(n*M), wz=double(n*M),
U=double(M*n), bnumat=as.double(bnumat),
qr=double(nstar*pstar), qraux=double(pstar), qpivot=integer(pstar),
@@ -85,17 +109,24 @@ if(TRUE) {
errcode=integer(1), othint=as.integer(othint),
rowind=integer(maxMr*(maxMr+1)/2), colind=integer(maxMr*(maxMr+1)/2),
deviance=double(1), beta=as.double(usethisbeta),
- twk=double(if(nice31) nstar*3 else M*n*2), wkmm=double(M*(M+pstar)),
+ twk=double(if (nice31) nstar*3 else M*n*2), wkmm=double(M*(M+pstar)),
othdbl=as.double(c(small=control$SmallNo, epsilon=control$epsilon,
.Machine$double.eps,
iKvector=rep(control$iKvector, len=NOS),
iShape=rep(control$iShape, len=NOS))))
+ print("Out of Fortran now; ans1$deviance")
+ print( ans1$deviance )
+ print("ans1$qpivot")
+ print( ans1$qpivot )
+ print(paste("out of fortran", if (nice31) "cqo1f" else "cqo2f"))
+ print("hi 44 20090729")
- if(ans1$errcode == 0) {
+ if (ans1$errcode == 0) {
+ print("hi 77 20090729")
assign2VGAMenv(c("etamat", "z", "U", "beta", "deviance"),
ans1, prefix=".VGAM.CQO.")
- if(is.R()) {
+ if (is.R()) {
assign(".VGAM.CQO.cmatrix", cmatrix, envir = VGAMenv)
assign(".VGAM.CQO.ocmatrix", ocmatrix, envir = VGAMenv)
} else {
@@ -103,16 +134,22 @@ if(TRUE) {
.VGAM.CQO.ocmatrix <<- ocmatrix
}
} else {
+ print("hi 88 20090729")
warning(paste("error code in callcqof =", ans1$errcode))
rmfromVGAMenv(c("etamat", "z", "U", "beta", "deviance",
"cmatrix", "ocmatrix"), prefix=".VGAM.CQO.")
}
- if(control$trace)
+ print("ans1$beta")
+ print( ans1$beta )
+ if (control$trace)
flush.console()
- if(allofit) list(deviance=ans1$deviance, coefficients=ans1$beta) else
+ print("out of callcqof 20090729")
+ if (allofit) list(deviance=ans1$deviance, coefficients=ans1$beta) else
ans1$deviance
}
+
+
calldcqof = function(cmatrix, etamat, xmat, ymat, wvec,
X_vlm_1save, modelno, Control,
n, M, p1star, p2star, nice31, allofit=FALSE) {
@@ -125,12 +162,12 @@ calldcqof = function(cmatrix, etamat, xmat, ymat, wvec,
numat <- double(n*Rank) #ccc
pstar = p1star + p2star
maxMr = max(M, Rank)
- nstar = if(nice31) ifelse(modelno==3 || modelno==5,n*2,n) else n*M
+ nstar = if (nice31) ifelse(modelno==3 || modelno==5,n*2,n) else n*M
NOS = ifelse(modelno == 3 || modelno==5, M/2, M)
lenbeta = pstar * ifelse(nice31, NOS, 1)
- if(itol <- control$ITolerances) {
- if(Rank > 1) {
+ if (itol <- control$ITolerances) {
+ if (Rank > 1) {
numat = xmat[,control$colx2.index,drop=FALSE] %*% cmatrix
evnu = eigen(var(numat))
cmatrix = cmatrix %*% evnu$vector
@@ -140,11 +177,11 @@ calldcqof = function(cmatrix, etamat, xmat, ymat, wvec,
numat = xmat[,control$colx2.index,drop=FALSE] %*% cmatrix
sdnumat = sd(numat)
for(lookat in 1:Rank)
- if(sdnumat[lookat]>control$MUXfactor[lookat]*control$isdlv[lookat]){
+ if (sdnumat[lookat]>control$MUXfactor[lookat]*control$isdlv[lookat]){
muxer = control$isdlv[lookat] * control$MUXfactor[lookat] /
sdnumat[lookat]
cmatrix[,lookat] = cmatrix[,lookat] * muxer
- if(control$trace) {
+ if (control$trace) {
cat(paste("Taking evasive action for latent variable ",
lookat, ".\n", sep=""))
flush.console()
@@ -155,21 +192,21 @@ calldcqof = function(cmatrix, etamat, xmat, ymat, wvec,
} else {
numat = xmat[,control$colx2.index,drop=FALSE] %*% cmatrix
evnu = eigen(var(numat))
- temp7 = if(Rank > 1) evnu$vector %*% diag(evnu$value^(-0.5)) else
+ temp7 = if (Rank > 1) evnu$vector %*% diag(evnu$value^(-0.5)) else
evnu$vector %*% evnu$value^(-0.5)
cmatrix = cmatrix %*% temp7
cmatrix = crow1C(cmatrix, control$Crow1positive)
numat = xmat[,control$colx2.index,drop=FALSE] %*% cmatrix
}
- inited = if(is.R()) {
- if(exists(".VGAM.CQO.etamat", envir = VGAMenv)) 1 else 0
+ inited = if (is.R()) {
+ if (exists(".VGAM.CQO.etamat", envir = VGAMenv)) 1 else 0
} else 0
- usethiseta = if(inited==1)
+ usethiseta = if (inited==1)
getfromVGAMenv("etamat", prefix = ".VGAM.CQO.") else t(etamat)
- usethisbeta = if(inited==2)
+ usethisbeta = if (inited==2)
getfromVGAMenv("beta", prefix = ".VGAM.CQO.") else double(lenbeta)
othint = c(Rank, control$EqualTol, pstar, dimw=1, inited=inited,
@@ -177,15 +214,17 @@ calldcqof = function(cmatrix, etamat, xmat, ymat, wvec,
p1star=p1star, p2star=p2star, nice31=nice31, lenbeta,
itol=itol, control$trace,
p1, p2, control$method.init) # other ints
- bnumat = if(nice31) matrix(0,nstar,pstar) else
+ bnumat = if (nice31) matrix(0,nstar,pstar) else
cbind(matrix(0,nstar,p2star), X_vlm_1save)
+ print("X_vlm_1save 20090729")
+ print( X_vlm_1save )
flush.console()
ans1 <-
dotFortran(name="dcqof", numat=as.double(numat), as.double(ymat),
- as.double(if(p1) xmat[,control$colx1.index] else 999),
+ as.double(if (p1) xmat[,control$colx1.index] else 999),
as.double(wvec), etamat=as.double(usethiseta),
- moff=double(if(itol) n else 1),
+ moff=double(if (itol) n else 1),
fv=double(NOS*n), z=double(n*M), wz=double(n*M),
U=double(M*n), bnumat=as.double(bnumat),
qr=double(nstar*pstar), qraux=double(pstar), qpivot=integer(pstar),
@@ -194,7 +233,7 @@ calldcqof = function(cmatrix, etamat, xmat, ymat, wvec,
errcode=integer(1), othint=as.integer(othint),
rowind=integer(maxMr*(maxMr+1)/2), colind=integer(maxMr*(maxMr+1)/2),
deviance=double(1), beta=as.double(usethisbeta),
- twk=double(if(nice31) nstar*3 else M*n*2), wkmm=double(M*(M+pstar)),
+ twk=double(if (nice31) nstar*3 else M*n*2), wkmm=double(M*(M+pstar)),
othdbl=as.double(c(small=control$SmallNo, epsilon=control$epsilon,
.Machine$double.eps,
iKvector=rep(control$iKvector, len=NOS),
@@ -203,7 +242,7 @@ calldcqof = function(cmatrix, etamat, xmat, ymat, wvec,
p2=as.integer(p2), deriv=double(p2*Rank), hstep=as.double(control$Hstep),
betasave=double(lenbeta))
- if(ans1$errcode != 0) {
+ if (ans1$errcode != 0) {
warning(paste("error code in calldcqof =", ans1$errcode))
}
@@ -216,11 +255,11 @@ checkCMCO <- function(Blist, control, modelno) {
p1 = length(colx1.index <- control$colx1.index)
p2 = length(colx2.index <- control$colx2.index)
- if(p1 + p2 != length(Blist))
+ if (p1 + p2 != length(Blist))
stop("'Blist' is the wrong length")
- if(p1 == 0 || p2 == 0)
+ if (p1 == 0 || p2 == 0)
stop("Some variables are needed in Norrr and non-Norrr arguments")
- if(all(names(colx1.index) != "(Intercept)"))
+ if (all(names(colx1.index) != "(Intercept)"))
stop("an intercept term must be in the argument 'Norrr' formula")
Blist1 = vector("list", p1)
Blist2 = vector("list", p2)
@@ -229,33 +268,30 @@ checkCMCO <- function(Blist, control, modelno) {
for(k in 1:p2)
Blist2[[k]] = Blist[[(colx2.index[k])]]
- if(modelno == 3 || modelno == 5) {
- if(p1 > 1)
+ if (modelno == 3 || modelno == 5) {
+ if (p1 > 1)
for(k in 2:p1)
Blist1[[k]] = (Blist1[[k]])[c(TRUE,FALSE),,drop=FALSE]
for(k in 1:p2)
Blist2[[k]] = (Blist2[[k]])[c(TRUE,FALSE),,drop=FALSE]
}
- if(!all(trivial.constraints(Blist2) == 1))
+ if (!all(trivial.constraints(Blist2) == 1))
stop("the constraint matrices for the non-Norrr terms are not trivial")
- if(!trivial.constraints(Blist1[[1]]))
+ if (!trivial.constraints(Blist1[[1]]))
stop("the constraint matrices for intercept term is not trivial")
- if(p1 > 1)
+ if (p1 > 1)
for(k in 2:p1)
- if(!trivial.constraints(list(Blist1[[k]])))
+ if (!trivial.constraints(list(Blist1[[k]])))
stop("the constraint matrices for some Norrr terms is not trivial")
- nice31 = if(control$Quadratic)
+ nice31 = if (control$Quadratic)
(!control$EqualTol || control$ITolerances) else TRUE
as.numeric(nice31)
}
-
-
-
cqo.fit <- function(x, y, w=rep(1, length(x[, 1])),
etastart=NULL, mustart=NULL, coefstart=NULL,
offset=0, family,
@@ -264,7 +300,7 @@ cqo.fit <- function(x, y, w=rep(1, length(x[, 1])),
extra=NULL,
Terms=Terms, function.name="cqo", ...)
{
- if(!all(offset == 0)) stop("cqo.fit() cannot handle offsets")
+ if (!all(offset == 0)) stop("cqo.fit() cannot handle offsets")
specialCM = NULL
post = list()
nonparametric <- FALSE
@@ -289,34 +325,34 @@ cqo.fit <- function(x, y, w=rep(1, length(x[, 1])),
Rank <- control$Rank
rrcontrol <- control #
- if(length(family at initialize))
+ if (length(family at initialize))
eval(family at initialize) # Initialize mu and M (and optionally w)
n <- n.save
eval(rrr.init.expression)
- if(length(etastart)) {
+ if (length(etastart)) {
eta <- etastart
- mu <- if(length(mustart)) mustart else family at inverse(eta, extra)
+ mu <- if (length(mustart)) mustart else family at inverse(eta, extra)
} else {
- if(length(mustart))
+ if (length(mustart))
mu <- mustart
eta <- family at link(mu, extra)
}
- M <- if(is.matrix(eta)) ncol(eta) else 1
+ M <- if (is.matrix(eta)) ncol(eta) else 1
- if(is.character(rrcontrol$Dzero)) {
+ if (is.character(rrcontrol$Dzero)) {
index = match(rrcontrol$Dzero, dimnames(as.matrix(y))[[2]])
- if(any(is.na(index)))
+ if (any(is.na(index)))
stop("Dzero argument didn't fully match y-names")
- if(length(index) == M)
+ if (length(index) == M)
stop("all linear predictors are linear in the",
" latent variable(s); so set 'Quadratic=FALSE'")
rrcontrol$Dzero = control$Dzero = index
}
- if(length(family at constraints))
+ if (length(family at constraints))
eval(family at constraints)
@@ -325,21 +361,21 @@ cqo.fit <- function(x, y, w=rep(1, length(x[, 1])),
findex = trivial.constraints(just.testing, special.matrix)
tc1 = trivial.constraints(constraints)
- if(!control$Quadratic && sum(!tc1)) {
+ if (!control$Quadratic && sum(!tc1)) {
for(ii in names(tc1))
- if(!tc1[ii] && !any(ii == names(findex)[findex==1]))
+ if (!tc1[ii] && !any(ii == names(findex)[findex==1]))
warning(paste("\"", ii, "\"", " is a non-trivial constraint",
" that will be overwritten by reduced-rank regression", sep=""))
}
- if(all(findex == 1))
+ if (all(findex == 1))
stop("use vglm(), not rrvglm()!")
colx1.index = names.colx1.index = NULL
dx2 = dimnames(x)[[2]]
- if(sum(findex)) {
+ if (sum(findex)) {
asx = attr(x, "assign")
for(ii in names(findex))
- if(findex[ii]) {
+ if (findex[ii]) {
names.colx1.index = c(names.colx1.index, dx2[asx[[ii]]])
colx1.index = c(colx1.index, asx[[ii]])
}
@@ -355,11 +391,11 @@ cqo.fit <- function(x, y, w=rep(1, length(x[, 1])),
- Amat <- if(length(rrcontrol$Ainit)) rrcontrol$Ainit else
+ Amat <- if (length(rrcontrol$Ainit)) rrcontrol$Ainit else
matrix(rnorm(M * Rank, sd=rrcontrol$SD.Cinit), M, Rank)
- Cmat = if(length(rrcontrol$Cinit)) matrix(rrcontrol$Cinit, p2, Rank) else {
- if(!rrcontrol$Use.Init.Poisson.QO) {
+ Cmat = if (length(rrcontrol$Cinit)) matrix(rrcontrol$Cinit, p2, Rank) else {
+ if (!rrcontrol$Use.Init.Poisson.QO) {
matrix(rnorm(p2 * Rank, sd=rrcontrol$SD.Cinit), p2, Rank)
} else
.Init.Poisson.QO(ymat=as.matrix(y),
@@ -374,18 +410,18 @@ cqo.fit <- function(x, y, w=rep(1, length(x[, 1])),
takelog= any(family at vfamily[1] != c("gaussianff")))
}
- if(rrcontrol$ITolerances) {
+ if (rrcontrol$ITolerances) {
lvmat = x[,rrcontrol$colx2.index,drop=FALSE] %*% Cmat
lvmatmeans = t(lvmat) %*% matrix(1/n, n, 1)
- if(!all(abs(lvmatmeans) < 4))
+ if (!all(abs(lvmatmeans) < 4))
warning(paste("ITolerances=TRUE but the variables making up the",
"latent variable(s) do not appear to be centered,"))
}
- if(modelno==3 || modelno==5)
+ if (modelno==3 || modelno==5)
Amat[c(FALSE,TRUE),] <- 0 # Intercept only for log(k)
- if(length(control$Structural.zero))
+ if (length(control$Structural.zero))
Amat[control$Structural.zero,] = 0
rrcontrol$Ainit = control$Ainit = Amat # Good for valt()
@@ -396,23 +432,23 @@ cqo.fit <- function(x, y, w=rep(1, length(x[, 1])),
ncolBlist <- unlist(lapply(Blist, ncol))
dimB <- sum(ncolBlist)
- X_vlm_save <- if(nice31) {
+ X_vlm_save <- if (nice31) {
NULL
} else {
tmp500=lm2qrrvlm.model.matrix(x=x,Blist=Blist,C=Cmat,control=control)
xsmall.qrr = tmp500$new.lv.model.matrix
B.list = tmp500$constraints # Doesn't change or contain \bI_{Rank} \bnu
lv.mat = tmp500$lv.mat
- if(length(tmp500$offset)) {
+ if (length(tmp500$offset)) {
offset = tmp500$offset
}
lm2vlm.model.matrix(xsmall.qrr, B.list, xij=control$xij)
}
- if(length(coefstart) && length(X_vlm_save)) {
- eta <- if(ncol(X_vlm_save) > 1) X_vlm_save %*% coefstart +
+ if (length(coefstart) && length(X_vlm_save)) {
+ 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)
+ eta <- if (M > 1) matrix(eta, ncol=M, byrow=TRUE) else c(eta)
mu <- family at inverse(eta, extra)
}
@@ -420,20 +456,25 @@ cqo.fit <- function(x, y, w=rep(1, length(x[, 1])),
"cmatrix", "ocmatrix"), prefix=".VGAM.CQO.")
eval(cqo.init.derivative.expression)
+ print("hi 20090729a")
for(iter in 1:control$optim.maxit) {
+ print("hi 20090729b")
eval(cqo.derivative.expression)
- if(!quasi.newton$convergence) break
+ print("hi 20090729c")
+ if (!quasi.newton$convergence) break
+ print("hi 20090729d")
}
- if(maxitl>1 && iter>=maxitl && quasi.newton$convergence)
+ print("hi 20090729e")
+ if (maxitl>1 && iter>=maxitl && quasi.newton$convergence)
warning(paste("convergence not obtained in", maxitl, "iterations."))
- if(length(family at fini))
+ if (length(family at fini))
eval(family at fini)
asgn <- attr(x, "assign")
coefs = getfromVGAMenv("beta", prefix = ".VGAM.CQO.")
- if(control$ITolerances) {
- if(NOS == M) {
+ if (control$ITolerances) {
+ if (NOS == M) {
coefs = c(t(matrix(coefs, ncol=M))) # Get into right order
} else {
coefs = coefs
@@ -444,18 +485,18 @@ cqo.fit <- function(x, y, w=rep(1, length(x[, 1])),
yn <- dn[[1]]
xn <- dn[[2]]
residuals <- z - fv
- if(M==1) {
+ if (M==1) {
residuals <- as.vector(residuals)
names(residuals) <- yn
} else {
dimnames(residuals) <- list(yn, predictors.names)
}
- if(is.matrix(mu)) {
- if(length(dimnames(y)[[2]])) {
+ if (is.matrix(mu)) {
+ if (length(dimnames(y)[[2]])) {
y.names <- dimnames(y)[[2]]
}
- if(length(dimnames(mu)[[2]])) {
+ if (length(dimnames(mu)[[2]])) {
y.names <- dimnames(mu)[[2]]
}
dimnames(mu) <- list(yn, y.names)
@@ -474,10 +515,10 @@ cqo.fit <- function(x, y, w=rep(1, length(x[, 1])),
residuals=residuals,
terms=Terms) # terms: This used to be done in vglm()
- if(M==1) {
+ if (M==1) {
wz <- as.vector(wz) # Convert wz into a vector
}
- fit$weights <- if(save.weight) wz else NULL
+ fit$weights <- if (save.weight) wz else NULL
misc <- list(
colnames.x = xn,
@@ -492,10 +533,10 @@ cqo.fit <- function(x, y, w=rep(1, length(x[, 1])),
p = ncol(x),
ynames = dimnames(y)[[2]])
- if(w[1] != 1 || any(w != w[1]))
+ if (w[1] != 1 || any(w != w[1]))
fit$prior.weights <- w
- if(length(family at last))
+ if (length(family at last))
eval(family at last)
deviance = getfromVGAMenv("deviance", prefix = ".VGAM.CQO.")
@@ -517,7 +558,6 @@ cqo.fit <- function(x, y, w=rep(1, length(x[, 1])),
-
.Init.Poisson.QO = function(ymat, X1, X2, Rank=1, epsilon=1/32,
max.ncol.etamat = 10,
trace=FALSE, Crow1positive=rep(TRUE, len=Rank),
@@ -525,66 +565,67 @@ cqo.fit <- function(x, y, w=rep(1, length(x[, 1])),
constwt=FALSE, takelog=TRUE) {
- print.expression = expression({
- if(trace && length(X2)) {
+ print.CQO.expression = expression({
+ if (trace && length(X2)) {
cat("\nUsing initial values\n")
dimnames(ans) = list(dimnames(X2)[[2]],
- if(Rank==1) "lv" else paste("lv", 1:Rank, sep=""))
- if(p2>5) print(ans, dig=3) else print(t(ans), dig=3)
+ if (Rank==1) "lv" else paste("lv", 1:Rank, sep=""))
+ if (p2>5) print(ans, dig=3) else print(t(ans), dig=3)
}
flush.console()
})
+
sd.scale.X2.expression = expression({
- if(length(isdlv)) {
+ if (length(isdlv)) {
actualSD = c( sqrt(diag(var(X2 %*% ans))) )
for(ii in 1:Rank)
ans[,ii] = ans[,ii] * isdlv[ii] / actualSD[ii]
}
})
- Crow1positive = if(length(Crow1positive)) rep(Crow1positive, len=Rank) else
+ Crow1positive = if (length(Crow1positive)) rep(Crow1positive, len=Rank) else
rep(TRUE, len=Rank) # Not nice. Because $Crow1positive==NULL for RRVGLMs
- if(epsilon <= 0)
+ if (epsilon <= 0)
stop("epsilon > 0 is required")
ymat = cbind(ymat) + epsilon # ymat==0 cause problems
NOS = ncol(ymat)
p2 = ncol(X2)
- if(NOS < 2*Rank) {
+ if (NOS < 2*Rank) {
ans = crow1C(matrix(rnorm(p2*Rank, sd=0.02), p2, Rank), Crow1positive)
eval(sd.scale.X2.expression)
- if(NOS == 1) {
- eval(print.expression)
+ if (NOS == 1) {
+ eval(print.CQO.expression)
return(ans)
} else ans.save = ans; # ans.save contains scaled guesses
}
calS = 1:NOS # Set of all species available for the approximation
effrank = min(Rank, floor(NOS/2)) # effective rank
- ncol.etamat = min(if(length(X2)) floor(NOS/2) else effrank, max.ncol.etamat)
+ ncol.etamat = min(if (length(X2)) floor(NOS/2) else effrank, max.ncol.etamat)
etamat = wts = matrix(0, nrow=nrow(ymat), ncol=ncol.etamat) # has >=1 coln
rr = 1
for(ii in 1:floor(NOS/2)) {
- if(length(calS) < 2) break
+ if (length(calS) < 2) break
index = sample(calS, size=2) # Randomness here
- etamat[,rr] = etamat[,rr] + (if(takelog)
+ etamat[,rr] = etamat[,rr] + (if (takelog)
log(ymat[,index[1]] / ymat[,index[2]]) else
ymat[,index[1]] - ymat[,index[2]])
- wts[,rr]=wts[,rr]+(if(constwt) 1 else ymat[,index[1]]+ymat[,index[2]])
+ wts[,rr]=wts[,rr]+(if (constwt) 1 else ymat[,index[1]]+ymat[,index[2]])
calS = setdiff(calS, index)
rr = (rr %% ncol.etamat) + 1
}
- if(trace)
+ if (trace)
cat("\nObtaining initial values\n")
- if(length(X2)) {
+ if (length(X2)) {
alt = valt(x=cbind(X1, X2), z=etamat, U=sqrt(t(wts)), Rank=effrank,
Blist=NULL, Cinit=NULL, trace=FALSE, colx1.index=1:ncol(X1),
Criterion="rss")
temp.control = list(Rank=effrank, colx1.index = 1:ncol(X1), Alpha=0.5,
colx2.index = (ncol(X1)+1):(ncol(X1) + ncol(X2)),
- Corner=FALSE, Svd.arg=TRUE, Uncor=TRUE, Quadratic=FALSE)
+ Corner=FALSE, Svd.arg=TRUE, Uncorrelated.lv=TRUE, Quadratic=FALSE)
- ans2 = if(Rank > 1) rrr.normalize(rrcontrol=temp.control, A=alt$A,
+ ans2 = if (Rank > 1) rrr.normalize(rrcontrol=temp.control, A=alt$A,
C=alt$C, x=cbind(X1, X2)) else alt
ans = crow1C(ans2$C, rep(Crow1positive, len=effrank))
@@ -593,57 +634,56 @@ cqo.fit <- function(x, y, w=rep(1, length(x[, 1])),
eval(sd.scale.X2.expression)
Rank = Rank.save
- if(effrank < Rank) {
+ if (effrank < Rank) {
ans = cbind(ans, ans.save[,-(1:effrank)]) # ans is better
}
- eval(print.expression)
+ eval(print.CQO.expression)
} else {
xij = NULL # temporary measure
U = t(sqrt(wts))
tmp = vlm.wfit(xmat=X1, zmat=etamat, Blist=NULL, U=U, matrix.out=TRUE,
is.vlmX=FALSE, rss=TRUE, qr=FALSE, xij=xij)
ans = crow1C(as.matrix(tmp$resid), rep(Crow1positive, len=effrank))
- if(effrank < Rank) {
+ if (effrank < Rank) {
ans = cbind(ans, ans.save[,-(1:effrank)]) # ans is better
}
- if(Rank > 1) {
+ if (Rank > 1) {
evnu = eigen(var(ans))
ans = ans %*% evnu$vector
}
- if(length(isdlv)) {
+ if (length(isdlv)) {
actualSD = sd(ans)
for(ii in 1:Rank)
ans[,ii] = ans[,ii] * isdlv[ii] / actualSD[ii]
}
ans = crow1C(ans, rep(Crow1positive, len=Rank))
dimnames(ans) = list(dimnames(X1)[[1]],
- if(Rank==1) "lv" else paste("lv", 1:Rank, sep=""))
- if(trace)
- {if(nrow(ans) > 10) print(t(ans), dig=3) else print(ans, dig=3)}
+ if (Rank==1) "lv" else paste("lv", 1:Rank, sep=""))
+ if (trace)
+ {if (nrow(ans) > 10) print(t(ans), dig=3) else print(ans, dig=3)}
}
ans
}
-
cqo.init.derivative.expression <- expression({
- which.optimizer = if(is.R()) {
- if(control$Quadratic && control$FastAlgorithm) {
+ which.optimizer = if (is.R()) {
+ if (control$Quadratic && control$FastAlgorithm) {
"BFGS"
} else {
- if(iter <= rrcontrol$Switch.optimizer) "Nelder-Mead" else "BFGS"
+ if (iter <= rrcontrol$Switch.optimizer) "Nelder-Mead" else "BFGS"
}
} else "Quasi-Newton"
- if(trace && control$OptimizeWrtC) {
+ if (trace && control$OptimizeWrtC) {
cat("\nUsing", which.optimizer, "algorithm\n")
flush.console()
}
-if(FALSE) {
+ if (FALSE) {
constraints=replace.constraints(constraints,diag(M),rrcontrol$colx2.index)
nice31 = (!control$EqualTol || control$ITolerances) &&
@@ -651,19 +691,19 @@ if(FALSE) {
}
NOS = ifelse(modelno==3 || modelno==5, M/2, M)
- canfitok = if(is.R())
+ canfitok = if (is.R())
(exists("CQO.FastAlgorithm", envir=VGAMenv) &&
get("CQO.FastAlgorithm", envir = VGAMenv)) else
(exists("CQO.FastAlgorithm",inherits=TRUE) && CQO.FastAlgorithm)
- if(!canfitok)
+ if (!canfitok)
stop("cannot fit this model using fast algorithm")
- p2star = if(nice31)
+ 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) ifelse(modelno==3 || modelno==5,1+p1,p1) else
+ p1star = if (nice31) ifelse(modelno==3 || modelno==5,1+p1,p1) else
(ncol(X_vlm_save)-p2star)
- X_vlm_1save = if(p1star > 0) X_vlm_save[,-(1:p2star)] else NULL
+ X_vlm_1save = if (p1star > 0) X_vlm_save[,-(1:p2star)] else NULL
})
@@ -672,10 +712,14 @@ if(FALSE) {
cqo.derivative.expression <- expression({
-if(is.R()) {
- if(iter == 1 || quasi.newton$convergence) {
+ if (is.R()) {
+ if (iter == 1 || quasi.newton$convergence) {
+ print("hi 20090729; nice31")
+ print( nice31 )
+ print("hi 20090729; X_vlm_1save")
+ print( X_vlm_1save )
quasi.newton = optim(par=Cmat, fn=callcqof,
- gr=if(control$GradientFunction) calldcqof else NULL,
+ gr = if (control$GradientFunction) calldcqof else NULL,
method=which.optimizer,
control=list(fnscale=1,trace=as.integer(control$trace),
parscale=rep(control$Parscale, len=length(Cmat)),
@@ -684,6 +728,10 @@ if(is.R()) {
X_vlm_1save = X_vlm_1save,
modelno=modelno, Control=control,
n=n, M=M, p1star=p1star, p2star=p2star, nice31=nice31)
+ print("hi 20090729; quasi.newton$par")
+ print( quasi.newton$par )
+ print("hi 20090729; quasi.newton$value")
+ print( quasi.newton$value )
z = matrix(getfromVGAMenv("z", prefix=".VGAM.CQO."), n, M)
U = matrix(getfromVGAMenv("U", prefix=".VGAM.CQO."), M, n)
@@ -695,7 +743,7 @@ if(is.R()) {
ocmatrix = getfromVGAMenv("ocmatrix", prefix = ".VGAM.CQO.")
maxdiff = max(abs(c(ocmatrix) - c(quasi.newton$par)) / (1+abs(c(ocmatrix))))
-if(maxdiff < 1.0e-4) {
+ if (maxdiff < 1.0e-4) {
Cmat = getfromVGAMenv("cmatrix", prefix = ".VGAM.CQO.")
} else {
warning("solution does not correspond to .VGAM.CQO.cmatrix")
@@ -706,26 +754,26 @@ alt = valt.1iter(x=x, z=z, U=U, Blist=Blist, C=Cmat, nice31=nice31,
control=rrcontrol, lp.names=predictors.names,
MSratio=M/NOS)
-if(length(alt$offset))
+ if (length(alt$offset))
offset = alt$offset
B1.save = alt$B1 # Put later into extra
tmp.fitted = alt$fitted # contains \bI_{Rank} \bnu if Corner
-if(trace && control$OptimizeWrtC) {
+ if (trace && control$OptimizeWrtC) {
cat("\n")
- cat(which.optimizer, "using", if(is.R()) "optim():" else "nlminb():", "\n")
+ cat(which.optimizer, "using", if (is.R()) "optim():" else "nlminb():", "\n")
cat("Objective =", quasi.newton$value, "\n")
- cat("Parameters (= c(C)) = ", if(length(quasi.newton$par) < 5) "" else "\n")
- cat(if(is.R()) alt$Cmat else format(alt$Cmat), fill=TRUE)
+ cat("Parameters (= c(C)) = ", if (length(quasi.newton$par) < 5) "" else "\n")
+ cat( if (is.R()) alt$Cmat else format(alt$Cmat), fill=TRUE)
cat("\n")
- if(!is.R()) {
+ if (!is.R()) {
cat("Gradient norm =", format(quasi.newton$grad.norm), "\n")
cat("Number of gradient evaluations =", quasi.newton$g.evals, "\n")
}
- cat("Number of function evaluations =", if(is.R())
+ cat("Number of function evaluations =", if (is.R())
quasi.newton$count[1] else quasi.newton$f.evals, "\n")
- if(length(quasi.newton$message))
+ if (length(quasi.newton$message))
cat("Message =", quasi.newton$message, "\n")
cat("\n")
flush.console()
@@ -739,13 +787,14 @@ eval(cqo.end.expression) #
})
+
cqo.end.expression = expression({
rmfromVGAMenv(c("etamat"), prefix=".VGAM.CQO.")
- if(control$Quadratic) {
- if(!length(extra)) extra=list()
+ if (control$Quadratic) {
+ if (!length(extra)) extra=list()
extra$Amat = Amat # Not the latest iteration ??
extra$Cmat = Cmat # Saves the latest iteration
extra$Dmat = Dmat # Not the latest iteration
@@ -759,12 +808,12 @@ cqo.end.expression = expression({
eta <- fv + offset
mu <- family at inverse(eta, extra)
- if(any(is.na(mu)))
+ if (any(is.na(mu)))
warning("there are NAs in mu")
deriv.mu <- eval(family at deriv)
wz <- eval(family at weight)
- if(control$checkwz)
+ if (control$checkwz)
wz = checkwz(wz, M=M, trace=trace, wzeps=control$wzepsilon)
U <- vchol(wz, M=M, n=n, silent=!trace)
tvfor <- vforsub(U, as.matrix(deriv.mu), M=M, n=n)
@@ -774,15 +823,15 @@ cqo.end.expression = expression({
})
crow1C = function(cmat, crow1positive=rep(TRUE, len=ncol(cmat)), amat=NULL) {
- if(!is.logical(crow1positive) || length(crow1positive) != ncol(cmat))
+ if (!is.logical(crow1positive) || length(crow1positive) != ncol(cmat))
stop("bad input in crow1C")
for(LV in 1:ncol(cmat))
- if(( crow1positive[LV] && cmat[1,LV] < 0) ||
+ if (( crow1positive[LV] && cmat[1,LV] < 0) ||
(!crow1positive[LV] && cmat[1,LV] > 0)) {
cmat[,LV] = -cmat[,LV]
- if(length(amat)) amat[,LV] = -amat[,LV]
+ if (length(amat)) amat[,LV] = -amat[,LV]
}
- if(length(amat)) list(cmat=cmat, amat=amat) else cmat
+ if (length(amat)) list(cmat=cmat, amat=amat) else cmat
}
@@ -791,29 +840,29 @@ crow1C = function(cmat, crow1positive=rep(TRUE, len=ncol(cmat)), amat=NULL) {
printqrrvglm <- function(x, ...)
{
- if(!is.null(cl <- x at call)) {
+ if (!is.null(cl <- x at call)) {
cat("Call:\n")
dput(cl)
}
- if(FALSE) {
+ if (FALSE) {
}
- if(FALSE) {
- nobs <- if(length(x at df.total)) x at df.total else length(x at residuals)
+ 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))
+ if (!length(rdf))
rdf <- nobs - Rank
}
cat("\n")
- if(length(deviance(x)))
+ if (length(deviance(x)))
cat("Residual Deviance:", format(deviance(x)), "\n")
- if(length(x at criterion)) {
+ if (length(x at criterion)) {
ncrit <- names(x at criterion)
for(i in ncrit)
- if(i!="loglikelihood" && i!="deviance")
+ if (i != "loglikelihood" && i != "deviance")
cat(paste(i, ":", sep=""), format(x at criterion[[i]]), "\n")
}
@@ -828,7 +877,7 @@ setMethod("coef", "qrrvglm", function(object, ...)
setMethod("coefficients", "qrrvglm", function(object, ...)
Coef.qrrvglm(object, ...))
-if(!isGeneric("deviance"))
+if (!isGeneric("deviance"))
setGeneric("deviance", function(object, ...) standardGeneric("deviance"))
setMethod("deviance", "qrrvglm", function(object,...) object at criterion$deviance)
diff --git a/R/deviance.vlm.q b/R/deviance.vlm.q
index 67e3e9b..aaee232 100644
--- a/R/deviance.vlm.q
+++ b/R/deviance.vlm.q
@@ -1,5 +1,5 @@
# These functions are
-# Copyright (C) 1998-2009 T.W. Yee, University of Auckland. All rights reserved.
+# Copyright (C) 1998-2010 T.W. Yee, University of Auckland. All rights reserved.
@@ -41,7 +41,7 @@ if(is.R()) {
setMethod("df.residual", "vlm", function(object, ...)
df.residual.vlm(object, ...))
} else {
- if(!isGeneric("df.residual"))
+ if (!isGeneric("df.residual"))
setGeneric("df.residual", function(object, ...)
standardGeneric("df.residual"))
setMethod("df.residual", "vlm", function(object, ...)
diff --git a/R/effects.vglm.q b/R/effects.vglm.q
index cf930f8..da66875 100644
--- a/R/effects.vglm.q
+++ b/R/effects.vglm.q
@@ -1,5 +1,5 @@
# These functions are
-# Copyright (C) 1998-2009 T.W. Yee, University of Auckland. All rights reserved.
+# Copyright (C) 1998-2010 T.W. Yee, University of Auckland. All rights reserved.
diff --git a/R/family.aunivariate.q b/R/family.aunivariate.R
similarity index 86%
rename from R/family.aunivariate.q
rename to R/family.aunivariate.R
index dfb85dc..2fe3069 100644
--- a/R/family.aunivariate.q
+++ b/R/family.aunivariate.R
@@ -1,5 +1,5 @@
# These functions are
-# Copyright (C) 1998-2009 T.W. Yee, University of Auckland. All rights reserved.
+# Copyright (C) 1998-2010 T.W. Yee, University of Auckland. All rights reserved.
@@ -12,7 +12,7 @@
dkumar = function(x, shape1, shape2, log = FALSE) {
- if(!is.logical(log.arg <- log))
+ if (!is.logical(log.arg <- log))
stop("bad input for argument 'log'")
rm(log)
@@ -26,7 +26,7 @@ dkumar = function(x, shape1, shape2, log = FALSE) {
(shape2[xok]-1) * log1p(-x[xok]^shape1[xok])
logdensity[shape1 <= 0] = NaN
logdensity[shape2 <= 0] = NaN
- if(log.arg) logdensity else exp(logdensity)
+ if (log.arg) logdensity else exp(logdensity)
}
@@ -69,17 +69,17 @@ kumar.control <- function(save.weight=TRUE, ...)
ishape1=NULL, ishape2=NULL,
nsimEIM=500, zero=NULL)
{
- if(mode(lshape1) != "character" && mode(lshape1) != "name")
+ if (mode(lshape1) != "character" && mode(lshape1) != "name")
lshape1 = as.character(substitute(lshape1))
- if(mode(lshape2) != "character" && mode(lshape2) != "name")
+ if (mode(lshape2) != "character" && mode(lshape2) != "name")
lshape2 = as.character(substitute(lshape2))
- if(length(ishape1) && (!is.Numeric(ishape1, allow=1, positive=TRUE)))
+ if (length(ishape1) && (!is.Numeric(ishape1, allow=1, positive=TRUE)))
stop("bad input for argument 'ishape1'")
- if(length(ishape2) && !is.Numeric(ishape2))
+ if (length(ishape2) && !is.Numeric(ishape2))
stop("bad input for argument 'ishape2'")
- if(!is.list(eshape1)) eshape1 = list()
- if(!is.list(eshape2)) eshape2 = list()
- if(!is.Numeric(nsimEIM, allow=1, integ=TRUE) || nsimEIM <= 50)
+ if (!is.list(eshape1)) eshape1 = list()
+ if (!is.list(eshape2)) eshape2 = list()
+ if (!is.Numeric(nsimEIM, allow=1, integ=TRUE) || nsimEIM <= 50)
stop("'nsimEIM' should be an integer greater than 50")
new("vglmff",
@@ -93,28 +93,28 @@ kumar.control <- function(save.weight=TRUE, ...)
constraints = cm.zero.vgam(constraints, x, .zero, M)
}), list( .zero=zero ))),
initialize=eval(substitute(expression({
- if(ncol(y <- cbind(y)) != 1)
+ if (ncol(y <- cbind(y)) != 1)
stop("the response must be a vector or one-column matrix")
- if(any((y <= 0) | (y >=1)))
+ if (any((y <= 0) | (y >=1)))
stop("the response must be in (0,1)")
predictors.names = c(
namesof("shape1", .lshape1, earg= .eshape1, tag=FALSE),
namesof("shape2", .lshape2, earg= .eshape2, tag=FALSE))
- if(!length(etastart)) {
+ if (!length(etastart)) {
kumar.Loglikfun = function(shape1, y, x, w, extraargs) {
- if(any(round(w) != w)) warning("assuming w is integer-valued")
+ if (any(round(w) != w)) warning("assuming w is integer-valued")
medy = median(rep(y, w))
shape2 = log(0.5) / log1p(-(medy^shape1))
sum(w * (log(shape1) + log(shape2) + (shape1-1)*log(y) +
(shape2-1)*log1p(-y^shape1)))
}
shape1.grid = seq(0.4, 6.0, len=19)
- shape1.init = if(length( .ishape1 )) .ishape1 else
+ shape1.init = if (length( .ishape1 )) .ishape1 else
getMaxMin(shape1.grid, objfun=kumar.Loglikfun, y=y, x=x, w=w)
shape1.init = rep(shape1.init, length=length(y))
medy = median(rep(y, w))
- shape2.init = if(length( .ishape2 )) .ishape2 else
+ shape2.init = if (length( .ishape2 )) .ishape2 else
log(0.5) / log1p(-(medy^shape1.init))
shape2.init = rep(shape2.init, length=length(y))
etastart = cbind(theta2eta(shape1.init, .lshape1, earg= .eshape1),
@@ -140,7 +140,7 @@ kumar.control <- function(save.weight=TRUE, ...)
function(mu,y,w,residuals=FALSE,eta,extra=NULL) {
shape1 = eta2theta(eta[,1], link= .lshape1, earg= .eshape1)
shape2 = eta2theta(eta[,2], link= .lshape2, earg= .eshape2)
- if(residuals) stop("loglikelihood residuals not implemented yet") else {
+ if (residuals) stop("loglikelihood residuals not implemented yet") else {
sum(w * dkumar(x=y, shape1=shape1, shape2=shape2, log=TRUE))
}
}, list( .lshape1=lshape1, .lshape2=lshape2,
@@ -176,7 +176,7 @@ kumar.control <- function(save.weight=TRUE, ...)
temp3[,iam(1,2,M=M)] = d2l.dshape1shape2
run.mean = ((ii-1) * run.mean + temp3) / ii
}
- wz = if(intercept.only)
+ wz = if (intercept.only)
matrix(colMeans(run.mean), n, dimm(M), byrow=TRUE) else run.mean
dtheta.detas = cbind(dshape1.deta, dshape2.deta)
@@ -191,7 +191,7 @@ kumar.control <- function(save.weight=TRUE, ...)
drice = function(x, vee, sigma, log = FALSE) {
- if(!is.logical(log.arg <- log))
+ if (!is.logical(log.arg <- log))
stop("bad input for argument 'log'")
rm(log)
@@ -207,12 +207,12 @@ drice = function(x, vee, sigma, log = FALSE) {
log(besselI(x.abs, nu=0, expon.scaled = TRUE)) + x.abs
logdensity[sigma <= 0] = NaN
logdensity[vee < 0] = NaN
- if(log.arg) logdensity else exp(logdensity)
+ if (log.arg) logdensity else exp(logdensity)
}
rrice = function(n, vee, sigma) {
- if(!is.Numeric(n, integ=TRUE,allow=1)) stop("bad input for argument 'n'")
+ if (!is.Numeric(n, integ=TRUE,allow=1)) stop("bad input for argument 'n'")
theta = 1 # any number
X = rnorm(n, mean=vee * cos(theta), sd=sigma)
Y = rnorm(n, mean=vee * sin(theta), sd=sigma)
@@ -232,17 +232,17 @@ riceff.control <- function(save.weight=TRUE, ...)
ivee=NULL, isigma=NULL,
nsimEIM=100, zero=NULL)
{
- if(mode(lvee) != "character" && mode(lvee) != "name")
+ if (mode(lvee) != "character" && mode(lvee) != "name")
lvee = as.character(substitute(lvee))
- if(mode(lsigma) != "character" && mode(lsigma) != "name")
+ if (mode(lsigma) != "character" && mode(lsigma) != "name")
lsigma = as.character(substitute(lsigma))
- if(length(ivee) && !is.Numeric(ivee, positive=TRUE))
+ if (length(ivee) && !is.Numeric(ivee, positive=TRUE))
stop("bad input for argument 'ivee'")
- if(length(isigma) && !is.Numeric(isigma, positive=TRUE))
+ if (length(isigma) && !is.Numeric(isigma, positive=TRUE))
stop("bad input for argument 'isigma'")
- if(!is.list(evee)) evee = list()
- if(!is.list(esigma)) esigma = list()
- if(!is.Numeric(nsimEIM, allow=1, integ=TRUE) || nsimEIM <= 50)
+ if (!is.list(evee)) evee = list()
+ if (!is.list(esigma)) esigma = list()
+ if (!is.Numeric(nsimEIM, allow=1, integ=TRUE) || nsimEIM <= 50)
stop("'nsimEIM' should be an integer greater than 50")
new("vglmff",
@@ -257,14 +257,14 @@ riceff.control <- function(save.weight=TRUE, ...)
constraints = cm.zero.vgam(constraints, x, .zero, M)
}), list( .zero=zero ))),
initialize=eval(substitute(expression({
- if(ncol(y <- cbind(y)) != 1)
+ if (ncol(y <- cbind(y)) != 1)
stop("the response must be a vector or one-column matrix")
- if(any((y <= 0)))
+ if (any((y <= 0)))
stop("the response must be in (0,Inf)")
predictors.names = c(
namesof("vee", .lvee, earg= .evee, tag=FALSE),
namesof("sigma", .lsigma, earg= .esigma, tag=FALSE))
- if(!length(etastart)) {
+ if (!length(etastart)) {
riceff.Loglikfun = function(vee, y, x, w, extraargs) {
sigma.init = sd(rep(y, w))
sum(w * (log(y) - 2*log(sigma.init) +
@@ -273,10 +273,10 @@ riceff.control <- function(save.weight=TRUE, ...)
}
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
+ vee.init = if (length( .ivee )) .ivee else
getMaxMin(vee.grid, objfun=riceff.Loglikfun, y=y, x=x, w=w)
vee.init = rep(vee.init, length=length(y))
- sigma.init = if(length( .isigma )) .isigma else
+ sigma.init = if (length( .isigma )) .isigma else
sqrt(max((weighted.mean(y^2, w) - vee.init^2)/2, 0.001))
sigma.init = rep(sigma.init, length=length(y))
etastart = cbind(theta2eta(vee.init, .lvee, earg= .evee),
@@ -306,7 +306,7 @@ riceff.control <- function(save.weight=TRUE, ...)
function(mu,y,w,residuals=FALSE,eta,extra=NULL) {
vee = eta2theta(eta[,1], link= .lvee, earg= .evee)
sigma = eta2theta(eta[,2], link= .lsigma, earg= .esigma)
- if(residuals) stop("loglikelihood residuals not implemented yet") else {
+ if (residuals) stop("loglikelihood residuals not implemented yet") else {
sum(w * drice(x=y, vee=vee, sigma=sigma, log = TRUE))
}
}, list( .lvee=lvee, .lsigma=lsigma,
@@ -341,7 +341,7 @@ riceff.control <- function(save.weight=TRUE, ...)
run.var = ((ii-1) * run.var + temp3^2) / ii
run.cov = ((ii-1) * run.cov + temp3[,1] * temp3[,2]) / ii
}
- wz = if(intercept.only)
+ wz = if (intercept.only)
matrix(colMeans(cbind(run.var, run.cov)),
n, dimm(M), byrow=TRUE) else cbind(run.var, run.cov)
@@ -358,7 +358,7 @@ riceff.control <- function(save.weight=TRUE, ...)
dskellam = function(x, mu1, mu2, log=FALSE) {
log.arg = log; rm(log)
- if( !is.logical( log.arg ) || length( log.arg )!=1 )
+ if ( !is.logical( log.arg ) || length( log.arg )!=1 )
stop("bad input for 'log.arg'")
L = max(length(x), length(mu1), length(mu2))
@@ -367,7 +367,7 @@ dskellam = function(x, mu1, mu2, log=FALSE) {
ok3 <- (mu1 == 0) & (mu2 > 0)
ok4 <- (mu1 > 0) & (mu2 == 0)
ok5 <- (mu1 == 0) & (mu2 == 0)
- if(log.arg) {
+ if (log.arg) {
ans = -mu1 - mu2 + 2 * sqrt(mu1*mu2) +
0.5 * x * log(mu1) - 0.5 * x * log(mu2) +
log(besselI(2 * sqrt(mu1*mu2), nu=x, expon=TRUE))
@@ -409,17 +409,17 @@ skellam.control <- function(save.weight=TRUE, ...)
imu1=NULL, imu2=NULL,
nsimEIM=100, parallel=FALSE, zero=NULL)
{
- if(mode(lmu1) != "character" && mode(lmu1) != "name")
+ if (mode(lmu1) != "character" && mode(lmu1) != "name")
lmu1 = as.character(substitute(lmu1))
- if(mode(lmu2) != "character" && mode(lmu2) != "name")
+ if (mode(lmu2) != "character" && mode(lmu2) != "name")
lmu2 = as.character(substitute(lmu2))
- if(length(imu1) && !is.Numeric(imu1, positive=TRUE))
+ if (length(imu1) && !is.Numeric(imu1, positive=TRUE))
stop("bad input for argument 'imu1'")
- if(length(imu2) && !is.Numeric(imu2, positive=TRUE))
+ 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, allow=1, integ=TRUE) || nsimEIM <= 50)
+ if (!is.list(emu1)) emu1 = list()
+ if (!is.list(emu2)) emu2 = list()
+ if (!is.Numeric(nsimEIM, allow=1, integ=TRUE) || nsimEIM <= 50)
stop("'nsimEIM' should be an integer greater than 50")
new("vglmff",
@@ -435,14 +435,14 @@ skellam.control <- function(save.weight=TRUE, ...)
constraints = cm.zero.vgam(constraints, x, .zero, M)
}), list( .parallel=parallel, .zero=zero ))),
initialize=eval(substitute(expression({
- if(ncol(y <- cbind(y)) != 1)
+ if (ncol(y <- cbind(y)) != 1)
stop("the response must be a vector or one-column matrix")
- if(any((y != round(y))))
+ if (any((y != round(y))))
stop("the response should be integer-valued")
predictors.names = c(
namesof("mu1", .lmu1, earg= .emu1, tag=FALSE),
namesof("mu2", .lmu2, earg= .emu2, tag=FALSE))
- if(!length(etastart)) {
+ if (!length(etastart)) {
junk = lm.wfit(x=x, y=y, w=w)
var.y.est = sum(w * junk$resid^2) / junk$df.residual
mean.init = weighted.mean(y, w)
@@ -473,12 +473,12 @@ skellam.control <- function(save.weight=TRUE, ...)
function(mu,y,w,residuals=FALSE,eta,extra=NULL) {
mu1 = eta2theta(eta[,1], link= .lmu1, earg= .emu1)
mu2 = eta2theta(eta[,2], link= .lmu2, earg= .emu2)
- if(residuals) stop("loglikelihood residuals not implemented yet") else {
+ if (residuals) stop("loglikelihood residuals not implemented yet") else {
- if( is.logical( .parallel ) && length( .parallel )==1 &&
+ if ( is.logical( .parallel ) && length( .parallel )==1 &&
.parallel )
sum(w * log(besselI(2*mu1, nu=y, expon=TRUE))) else
sum(w * (-mu1 - mu2 +
@@ -522,7 +522,7 @@ skellam.control <- function(save.weight=TRUE, ...)
run.var = ((ii-1) * run.var + temp3^2) / ii
run.cov = ((ii-1) * run.cov + temp3[,1] * temp3[,2]) / ii
}
- wz = if(intercept.only)
+ wz = if (intercept.only)
matrix(colMeans(cbind(run.var, run.cov)),
n, dimm(M), byrow=TRUE) else cbind(run.var, run.cov)
@@ -540,9 +540,9 @@ skellam.control <- function(save.weight=TRUE, ...)
dyules = function(x, rho, log=FALSE) {
log.arg = log
rm(log)
- if( !is.logical( log.arg ) || length( log.arg )!=1 )
+ if ( !is.logical( log.arg ) || length( log.arg )!=1 )
stop("bad input for 'log.arg'")
- if( log.arg ) {
+ if ( log.arg ) {
ans = log(rho) + lbeta(abs(x), rho+1)
ans[(x != round(x)) | (x < 1)] = log(0)
} else {
@@ -555,7 +555,7 @@ dyules = function(x, rho, log=FALSE) {
ryules = function(n, rho) {
- if(!is.Numeric(n, integ=TRUE,allow=1)) stop("bad input for argument 'n'")
+ if (!is.Numeric(n, integ=TRUE,allow=1)) stop("bad input for argument 'n'")
rgeom(n, prob=exp(-rexp(n, rate=rho))) + 1
}
@@ -579,12 +579,12 @@ yulesimon.control <- function(save.weight=TRUE, ...)
yulesimon = function(link="loge", earg=list(), irho=NULL, nsimEIM=200)
{
- if(length(irho) && !is.Numeric(irho, positi=TRUE))
+ if (length(irho) && !is.Numeric(irho, positi=TRUE))
stop("argument 'irho' must be > 0")
- if(mode(link) != "character" && mode(link) != "name")
+ if (mode(link) != "character" && mode(link) != "name")
link = as.character(substitute(link))
- if(!is.list(earg)) earg = list()
- if(!is.Numeric(nsimEIM, allow=1, integ=TRUE) || nsimEIM <= 50)
+ if (!is.list(earg)) earg = list()
+ if (!is.Numeric(nsimEIM, allow=1, integ=TRUE) || nsimEIM <= 50)
stop("'nsimEIM' should be an integer greater than 50")
new("vglmff",
@@ -595,18 +595,18 @@ yulesimon.control <- function(save.weight=TRUE, ...)
"Variance: rho^2 / ((rho-1)^2 * (rho-2)), provided rho>2"),
initialize=eval(substitute(expression({
y = as.numeric(y)
- if(any(y < 1))
+ if (any(y < 1))
stop("all y values must be in 1,2,3,...")
- if(any(y != round(y )))
+ if (any(y != round(y )))
warning("y should be integer-valued")
- if(ncol(cbind(y)) != 1)
+ if (ncol(cbind(y)) != 1)
stop("response must be a vector or a one-column matrix")
predictors.names = namesof("rho", .link, earg=.earg, tag=FALSE)
- if(!length(etastart)) {
+ 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 ))),
@@ -625,7 +625,7 @@ yulesimon.control <- function(save.weight=TRUE, ...)
loglikelihood=eval(substitute(
function(mu,y,w,residuals= FALSE,eta, extra=NULL) {
rho = eta2theta(eta, .link, earg=.earg)
- if(residuals) stop("loglikelihood residuals not implemented yet") else {
+ if (residuals) stop("loglikelihood residuals not implemented yet") else {
sum(w * dyules(x=y, rho=rho, log=TRUE))
}
}, list( .link=link, .earg=earg ))),
@@ -645,7 +645,7 @@ yulesimon.control <- function(save.weight=TRUE, ...)
temp3 = dl.drho
run.var = ((ii-1) * run.var + temp3^2) / ii
}
- wz = if(intercept.only)
+ wz = if (intercept.only)
matrix(colMeans(cbind(run.var)),
n, dimm(M), byrow=TRUE) else cbind(run.var)
@@ -669,7 +669,7 @@ dslash <- function(x, mu=0, sigma=1, log=FALSE,
L = max(length(x), length(mu), length(sigma))
x = rep(x, len = L); mu = rep(mu, len = L); sigma = rep(sigma, len = L)
zedd = (x-mu)/sigma
- if(log.arg)
+ if (log.arg)
ifelse(abs(zedd)<smallno, -log(2*sigma*sqrt(2*pi)),
log1p(-exp(-zedd^2/2)) - log(sqrt(2*pi)*sigma*zedd^2)) else
ifelse(abs(zedd)<smallno, 1/(2*sigma*sqrt(2*pi)),
@@ -684,7 +684,7 @@ pslash <- function(q, mu=0, sigma=1){
ans = q * NA
for (ii in 1:L) {
temp = integrate(dslash, lower = -Inf, upper = q[ii])
- if(temp$message != "OK") {
+ if (temp$message != "OK") {
warning("integrate() failed")
} else
ans[ii] = temp$value
@@ -711,22 +711,22 @@ slash.control <- function(save.weight=TRUE, ...)
nsimEIM=250, zero=NULL,
smallno = .Machine$double.eps*1000)
{
- if(mode(lmu) != "character" && mode(lmu) != "name")
+ if (mode(lmu) != "character" && mode(lmu) != "name")
lmu = as.character(substitute(lmu))
- if(mode(lsigma) != "character" && mode(lsigma) != "name")
+ if (mode(lsigma) != "character" && mode(lsigma) != "name")
lsigma = as.character(substitute(lsigma))
- if(length(isigma) && !is.Numeric(isigma, posit=TRUE))
+ if (length(isigma) && !is.Numeric(isigma, posit=TRUE))
stop("'isigma' must be > 0")
- if(length(zero) && !is.Numeric(zero, integer=TRUE, posit=TRUE))
+ if (length(zero) && !is.Numeric(zero, integer=TRUE, posit=TRUE))
stop("bad input for argument 'zero'")
- if(!is.list(emu)) emu = list()
- if(!is.list(esigma)) esigma = list()
- if(!is.Numeric(nsimEIM, allow=1, integ=TRUE) || nsimEIM <= 50)
+ if (!is.list(emu)) emu = list()
+ if (!is.list(esigma)) esigma = list()
+ if (!is.Numeric(nsimEIM, allow=1, integ=TRUE) || nsimEIM <= 50)
stop("'nsimEIM' should be an integer greater than 50")
- if(!is.Numeric(iprobs, posit=TRUE) || max(iprobs) >= 1 ||
+ if (!is.Numeric(iprobs, posit=TRUE) || max(iprobs) >= 1 ||
length(iprobs)!=2)
stop("bad input for argument 'iprobs'")
- if(!is.Numeric(smallno, posit=TRUE) || smallno > 0.1)
+ if (!is.Numeric(smallno, posit=TRUE) || smallno > 0.1)
stop("bad input for argument 'smallno'")
new("vglmff",
@@ -743,15 +743,15 @@ slash.control <- function(save.weight=TRUE, ...)
constraints = cm.zero.vgam(constraints, x, .zero, M)
}), list( .zero=zero ))),
initialize=eval(substitute(expression({
- if(ncol(y <- cbind(y)) != 1)
+ if (ncol(y <- cbind(y)) != 1)
stop("the response must be a vector or one-column matrix")
predictors.names = c(
namesof("mu", .lmu, earg= .emu, tag=FALSE),
namesof("sigma", .lsigma, earg= .esigma, tag=FALSE))
- if(!length(etastart)) {
+ if (!length(etastart)) {
slash.Loglikfun = function(mu, y, x, w, extraargs) {
- sigma = if(is.Numeric(.isigma)) .isigma else
+ sigma = if (is.Numeric(.isigma)) .isigma else
max(0.01, ((quantile(rep(y,w), prob=0.75)/2)-mu)/qnorm(0.75))
zedd = (y-mu)/sigma
sum(w * ifelse(abs(zedd)<.smallno, -log(2*sigma*sqrt(2*pi)),
@@ -760,9 +760,9 @@ slash.control <- function(save.weight=TRUE, ...)
iprobs = .iprobs
mu.grid = quantile(rep(y,w), probs=iprobs)
mu.grid = seq(mu.grid[1], mu.grid[2], length=100)
- mu.init = if(length( .imu )) .imu else
+ mu.init = if (length( .imu )) .imu else
getMaxMin(mu.grid, objfun=slash.Loglikfun, y=y, x=x, w=w)
- sigma.init = if(is.Numeric(.isigma)) .isigma else
+ sigma.init = if (is.Numeric(.isigma)) .isigma else
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)
@@ -788,7 +788,7 @@ slash.control <- function(save.weight=TRUE, ...)
mu = eta2theta(eta[,1], link= .lmu, earg= .emu)
sigma = eta2theta(eta[,2], link= .lsigma, earg= .esigma)
zedd = (y-mu)/sigma
- if(residuals) stop("loglikelihood residuals not implemented yet") else {
+ if (residuals) stop("loglikelihood residuals not implemented yet") else {
sum(w * dslash(x=y, mu=mu, sigma=sigma, log=TRUE,
smallno= .smallno))
}
@@ -835,7 +835,7 @@ slash.control <- function(save.weight=TRUE, ...)
run.varcov = ((ii-1) * run.varcov +
temp3[,ind1$row.index]*temp3[,ind1$col.index]) / ii
}
- wz = if(intercept.only)
+ wz = if (intercept.only)
matrix(colMeans(run.varcov, na.rm=FALSE),
n, ncol(run.varcov), byrow=TRUE) else run.varcov
dthetas.detas = cbind(dmu.deta, dsigma.deta)
@@ -850,7 +850,7 @@ slash.control <- function(save.weight=TRUE, ...)
dnefghs = function(x, tau, log=FALSE) {
- if(!is.logical(log.arg <- log))
+ if (!is.logical(log.arg <- log))
stop("bad input for argument 'log'")
rm(log)
@@ -860,19 +860,19 @@ dnefghs = function(x, tau, log=FALSE) {
logdensity = log(sin(pi*tau)) + (1-tau)*x - log(pi) - log1p(exp(x))
logdensity[tau < 0] = NaN
logdensity[tau > 1] = NaN
- if(log.arg) logdensity else exp(logdensity)
+ if (log.arg) logdensity else exp(logdensity)
}
nefghs = function(link="logit", earg=list(), itau=NULL, method.init=1)
{
- if(length(itau) && !is.Numeric(itau, positi=TRUE) || any(itau >= 1))
+ if (length(itau) && !is.Numeric(itau, positi=TRUE) || any(itau >= 1))
stop("argument 'itau' must be in (0,1)")
- if(mode(link) != "character" && mode(link) != "name")
+ if (mode(link) != "character" && mode(link) != "name")
link = as.character(substitute(link))
- if(!is.list(earg)) earg = list()
- if(!is.Numeric(method.init, allow=1, integ=TRUE, posit=TRUE) ||
+ if (!is.list(earg)) earg = list()
+ if (!is.Numeric(method.init, allow=1, integ=TRUE, posit=TRUE) ||
method.init > 2)
stop("'method.init' must be 1 or 2")
@@ -884,18 +884,18 @@ dnefghs = function(x, tau, log=FALSE) {
namesof("tau", link, earg=earg), "\n\n",
"Mean: pi / tan(pi * tau)\n"),
initialize=eval(substitute(expression({
- if(ncol(cbind(y)) != 1)
+ if (ncol(cbind(y)) != 1)
stop("response must be a vector or a one-column matrix")
predictors.names = namesof("tau", .link, earg=.earg, tag=FALSE)
- if(!length(etastart)) {
- wmeany = if( .method.init == 1) weighted.mean(y,w) else
+ if (!length(etastart)) {
+ wmeany = if ( .method.init == 1) weighted.mean(y,w) else
median(rep(y,w))
- if(abs(wmeany) < 0.01) wmeany = 0.01
+ if (abs(wmeany) < 0.01) wmeany = 0.01
tau.init = atan(pi / wmeany) / pi + 0.5
tau.init[tau.init < 0.03] = 0.03
tau.init[tau.init > 0.97] = 0.97
- tau.init = rep( if(length( .itau )) .itau else tau.init, len=n)
+ tau.init = rep( if (length( .itau )) .itau else tau.init, len=n)
etastart = theta2eta(tau.init, .link, earg=.earg)
}
}), list( .link=link, .earg=earg, .itau=itau, .method.init=method.init ))),
@@ -912,7 +912,7 @@ dnefghs = function(x, tau, log=FALSE) {
loglikelihood=eval(substitute(
function(mu,y,w,residuals= FALSE,eta, extra=NULL) {
tau = eta2theta(eta, .link, earg=.earg)
- if(residuals) stop("loglikelihood residuals not implemented yet") else {
+ if (residuals) stop("loglikelihood residuals not implemented yet") else {
sum(w * dnefghs(x=y, tau=tau, log=TRUE))
}
}, list( .link=link, .earg=earg ))),
@@ -934,13 +934,13 @@ dnefghs = function(x, tau, log=FALSE) {
dlogF = function(x, shape1, shape2, log=FALSE) {
- if(!is.logical(log.arg <- log))
+ if (!is.logical(log.arg <- log))
stop("bad input for argument 'log'")
rm(log)
logdensity = -shape2*x - lbeta(shape1, shape2) -
(shape1 + shape2) * log1p(exp(-x))
- if(log.arg) logdensity else exp(logdensity)
+ if (log.arg) logdensity else exp(logdensity)
}
@@ -951,18 +951,18 @@ dlogF = function(x, shape1, shape2, log=FALSE) {
ishape1=NULL, ishape2=1,
method.init=1)
{
- if(length(ishape1) && !is.Numeric(ishape1, positi=TRUE))
+ if (length(ishape1) && !is.Numeric(ishape1, positi=TRUE))
stop("argument 'ishape1' must be positive")
- if( # length(ishape2) &&
+ if ( # length(ishape2) &&
!is.Numeric(ishape2, positi=TRUE))
stop("argument 'ishape2' must be positive")
- if(mode(lshape1) != "character" && mode(lshape1) != "name")
+ if (mode(lshape1) != "character" && mode(lshape1) != "name")
lshape1 = as.character(substitute(lshape1))
- if(mode(lshape2) != "character" && mode(lshape2) != "name")
+ if (mode(lshape2) != "character" && mode(lshape2) != "name")
lshape2 = as.character(substitute(lshape2))
- if(!is.list(eshape1)) eshape1 = list()
- if(!is.list(eshape2)) eshape2 = list()
- if(!is.Numeric(method.init, allow=1, integ=TRUE, posit=TRUE) ||
+ if (!is.list(eshape1)) eshape1 = list()
+ if (!is.list(eshape2)) eshape2 = list()
+ if (!is.Numeric(method.init, allow=1, integ=TRUE, posit=TRUE) ||
method.init > 2)
stop("'method.init' must be 1 or 2")
@@ -977,19 +977,19 @@ dlogF = function(x, shape1, shape2, log=FALSE) {
"\n\n",
"Mean: digamma(shape1) - digamma(shape2)"),
initialize=eval(substitute(expression({
- if(ncol(cbind(y)) != 1)
+ if (ncol(cbind(y)) != 1)
stop("response must be a vector or a one-column matrix")
predictors.names = c(
namesof("shape1", .lshape1, earg=.eshape1, tag=FALSE),
namesof("shape2", .lshape2, earg=.eshape2, tag=FALSE))
- if(!length(etastart)) {
- wmeany = if( .method.init == 1) weighted.mean(y,w) else
+ if (!length(etastart)) {
+ wmeany = if ( .method.init == 1) weighted.mean(y,w) else
median(rep(y,w))
shape1.init = shape2.init = rep( .ishape2, len=n)
- shape1.init = if(length( .ishape1)) rep( .ishape1, len=n) else {
+ shape1.init = if (length( .ishape1)) rep( .ishape1, len=n) else {
index1 = (y > wmeany)
shape1.init[index1] = shape2.init[index1] + 1/1
shape1.init[!index1] = shape2.init[!index1] - 1/1
@@ -1021,7 +1021,7 @@ dlogF = function(x, shape1, shape2, log=FALSE) {
function(mu,y,w,residuals= FALSE,eta, extra=NULL) {
shape1 = eta2theta(eta[,1], .lshape1, earg=.eshape1)
shape2 = eta2theta(eta[,2], .lshape2, earg=.eshape2)
- if(residuals) stop("loglikelihood residuals not implemented yet") else {
+ if (residuals) stop("loglikelihood residuals not implemented yet") else {
sum(w * dlogF(x=y, shape1=shape1, shape2=shape2, log=TRUE))
}
}, list( .lshape1=lshape1, .lshape2=lshape2,
@@ -1057,7 +1057,7 @@ dlogF = function(x, shape1, shape2, log=FALSE) {
dbenf = function(x, ndigits=1, log=FALSE) {
- if(!is.Numeric(ndigits, allow=1, posit=TRUE, integ=TRUE) || ndigits > 2)
+ if (!is.Numeric(ndigits, allow=1, posit=TRUE, integ=TRUE) || ndigits > 2)
stop("argument 'ndigits' must be 1 or 2")
lowerlimit = ifelse(ndigits==1, 1, 10)
upperlimit = ifelse(ndigits==1, 9, 99)
@@ -1068,17 +1068,17 @@ dbenf = function(x, ndigits=1, log=FALSE) {
ans[!is.na(x) & !is.nan(x) & ((x < lowerlimit) |
(x > upperlimit) |
(x != round(x)))] = 0.0
- if(log.arg) log(ans) else ans
+ if (log.arg) log(ans) else ans
}
rbenf = function(n, ndigits=1) {
- if(!is.Numeric(ndigits, allow=1, posit=TRUE, integ=TRUE) || ndigits > 2)
+ if (!is.Numeric(ndigits, allow=1, posit=TRUE, integ=TRUE) || ndigits > 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, integ=TRUE, allow=1, posit=TRUE))
+ use.n = if ((length.n <- length(n)) > 1) length.n else
+ if (!is.Numeric(n, integ=TRUE, allow=1, posit=TRUE))
stop("bad input for argument 'n'") else n
myrunif = runif(use.n)
ans = rep(lowerlimit, length = use.n)
@@ -1092,7 +1092,7 @@ rbenf = function(n, ndigits=1) {
pbenf = function(q, ndigits=1, log.p=FALSE) {
- if(!is.Numeric(ndigits, allow=1, posit=TRUE, integ=TRUE) || ndigits > 2)
+ if (!is.Numeric(ndigits, allow=1, posit=TRUE, integ=TRUE) || ndigits > 2)
stop("argument 'ndigits' must be 1 or 2")
lowerlimit = ifelse(ndigits==1, 1, 10)
upperlimit = ifelse(ndigits==1, 9, 99)
@@ -1102,19 +1102,19 @@ pbenf = function(q, ndigits=1, log.p=FALSE) {
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
+ if (log.p) log(ans) else ans
}
qbenf = function(p, ndigits=1) {
- if(!is.Numeric(ndigits, allow=1, posit=TRUE, integ=TRUE) || ndigits > 2)
+ if (!is.Numeric(ndigits, allow=1, posit=TRUE, integ=TRUE) || ndigits > 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))
- if(any(bad))
+ if (any(bad))
stop("bad input for 'p'")
ans = rep(lowerlimit, length = length(p))
diff --git a/R/family.basics.q b/R/family.basics.R
similarity index 75%
rename from R/family.basics.q
rename to R/family.basics.R
index 44830a6..dff753f 100644
--- a/R/family.basics.q
+++ b/R/family.basics.R
@@ -1,5 +1,5 @@
# These functions are
-# Copyright (C) 1998-2009 T.W. Yee, University of Auckland. All rights reserved.
+# Copyright (C) 1998-2010 T.W. Yee, University of Auckland. All rights reserved.
@@ -11,7 +11,7 @@ getind <- function(constraints, M, ncolx) {
- if(!length(constraints)) {
+ if (!length(constraints)) {
constraints = vector("list", ncolx)
for(ii in 1:ncolx)
@@ -27,7 +27,7 @@ getind <- function(constraints, M, ncolx) {
for(ii in 1:length(constraints)) {
temp <- constraints[[ii]]
isfox <- any(temp[kk,] != 0)
- if(isfox) {
+ if (isfox) {
ansx <- c(ansx, ii)
}
}
@@ -52,42 +52,42 @@ cm.vgam <- function(cm, x, bool, constraints,
nasgn <- names(asgn)
ninasgn <- nasgn[nasgn != "(Intercept)"]
- if(!length(constraints)) {
+ if (!length(constraints)) {
constraints <- vector("list", length(nasgn))
for(ii in 1:length(nasgn)) {
constraints[[ii]] <- diag(M)
}
names(constraints) <- nasgn
}
- if(!is.list(constraints))
+ if (!is.list(constraints))
stop("'constraints' must be a list")
- if(length(constraints) != length(nasgn) ||
+ if (length(constraints) != length(nasgn) ||
any(sort(names(constraints)) != sort(nasgn))) {
cat("names(constraints)\n")
cat("The above don't match;\n")
stop("'constraints' is half-pie")
}
- if(is.logical(bool)) {
- if(bool) {
- if(intercept.apply && any(nasgn=="(Intercept)"))
+ if (is.logical(bool)) {
+ if (bool) {
+ if (intercept.apply && any(nasgn=="(Intercept)"))
constraints[["(Intercept)"]] <- cm
- if(length(ninasgn))
+ if (length(ninasgn))
for(ii in ninasgn)
constraints[[ii]] <- cm
} else {
return(constraints)
}
} else {
- if(!is.R()) {
+ if (!is.R()) {
warn.save <- options()$warn
options(warn=-1)
tbool <- terms(bool) # Sqawks if FALSE or TRUE is response
options(warn=warn.save) # Restore the warnings
} else
tbool <- terms(bool)
- if(attr(tbool, "response")) {
+ if (attr(tbool, "response")) {
i <- attr(tbool, "factors")
default <- dimnames(i)[[1]]
default <- default[1]
@@ -97,13 +97,13 @@ cm.vgam <- function(cm, x, bool, constraints,
default <- TRUE
}
tl <- attr(tbool, "term.labels")
- if(attr(tbool, "intercept"))
+ if (attr(tbool, "intercept"))
tl <- c("(Intercept)", tl)
for(ii in nasgn) {
- if(default && any(tl == ii))
+ if (default && any(tl == ii))
constraints[[ii]] <- cm
- if(!default && !any(tl == ii))
+ if (!default && !any(tl == ii))
constraints[[ii]] <- cm
}
}
@@ -118,30 +118,30 @@ cm.nointercept.vgam <- function(constraints, x, nointercept, M)
asgn <- attr(x, "assign")
nasgn <- names(asgn)
- if(is.null(constraints)) {
+ if (is.null(constraints)) {
constraints <- vector("list", length(nasgn)) # list()
names(constraints) <- nasgn
}
- if(!is.list(constraints))
+ 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]]]))
+ constraints[[nasgn[ii]]] <- if (is.null(constraints[[nasgn[ii]]]))
diag(M) else eval(constraints[[nasgn[ii]]])
- if(is.null(nointercept))
+ if (is.null(nointercept))
return(constraints)
- if(!is.numeric(nointercept))
+ if (!is.numeric(nointercept))
stop("'nointercept' must be numeric")
nointercept <- unique(sort(nointercept))
- if(length(nointercept) == 0 || length(nointercept) >= M)
+ if (length(nointercept) == 0 || length(nointercept) >= M)
stop("too few or too many values")
- if(any(nointercept < 1 | nointercept > M))
+ if (any(nointercept < 1 | nointercept > M))
stop("'nointercept' out of range")
- if(nasgn[1] != "(Intercept)" || M == 1)
+ if (nasgn[1] != "(Intercept)" || M == 1)
stop("Need an (Intercept) constraint matrix with M>1")
- if(!all.equal(constraints[["(Intercept)"]], diag(M)))
+ if (!all.equal(constraints[["(Intercept)"]], diag(M)))
warning("Constraint matrix of (Intercept) not diagonal")
temp <- constraints[["(Intercept)"]]
@@ -157,33 +157,33 @@ cm.zero.vgam <- function(constraints, x, zero, M)
asgn <- attr(x, "assign")
nasgn <- names(asgn)
- if(is.null(constraints)) {
+ if (is.null(constraints)) {
constraints <- vector("list", length(nasgn)) # list()
names(constraints) <- nasgn
}
- if(!is.list(constraints)) stop("'constraints' must be a list")
+ 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]]]))
+ constraints[[nasgn[ii]]] <- if (is.null(constraints[[nasgn[ii]]]))
diag(M) else eval(constraints[[nasgn[ii]]])
- if(is.null(zero))
+ if (is.null(zero))
return(constraints)
- if(!is.numeric(zero)) stop("'zero' must be numeric")
- if(any(zero < 1 | zero > M))
+ if (!is.numeric(zero)) stop("'zero' must be numeric")
+ if (any(zero < 1 | zero > M))
stop("'zero' out of range")
- if(nasgn[1] != "(Intercept)")
+ if (nasgn[1] != "(Intercept)")
stop("cannot fit an intercept to a no-intercept model")
- if(2 <= length(constraints))
+ if (2 <= length(constraints))
for(ii in 2:length(constraints)) {
temp <- constraints[[nasgn[ii]]]
temp[zero,] <- 0
index <- NULL
for(kk in 1:ncol(temp))
- if(all(temp[,kk] == 0)) index <- c(index,kk)
- if(length(index) == ncol(temp))
+ if (all(temp[,kk] == 0)) index <- c(index,kk)
+ if (length(index) == ncol(temp))
stop("constraint matrix has no columns!")
- if(!is.null(index))
+ if (!is.null(index))
temp <- temp[,-index,drop=FALSE]
constraints[[nasgn[ii]]] <- temp
}
@@ -200,49 +200,49 @@ process.constraints <- function(constraints, x, M, by.col=TRUE, specialCM=NULL)
asgn <- attr(x, "assign")
nasgn <- names(asgn)
- if(is.null(constraints)) {
+ 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))
+ if (is.matrix(constraints))
constraints <- list(constraints)
- if(!is.list(constraints))
+ if (!is.list(constraints))
stop("'constraints' must be a list")
lenconstraints <- length(constraints)
- if(lenconstraints > 0)
+ if (lenconstraints > 0)
for(i in 1:lenconstraints) {
constraints[[i]] <- eval(constraints[[i]])
- if(!is.null(constraints[[i]]) && !is.matrix(constraints[[i]]))
+ if (!is.null(constraints[[i]]) && !is.matrix(constraints[[i]]))
stop("'constraints[[",i,"]]' is not a matrix")
}
- if(is.null(names(constraints)))
+ if (is.null(names(constraints)))
names(constraints) <- rep(nasgn, length=lenconstraints)
- temp <- if(!is.R()) list() else {
+ temp <- if (!is.R()) list() else {
junk <- vector("list", length(nasgn))
names(junk) <- nasgn
junk
}
for(i in 1:length(nasgn))
temp[[nasgn[i]]] <-
- if(is.null(constraints[[nasgn[i]]])) diag(M) else
+ if (is.null(constraints[[nasgn[i]]])) diag(M) else
eval(constraints[[nasgn[i]]])
for(i in 1:length(asgn)) {
- if(!is.matrix(temp[[i]])) {
+ if (!is.matrix(temp[[i]])) {
stop("not a constraint matrix")
}
- if(ncol(temp[[i]]) > M)
+ if (ncol(temp[[i]]) > M)
stop("constraint matrix has too many columns")
}
- if(!by.col)
+ if (!by.col)
return(temp)
constraints <- temp
@@ -252,7 +252,7 @@ process.constraints <- function(constraints, x, M, by.col=TRUE, specialCM=NULL)
ictr = 0
for(jay in cols) {
ictr = ictr + 1
- cm = if(is.list(specialCM) && any(nasgn[ii] == names(specialCM))) {
+ cm = if (is.list(specialCM) && any(nasgn[ii] == names(specialCM))) {
slist = specialCM[[(nasgn[ii])]]
slist[[ictr]]
} else constraints[[ii]]
@@ -269,14 +269,14 @@ process.constraints <- function(constraints, x, M, by.col=TRUE, specialCM=NULL)
trivial.constraints <- function(Blist, target=diag(M))
{
- if(is.null(Blist))
+ if (is.null(Blist))
return(1)
- if(is.matrix(Blist))
+ if (is.matrix(Blist))
Blist <- list(Blist)
M <- dim(Blist[[1]])[1]
- if(!is.matrix(target))
+ if (!is.matrix(target))
stop("target is not a matrix")
dimtar = dim(target)
@@ -284,14 +284,14 @@ trivial.constraints <- function(Blist, target=diag(M))
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)))
+ 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
+ if (trivc[ii] == 0) next
}
trivc
}
@@ -304,8 +304,8 @@ add.constraints <- function(constraints, new.constraints,
empty.list <- function(l)
(is.null(l) || (is.list(l) && length(l)==0))
- if(empty.list(constraints))
- if(is.list(new.constraints))
+ if (empty.list(constraints))
+ if (is.list(new.constraints))
return(new.constraints) else
return(list()) # Both NULL probably
@@ -314,26 +314,26 @@ add.constraints <- function(constraints, new.constraints,
nc <- names(constraints) # May be NULL
nn <- names(new.constraints) # May be NULL
- if(is.null(nc) || is.null(nn))
+ if (is.null(nc) || is.null(nn))
stop("lists must have names")
- if(any(nc=="") || any(nn==""))
+ if (any(nc=="") || any(nn==""))
stop("lists must have names")
- if(!empty.list(constraints) && !empty.list(new.constraints)) {
+ if (!empty.list(constraints) && !empty.list(new.constraints)) {
for(i in nn) {
- if(any(i==nc)) {
- if(check &&
+ if (any(i==nc)) {
+ if (check &&
(!(all(dim(constraints[[i]])==dim(new.constraints[[i]])) &&
all(constraints[[i]]==new.constraints[[i]]))))
stop("apparent contradiction in the specification ",
"of the constraints")
- if(overwrite)
+ if (overwrite)
constraints[[i]] <- new.constraints[[i]]
} else
constraints[[i]] <- new.constraints[[i]]
}
} else {
- if(!empty.list(constraints))
+ if (!empty.list(constraints))
return(as.list(constraints)) else
return(as.list(new.constraints))
}
@@ -351,24 +351,24 @@ add.constraints <- function(constraints, new.constraints,
iam <- function(j, k, M, hbw=M, both=FALSE, diagonal=TRUE)
{
- if(M==1)
- if(!diagonal) stop("cannot handle this")
+ if (M==1)
+ if (!diagonal) stop("cannot handle this")
- if(M==1)
- if(both) return(list(row.index=1, col.index=1)) else return(1)
+ if (M==1)
+ if (both) return(list(row.index=1, col.index=1)) else return(1)
- upper <- if(diagonal) M else M-1
+ upper <- if (diagonal) M else M-1
i2 <- as.list(upper:1)
i2 <- lapply(i2, seq)
i2 <- unlist(i2)
i1 <- matrix(1:M, M, M)
- i1 <- if(diagonal) c(i1[row(i1)>=col(i1)]) else c(i1[row(i1)>col(i1)])
+ i1 <- if (diagonal) c(i1[row(i1)>=col(i1)]) else c(i1[row(i1)>col(i1)])
- if(both) list(row.index=i2, col.index=i1) else {
- if(j > M || k > M || j < 1 || k < 1)
+ if (both) list(row.index=i2, col.index=i1) else {
+ if (j > M || k > M || j < 1 || k < 1)
stop("range error in j or k")
both <- (i1==j & i2==k) | (i1==k & i2==j)
(1:length(i2))[both]
@@ -381,10 +381,10 @@ dimm <- function(M, hbw=M)
{
- if(!is.numeric(hbw))
+ if (!is.numeric(hbw))
hbw <- M
- if(hbw > M || hbw < 1)
+ if (hbw > M || hbw < 1)
stop("range error in hbw")
hbw * (2*M - hbw +1) / 2
}
@@ -402,17 +402,17 @@ m2avglm <- function(object, upper=FALSE, allow.vector=FALSE) {
m2adefault <- function(m, M, upper=FALSE, allow.vector=FALSE)
{
- if(!is.numeric(m))
+ if (!is.numeric(m))
stop("argument 'm' is not numeric")
- if(!is.matrix(m))
+ 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))
+ if (dimm > length(index$row.index))
stop("bad value for M; it is too small")
- if(dimm < M) {
+ if (dimm < M) {
stop("bad value for M; it is too big")
}
@@ -434,9 +434,9 @@ a2m <- function(a, hbw=M)
- if(is.matrix(a) && ncol(a)==nrow(a))
+ if (is.matrix(a) && ncol(a)==nrow(a))
a <- array(a, c(nrow(a), ncol(a), 1))
- if(!is.array(a))
+ if (!is.array(a))
dim(a) <- c(1,1,length(a))
M <- dim(a)[1]
@@ -453,9 +453,9 @@ a2m <- function(a, hbw=M)
dim(fred$m) <- c(dimm.value,n)
fred$m <- t(fred$m)
- if(hbw != M)
+ if (hbw != M)
attr(fred$m, "hbw") <- hbw
- if(length(lpn <- dimnames(a)[[1]]) != 0)
+ if (length(lpn <- dimnames(a)[[1]]) != 0)
attr(fred$m, "predictors.names") <- lpn
fred$m
}
@@ -466,12 +466,12 @@ vindex <- function(M, row.arg=FALSE, col.arg=FALSE, length.arg=M*(M+1)/2)
- if((row.arg + col.arg) != 1)
+ if ((row.arg + col.arg) != 1)
stop("only one of row and col must be TRUE")
- if(M==1) {
+ if (M==1) {
ans <- 1
} else {
- if(row.arg) {
+ if (row.arg) {
i1 <- matrix(1:M, M, M)
ans <- c(i1[row(i1)+col(i1)<=(M+1)])
} else {
@@ -479,7 +479,7 @@ vindex <- function(M, row.arg=FALSE, col.arg=FALSE, length.arg=M*(M+1)/2)
ans <- c(i1[row(i1)>=col(i1)])
}
}
- if(length.arg>length(ans))
+ if (length.arg>length(ans))
stop("length argument too big")
rep(ans, len=length.arg)
}
@@ -496,72 +496,72 @@ wweights = function(object, matrix.arg=TRUE, deriv.arg=FALSE,
- if(length(wz <- object at weights) && !ignore.slot && !deriv.arg) {
+ if (length(wz <- object at weights) && !ignore.slot && !deriv.arg) {
return(wz)
}
M <- object at misc$M # Done below
n <- object at misc$n # Done below
- if(any(slotNames(object)=="extra")) {
+ if (any(slotNames(object)=="extra")) {
extra <- object at extra
- if(length(extra)==1 && !length(names(extra))) {
+ if (length(extra)==1 && !length(names(extra))) {
# Usage was something like vglm(..., extra = 5)
# so, internally, extra == 5 and not a list
extra <- extra[[1]]
}
}
mu <- object at fitted.values
- if(any(slotNames(object)=="predictors"))
+ if (any(slotNames(object)=="predictors"))
eta <- object at predictors
mt <- terms(object) # object at terms$terms; 11/8/03
Blist <- constraints <- object at constraints
new.coeffs <- object at coefficients
- if(any(slotNames(object)=="iter"))
+ if (any(slotNames(object)=="iter"))
iter <- object at iter
w <- rep(1, n)
- if(any(slotNames(object)=="prior.weights"))
+ if (any(slotNames(object)=="prior.weights"))
w <- object at prior.weights
- if(!length(w))
+ if (!length(w))
w <- rep(1, n)
x <- object at x
- if(!length(x))
+ if (!length(x))
x <- model.matrixvlm(object, type="lm")
y <- object at y
- if(any(slotNames(object)=="control"))
+ if (any(slotNames(object)=="control"))
for(i in names(object at control)) {
assign(i, object at control[[i]])
}
- if(length(object at misc))
+ if (length(object at misc))
for(i in names(object at misc)) {
assign(i, object at misc[[i]])
}
- if(any(slotNames(object)=="family")) {
+ if (any(slotNames(object)=="family")) {
expr <- object at family@deriv
deriv.mu <- eval(expr)
# Need to compute wz only if it couldn't be extracted from the object
- if(!length(wz)) {
+ if (!length(wz)) {
expr <- object at family@weight
wz <- eval(expr)
- if(M > 1)
+ if (M > 1)
dimnames(wz) = list(dimnames(wz)[[1]], NULL) # Remove colnames
- wz = if(matrix.arg) as.matrix(wz) else c(wz)
+ wz = if (matrix.arg) as.matrix(wz) else c(wz)
}
- if(deriv.arg) list(deriv=deriv.mu, weights=wz) else wz
+ if (deriv.arg) list(deriv=deriv.mu, weights=wz) else wz
} else NULL
}
pweights = function(object, ...) {
ans = object at prior.weights
- if(length(ans)) {
+ if (length(ans)) {
ans
} else {
temp = object at y
@@ -577,24 +577,24 @@ procVec = function(vec, yn, Default) {
- if(any(is.na(vec)))
+ if (any(is.na(vec)))
stop("vec cannot contain any NAs")
L = length(vec)
nvec <- names(vec) # vec[""] undefined
named = length(nvec) # FALSE for c(1,3)
- if(named) {
+ if (named) {
index = (1:L)[nvec==""]
- default = if(length(index)) vec[index] else Default
+ default = if (length(index)) vec[index] else Default
} else {
default = vec
}
answer = rep(default, len=length(yn)) # Recycling may be premature if named
names(answer) = yn
- if(named) {
+ if (named) {
nvec2 = nvec[nvec != ""]
- if(length(nvec2)) {
- if(any(!is.element(nvec2, yn)))
+ if (length(nvec2)) {
+ if (any(!is.element(nvec2, yn)))
stop("some names given which are superfluous")
answer = rep(as.numeric(NA), len=length(yn))
names(answer) = yn
@@ -608,8 +608,8 @@ procVec = function(vec, yn, Default) {
-if(FALSE) {
-if(!isGeneric("m2a"))
+if (FALSE) {
+if (!isGeneric("m2a"))
setGeneric("m2a", function(object, ...) standardGeneric("m2a"))
setMethod("m2a", "vglm",
@@ -629,18 +629,18 @@ 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")
+ if (mode(type) != "character" && mode(type) != "name")
type = as.character(substitute(type))
type = match.arg(type, c("prior", "working"))[1]
- if(type == "working") {
+ 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\"'")
+ if (deriv.arg) stop("cannot set 'deriv=TRUE' when 'type=\"prior\"'")
ans = pweights(object)
- if(matrix.arg) as.matrix(ans) else c(ans)
+ if (matrix.arg) as.matrix(ans) else c(ans)
}
}
@@ -659,7 +659,7 @@ setMethod("weights", "vglm",
dotFortran = function(name, ..., NAOK = FALSE, DUP = TRUE,
PACKAGE="VGAM") {
- if(is.R()) {
+ if (is.R()) {
.Fortran(name=name, ..., NAOK = NAOK, DUP = DUP, PACKAGE=PACKAGE)
} else {
stop()
@@ -667,7 +667,7 @@ dotFortran = function(name, ..., NAOK = FALSE, DUP = TRUE,
}
dotC = function(name, ..., NAOK = FALSE, DUP = TRUE, PACKAGE="VGAM") {
- if(is.R()) {
+ if (is.R()) {
.C(name=name, ..., NAOK = NAOK, DUP = DUP, PACKAGE=PACKAGE)
} else {
stop()
@@ -680,7 +680,7 @@ qnupdate = function(w, wzold, dderiv, deta, M, keeppd=TRUE,
trace=FALSE, reset=FALSE, effpos=.Machine$double.eps^0.75) {
- if(M ==1) {
+ if (M ==1) {
dderiv = cbind(dderiv)
deta = cbind(deta)
}
@@ -691,14 +691,14 @@ qnupdate = function(w, wzold, dderiv, deta, M, keeppd=TRUE,
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)) {
+ 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)
+ if (notupdated && trace)
cat(notupdated,"weight matrices not updated out of",length(sy),"\n")
} else {
warning("no BFGS quasi-Newton update made at all")
@@ -714,49 +714,53 @@ qnupdate = function(w, wzold, dderiv, deta, M, keeppd=TRUE,
mbesselI0 = function(x, deriv.arg=0) {
- if(!is.Numeric(deriv.arg, allow=1, integer=TRUE, positi=TRUE) && deriv.arg!=0)
+ if (!is.Numeric(deriv.arg, allow=1, integer=TRUE, positi=TRUE) && deriv.arg!=0)
stop("deriv.arg must be a single non-negative integer")
- if(!(deriv.arg==0 || deriv.arg==1 || deriv.arg==2))
+ if (!(deriv.arg==0 || deriv.arg==1 || deriv.arg==2))
stop("deriv must be 0, 1, or 2")
- if(!is.Numeric(x))
+ if (!is.Numeric(x))
stop("bad input for x")
n = length(x)
- if(FALSE) {
+ if (FALSE) {
}
# Use finite differences
ans = matrix(as.numeric(NA), nrow=n, ncol=deriv.arg+1)
ans[,1] = besselI(x, nu=0)
- if(deriv.arg>=1) ans[,2] = besselI(x, nu=1)
- if(deriv.arg>=2) ans[,3] = ans[,1] - ans[,2] / x
+ if (deriv.arg>=1) ans[,2] = besselI(x, nu=1)
+ if (deriv.arg>=2) ans[,3] = ans[,1] - ans[,2] / x
ans
}
VGAM.matrix.norm = function(A, power=2, suppressWarning=FALSE) {
- if((nrow(A) != ncol(A)) && !suppressWarning)
+ if ((nrow(A) != ncol(A)) && !suppressWarning)
warning("norms should be calculated for square matrices; A is not square")
- if(power=="F") {
+ if (power=="F") {
sqrt(sum(A^2))
- } else if(power==1) {
+ } else if (power==1) {
max(colSums(abs(A)))
- } else if(power==2) {
+ } else if (power==2) {
sqrt(max(eigen(t(A) %*% A)$value))
- } else if(!is.finite(power)) {
+ } else if (!is.finite(power)) {
max(colSums(abs(A)))
} else stop("argument 'power' not recognised")
}
+
+
+
+
rmfromVGAMenv = function(varnames, prefix="") {
evarnames = paste(prefix, varnames, sep="")
- if(is.R()) {
+ if (is.R()) {
for(i in evarnames) {
mytext1 = "exists(x=i, envir = VGAMenv)"
myexp1 = parse(text=mytext1)
is.there = eval(myexp1)
- if(is.there) {
+ if (is.there) {
rm(list=i, envir = VGAMenv)
}
}
@@ -772,7 +776,7 @@ rmfromVGAMenv = function(varnames, prefix="") {
existsinVGAMenv = function(varnames, prefix="") {
evarnames = paste(prefix, varnames, sep="")
ans = NULL
- if(is.R()) {
+ if (is.R()) {
for(i in evarnames) {
mytext1 = "exists(x=i, envir = VGAMenv)"
myexp1 = parse(text=mytext1)
@@ -791,7 +795,7 @@ existsinVGAMenv = function(varnames, prefix="") {
assign2VGAMenv = function(varnames, mylist, prefix="") {
evarnames = paste(prefix, varnames, sep="")
- if(is.R()) {
+ if (is.R()) {
for(i in 1:length(varnames)) {
assign(evarnames[i], mylist[[(varnames[i])]], envir = VGAMenv)
}
@@ -801,10 +805,13 @@ assign2VGAMenv = function(varnames, mylist, prefix="") {
}
+
+
+
getfromVGAMenv = function(varname, prefix="") {
varname = paste(prefix, varname, sep="")
- if(length(varname) > 1) stop("varname must be of length 1")
- if(is.R()) {
+ if (length(varname) > 1) stop("'varname' must be of length 1")
+ if (is.R()) {
get(varname, envir = VGAMenv)
} else {
get(varname)
@@ -813,13 +820,13 @@ getfromVGAMenv = function(varname, prefix="") {
lerch <- function(x, s, v, tolerance=1.0e-10, iter=100) {
- if(!is.Numeric(x) || !is.Numeric(s) || !is.Numeric(v))
+ if (!is.Numeric(x) || !is.Numeric(s) || !is.Numeric(v))
stop("bad input in x, s, and/or v")
- if(is.complex(c(x,s,v)))
+ if (is.complex(c(x,s,v)))
stop("complex arguments not allowed in x, s and v")
- if(!is.Numeric(tolerance, allow=1, posi=TRUE) || tolerance > 0.01)
+ if (!is.Numeric(tolerance, allow=1, posi=TRUE) || tolerance > 0.01)
stop("bad input for argument 'tolerance'")
- if(!is.Numeric(iter, allow=1, integ=TRUE, posi=TRUE))
+ if (!is.Numeric(iter, allow=1, integ=TRUE, posi=TRUE))
stop("bad input for argument 'iter'")
L = max(length(x), length(s), length(v))
x = rep(x, length=L); s = rep(s, length=L); v = rep(v, length=L);
diff --git a/R/family.binomial.q b/R/family.binomial.R
similarity index 81%
rename from R/family.binomial.q
rename to R/family.binomial.R
index 823e3da..5624d4e 100644
--- a/R/family.binomial.q
+++ b/R/family.binomial.R
@@ -1,5 +1,5 @@
# These functions are
-# Copyright (C) 1998-2009 T.W. Yee, University of Auckland. All rights reserved.
+# Copyright (C) 1998-2010 T.W. Yee, University of Auckland. All rights reserved.
@@ -13,11 +13,11 @@
process.binomial2.data.vgam <- expression({
- if(!is.matrix(y)) {
+ if (!is.matrix(y)) {
yf <- as.factor(y)
lev <- levels(yf)
llev <- length(lev)
- if(llev != 4)
+ if (llev != 4)
stop("response must have 4 levels")
nn <- length(yf)
y <- matrix(0, nn, llev)
@@ -25,8 +25,8 @@ process.binomial2.data.vgam <- expression({
colnamesy <- paste(lev, ":", c("00","01","10","11"), sep="")
dimnames(y) <- list(names(yf), colnamesy)
input.type <- 1
- } else if(ncol(y)==2) {
- if(!all(y==0 | y==1))
+ } else if (ncol(y)==2) {
+ if (!all(y==0 | y==1))
stop("response must contains 0's and 1's only")
col.index <- y[,2] + 2*y[,1] + 1 # 1:4
nn <- nrow(y)
@@ -34,7 +34,7 @@ process.binomial2.data.vgam <- expression({
y[cbind(1:nn,col.index)] <- 1
dimnames(y) <- list(dimnames(y)[[1]], c("00","01","10","11"))
input.type <- 2
- } else if(ncol(y)==4) {
+ } else if (ncol(y)==4) {
input.type <- 3
} else
stop("response unrecognized")
@@ -63,24 +63,24 @@ betabinomial.control <- function(save.weight=TRUE, ...)
betabinomial = function(lmu="logit", lrho="logit",
- emu=list(), erho=list(),
- irho=NULL, method.init=1,
- shrinkage.init=0.95, nsimEIM=NULL, zero=2)
+ emu=list(), erho=list(), irho=NULL,
+ method.init=1, shrinkage.init=0.95,
+ nsimEIM=NULL, zero=2)
{
- if(mode(lmu) != "character" && mode(lmu) != "name")
+ if (mode(lmu) != "character" && mode(lmu) != "name")
lmu = as.character(substitute(lmu))
- if(mode(lrho) != "character" && mode(lrho) != "name")
+ if (mode(lrho) != "character" && mode(lrho) != "name")
lrho = as.character(substitute(lrho))
- if(!is.list(emu )) emu = list()
- if(!is.list(erho)) erho = list()
- if(!is.Numeric(method.init, allow=1, integ=TRUE, posit=TRUE) ||
+ if (!is.list(emu )) emu = list()
+ if (!is.list(erho)) erho = list()
+ if (!is.Numeric(method.init, allow=1, integ=TRUE, posit=TRUE) ||
method.init > 4) stop("argument 'method.init' must be 1, 2, 3 or 4")
- if(!is.Numeric(shrinkage.init, allow=1) || shrinkage.init < 0 ||
+ if (!is.Numeric(shrinkage.init, allow=1) || shrinkage.init < 0 ||
shrinkage.init > 1) stop("bad input for argument 'shrinkage.init'")
- if(!is.null(nsimEIM)) {
- if(!is.Numeric(nsimEIM, allow=1, integ=TRUE))
+ if (!is.null(nsimEIM)) {
+ if (!is.Numeric(nsimEIM, allow=1, integ=TRUE))
stop("bad input for argument 'nsimEIM'")
- if(nsimEIM <= 10)
+ if (nsimEIM <= 10)
warning("'nsimEIM' should be an integer greater than 10, say")
}
@@ -95,31 +95,33 @@ betabinomial.control <- function(save.weight=TRUE, ...)
constraints <- cm.zero.vgam(constraints, x, .zero, M)
}), list( .zero=zero ))),
initialize=eval(substitute(expression({
- if(is.null( .nsimEIM)) {
+ if (is.null( .nsimEIM)) {
save.weight <- control$save.weight <- FALSE
}
eval(binomialff()@initialize) # Note: n,w,y,mustart is changed
ycounts = y * w # Convert proportions to counts
- if(max(abs(ycounts-round(ycounts))) > 1.0e-6)
- stop("the response (as counts) does not appear to be integer-valued")
+ if (max(abs(ycounts-round(ycounts))) > 1.0e-6)
+ warning("the response (as counts) does not appear to be integer-valued. ",
+ "Am rounding to integer values.")
+ ycounts = round(ycounts) # Make sure it is an integer
predictors.names = c(namesof("mu", .lmu, earg= .emu, tag=FALSE),
namesof("rho", .lrho, earg= .erho, tag=FALSE))
- if(!length(etastart)) {
+ if (!length(etastart)) {
betabinomial.Loglikfun = function(rhoval, y, x, w, extraargs) {
shape1 = extraargs$mustart*(1-rhoval)/rhoval
shape2 = (1-extraargs$mustart)*(1-rhoval)/rhoval
- ycounts = extraargs$ycounts
+ ycounts = extraargs$ycounts # Ought to be integer-valued
nvec = extraargs$nvec
sum(dbetabin.ab(x=ycounts, size=nvec, shape1=shape1,
shape2=shape2, log=TRUE))
}
rho.grid = rvar = seq(0.05, 0.95, len=21) #
- mustart.use = if( .method.init == 1) {
+ mustart.use = if ( .method.init == 1) {
rep(weighted.mean(y, w), len=n)
- } else if( .method.init == 2) {
+ } else if ( .method.init == 2) {
.sinit * weighted.mean(y, w) + (1- .sinit) * y
- } else if( .method.init == 3) {
+ } else if ( .method.init == 3) {
y.matrix = cbind(y)
mat.temp = matrix(colMeans(y.matrix), nrow(y.matrix),
ncol(y.matrix), byrow=TRUE)
@@ -131,7 +133,7 @@ betabinomial.control <- function(save.weight=TRUE, ...)
y=y, x=x, w=w, extraargs=list(
ycounts=ycounts, nvec=w,
mustart=mustart.use))
- init.rho = if(is.Numeric( .irho )) rep( .irho, length=n) else
+ init.rho = if (is.Numeric( .irho )) rep( .irho, length=n) else
rep(try.this, len=n)
}
etastart = cbind(theta2eta(mustart.use, .lmu, earg= .emu),
@@ -155,25 +157,30 @@ betabinomial.control <- function(save.weight=TRUE, ...)
loglikelihood=eval(substitute(
function(mu,y,w,residuals=FALSE, eta, extra=NULL) {
ycounts = y * w # Convert proportions to counts
- mymu = eta2theta(eta[,1], .lmu, earg= .emu)
+ mymu = eta2theta(eta[,1], .lmu, earg= .emu)
rho = eta2theta(eta[,2], .lrho, earg= .erho)
- smallno = 100 * .Machine$double.eps
+ smallno = 1.0e4 * .Machine$double.eps
+
+ if (max(abs(ycounts - round(y * w))) > smallno)
+ warning("converting 'ycounts' to integer in @loglikelihood")
+ ycounts = round(ycounts)
+
rho = pmax(rho, smallno)
rho = pmin(rho, 1-smallno)
shape1 = mymu * (1 - rho) / rho
shape2 = (1-mymu) * (1 - rho) / rho
nvec = w
- if(residuals) stop("loglikelihood residuals not implemented yet") else {
+ if (residuals) stop("loglikelihood residuals not implemented yet") else {
sum(dbetabin.ab(x=ycounts, size=nvec, shape1=shape1,
shape2=shape2, log=TRUE))
}
- }, list( .lmu=lmu,
- .emu=emu, .erho=erho,
- .lrho=lrho ))),
+ }, list( .lmu=lmu, .lrho=lrho,
+ .emu=emu, .erho=erho ))),
vfamily=c("betabinomial"),
deriv=eval(substitute(expression({
nvec = w # extra$nvec # for summary()
ycounts = y * w # Convert proportions to counts
+ ycounts = round(ycounts)
mymu = eta2theta(eta[,1], .lmu, earg= .emu)
rho = eta2theta(eta[,2], .lrho, earg= .erho)
smallno = 100 * .Machine$double.eps
@@ -196,11 +203,10 @@ betabinomial.control <- function(save.weight=TRUE, ...)
mymu * digamma(shape1) -
(1-mymu)*digamma(shape2) + digamma(shape1+shape2))
cbind(dl.dmu * dmu.deta, dl.drho * drho.deta)
- }), list( .lmu=lmu,
- .emu=emu, .erho=erho,
- .lrho=lrho ))),
+ }), list( .lmu=lmu, .lrho=lrho,
+ .emu=emu, .erho=erho ))),
weight=eval(substitute(expression({
- if(is.null( .nsimEIM)) {
+ if (is.null( .nsimEIM)) {
wz = matrix(as.numeric(NA), n, dimm(M)) #3=dimm(2)
wz11 = -(expected.betabin.ab(nvec, shape1, shape2, TRUE) -
trigamma(shape1+shape2+nvec) -
@@ -240,14 +246,15 @@ betabinomial.control <- function(save.weight=TRUE, ...)
run.varcov = ((ii-1) * run.varcov +
temp3[,ind1$row.index]*temp3[,ind1$col.index]) / ii
}
- wz = if(intercept.only)
+ wz = if (intercept.only)
matrix(colMeans(run.varcov),
n, ncol(run.varcov), byrow=TRUE) else run.varcov
wz = wz * dthetas.detas[,ind1$row] * dthetas.detas[,ind1$col]
wz
}
- }), list( .lmu=lmu, .emu=emu, .erho=erho, .lrho=lrho,
+ }), list( .lmu=lmu, .lrho=lrho,
+ .emu=emu, .erho=erho,
.nsimEIM = nsimEIM ))))
}
@@ -257,23 +264,23 @@ betabinomial.control <- function(save.weight=TRUE, ...)
dbinom2.or = function(mu1,
- mu2=if(exchangeable) mu1 else stop("'mu2' not specified"),
+ mu2 = if (exchangeable) mu1 else stop("'mu2' not specified"),
oratio=1,
exchangeable=FALSE,
tol=0.001,
colnames=c("00", "01", "10", "11"),
ErrorCheck=TRUE)
{
- if(ErrorCheck) {
- if(!is.Numeric(mu1, positive=TRUE) || max(mu1) >= 1)
+ 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)
+ if (!is.Numeric(mu2, positive=TRUE) || max(mu2) >= 1)
stop("bad input for argument 'mu2'")
- if(!is.Numeric(oratio, positive=TRUE))
+ if (!is.Numeric(oratio, positive=TRUE))
stop("bad input for argument 'oratio'")
- if(!is.Numeric(tol, positive=TRUE, allow=1) || tol > 0.1)
+ if (!is.Numeric(tol, positive=TRUE, allow=1) || tol > 0.1)
stop("bad input for argument 'tol'")
- if(exchangeable && max(abs(mu1 - mu2)) > 0.00001)
+ if (exchangeable && max(abs(mu1 - mu2)) > 0.00001)
stop("argument 'exchangeable' is TRUE but 'mu1' and 'mu2' differ")
}
@@ -296,33 +303,33 @@ dbinom2.or = function(mu1,
rbinom2.or = function(n, mu1,
- mu2=if(exchangeable) mu1 else stop("'mu2' not specified"),
+ mu2 = if (exchangeable) mu1 else stop("'mu2' not specified"),
oratio=1,
exchangeable=FALSE,
tol=0.001,
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=TRUE, posit=TRUE, allow=1))
+ if (ErrorCheck) {
+ if (!is.Numeric(n, integer=TRUE, posit=TRUE, allow=1))
stop("bad input for argument 'n'")
- if(!is.Numeric(mu1, positive=TRUE) || max(mu1) >= 1)
+ if (!is.Numeric(mu1, positive=TRUE) || max(mu1) >= 1)
stop("bad input for argument 'mu1'")
- if(!is.Numeric(mu2, positive=TRUE) || max(mu2) >= 1)
+ if (!is.Numeric(mu2, positive=TRUE) || max(mu2) >= 1)
stop("bad input for argument 'mu2'")
- if(!is.Numeric(oratio, positive=TRUE))
+ if (!is.Numeric(oratio, positive=TRUE))
stop("bad input for argument 'oratio'")
- if(!is.Numeric(tol, positive=TRUE, allow=1) || tol > 0.1)
+ if (!is.Numeric(tol, positive=TRUE, allow=1) || tol > 0.1)
stop("bad input for argument 'tol'")
- if(exchangeable && max(abs(mu1 - mu2)) > 0.00001)
+ if (exchangeable && max(abs(mu1 - mu2)) > 0.00001)
stop("argument 'exchangeable' is TRUE but 'mu1' and 'mu2' differ")
}
dmat = dbinom2.or(mu1=mu1, mu2=mu2, oratio=oratio, exchang=exchangeable,
tol=tol, ErrorCheck=ErrorCheck)
- answer = matrix(0, n, 2, dimnames=list(NULL, if(twoCols) colnames else NULL))
+ 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"]
@@ -332,7 +339,7 @@ rbinom2.or = function(n, mu1,
answer[index,1] = 1
index = (yy > cs2)
answer[index,] = 1
- if(twoCols) answer else {
+ 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
@@ -347,22 +354,22 @@ rbinom2.or = function(n, mu1,
imu1=NULL, imu2=NULL, ioratio = NULL,
zero=3, exchangeable=FALSE, tol=0.001, morerobust=FALSE)
{
- if(mode(lmu) != "character" && mode(lmu) != "name")
+ if (mode(lmu) != "character" && mode(lmu) != "name")
lmu = as.character(substitute(lmu))
- if(mode(lmu1) != "character" && mode(lmu1) != "name")
+ if (mode(lmu1) != "character" && mode(lmu1) != "name")
lmu1 = as.character(substitute(lmu1))
- if(mode(lmu2) != "character" && mode(lmu2) != "name")
+ if (mode(lmu2) != "character" && mode(lmu2) != "name")
lmu2 = as.character(substitute(lmu2))
- if(mode(loratio) != "character" && mode(loratio) != "name")
+ if (mode(loratio) != "character" && mode(loratio) != "name")
loratio = as.character(substitute(loratio))
- if(is.logical(exchangeable) && exchangeable && ((lmu1 != lmu2) ||
+ if (is.logical(exchangeable) && exchangeable && ((lmu1 != lmu2) ||
!all.equal(emu1, emu2)))
stop("exchangeable=TRUE but marginal links are not equal")
- if(!is.Numeric(tol, positive=TRUE, allow=1) || tol > 0.1)
+ if (!is.Numeric(tol, positive=TRUE, allow=1) || tol > 0.1)
stop("bad input for argument 'tol'")
- if(!is.list(emu1)) emu1 = list()
- if(!is.list(emu2)) emu2 = list()
- if(!is.list(eoratio)) eoratio = list()
+ 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",
@@ -383,12 +390,12 @@ rbinom2.or = function(n, mu1,
namesof("mu2", .lmu2, earg= .emu2, short=TRUE),
namesof("oratio", .loratio, earg= .eoratio, short=TRUE))
- if(!length(etastart)) {
+ if (!length(etastart)) {
pmargin = cbind(mu[,3]+mu[,4], mu[,2]+mu[,4])
- ioratio = if(length( .ioratio)) rep( .ioratio, len=n) else
+ ioratio = if (length( .ioratio)) rep( .ioratio, len=n) else
mu[,4]*mu[,1]/(mu[,2]*mu[,3])
- if(length( .imu1)) pmargin[,1] = .imu1
- if(length( .imu2)) pmargin[,2] = .imu2
+ 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))
@@ -430,8 +437,8 @@ rbinom2.or = function(n, mu1,
.loratio=loratio ))),
loglikelihood=eval(substitute(
function(mu, y, w, residuals = FALSE, eta, extra=NULL) {
- if(residuals) stop("loglikelihood residuals not implemented yet") else {
- if( .morerobust) {
+ if (residuals) stop("loglikelihood residuals not implemented yet") else {
+ if ( .morerobust) {
vsmallno = 1.0e4 * .Machine$double.xmin
mu[mu < vsmallno] = vsmallno
}
@@ -498,20 +505,20 @@ rbinom2.or = function(n, mu1,
dbinom2.rho = function(mu1,
- mu2=if(exchangeable) mu1 else stop("'mu2' not specified"),
+ mu2 = if (exchangeable) mu1 else stop("'mu2' not specified"),
rho=0,
exchangeable=FALSE,
colnames=c("00", "01", "10", "11"),
ErrorCheck=TRUE)
{
- if(ErrorCheck) {
- if(!is.Numeric(mu1, positive=TRUE) || max(mu1) >= 1)
+ 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)
+ 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)
+ if (!is.Numeric(rho) || min(rho) <= -1 || max(rho) >= 1)
stop("bad input for argument 'rho'")
- if(exchangeable && max(abs(mu1 - mu2)) > 0.00001)
+ if (exchangeable && max(abs(mu1 - mu2)) > 0.00001)
stop("argument 'exchangeable' is TRUE but 'mu1' and 'mu2' differ")
}
@@ -531,30 +538,30 @@ dbinom2.rho = function(mu1,
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=TRUE, posit=TRUE, allow=1))
+ if (ErrorCheck) {
+ if (!is.Numeric(n, integer=TRUE, posit=TRUE, allow=1))
stop("bad input for argument 'n'")
- if(!is.Numeric(mu1, positive=TRUE) || max(mu1) >= 1)
+ if (!is.Numeric(mu1, positive=TRUE) || max(mu1) >= 1)
stop("bad input for argument 'mu1'")
- if(!is.Numeric(mu2, positive=TRUE) || max(mu2) >= 1)
+ 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)
+ if (!is.Numeric(rho) || min(rho) <= -1 || max(rho) >= 1)
stop("bad input for argument 'rho'")
- if(exchangeable && max(abs(mu1 - mu2)) > 0.00001)
+ 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, exchang=exchangeable,
ErrorCheck=ErrorCheck)
- answer = matrix(0, n, 2, dimnames=list(NULL, if(twoCols) colnames else NULL))
+ 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"]
@@ -564,7 +571,7 @@ rbinom2.rho = function(n, mu1,
answer[index,1] = 1
index = (yy > cs2)
answer[index,] = 1
- if(twoCols) answer else {
+ 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
@@ -586,15 +593,15 @@ binom2.rho.control <- function(save.weight=TRUE, ...)
zero=3, exchangeable=FALSE, nsimEIM=NULL)
{
- if(mode(lrho) != "character" && mode(lrho) != "name")
+ if (mode(lrho) != "character" && mode(lrho) != "name")
lrho = as.character(substitute(lrho))
- if(!is.list(erho)) erho = list()
+ if (!is.list(erho)) erho = list()
lmu12 = "probit"
emu12 = list()
- if(is.Numeric(nsimEIM)) {
- if(!is.Numeric(nsimEIM, allow=1, integ=TRUE))
+ if (is.Numeric(nsimEIM)) {
+ if (!is.Numeric(nsimEIM, allow=1, integ=TRUE))
stop("bad input for argument 'nsimEIM'")
- if(nsimEIM <= 100)
+ if (nsimEIM <= 100)
warning("'nsimEIM' should be an integer greater than 100")
}
@@ -617,13 +624,13 @@ binom2.rho.control <- function(save.weight=TRUE, ...)
namesof("mu2", .lmu12, earg= .emu12, short=TRUE),
namesof("rho", .lrho, earg= .erho, short=TRUE))
- if(is.null( .nsimEIM)) {
+ if (is.null( .nsimEIM)) {
save.weight <- control$save.weight <- FALSE
}
- if(is.null(etastart)) {
- mu1.init= if(is.Numeric(.imu1)) rep(.imu1, len=n) else mu[,3]+mu[,4]
- mu2.init= if(is.Numeric(.imu2)) rep(.imu2, len=n) else mu[,2]+mu[,4]
- rho.init = if(is.Numeric(.init.rho)) rep( .init.rho, len=n) else {
+ if (is.null(etastart)) {
+ mu1.init= if (is.Numeric(.imu1)) rep(.imu1, len=n) else mu[,3]+mu[,4]
+ mu2.init= if (is.Numeric(.imu2)) rep(.imu2, len=n) else mu[,2]+mu[,4]
+ rho.init = if (is.Numeric(.init.rho)) rep( .init.rho, len=n) else {
temp4 = oratio = mu[,1] * mu[,4] / (mu[,2] * mu[,3])
temp4[oratio <= 0.1] = -0.6
temp4[oratio > 0.1] = -0.4
@@ -661,7 +668,7 @@ binom2.rho.control <- function(save.weight=TRUE, ...)
.nsimEIM=nsimEIM ))),
loglikelihood=eval(substitute(
function(mu, y, w, residuals = FALSE, eta, extra=NULL) {
- if(residuals) stop("loglikelihood residuals not implemented yet") else {
+ if (residuals) stop("loglikelihood residuals not implemented yet") else {
sum(dmultinomial(x=w*y, size=w, prob=mu, log=TRUE, docheck=FALSE))
}
}, list( .erho=erho ))),
@@ -699,7 +706,7 @@ binom2.rho.control <- function(save.weight=TRUE, ...)
w * cbind(dl.dprob1, dl.dprob2, dl.drho) * dthetas.detas
}), list( .lmu12=lmu12, .emu12=emu12, .lrho=lrho, .erho=erho ))),
weight=eval(substitute(expression({
- if(is.null( .nsimEIM)) {
+ if (is.null( .nsimEIM)) {
d2l.dprob1prob1 = PhiB^2 *(1/p11+1/p01) + onemPhiB^2 *(1/p10+1/p00)
d2l.dprob2prob2 = PhiA^2 *(1/p11+1/p10) + onemPhiA^2 *(1/p01+1/p00)
d2l.dprob1prob2 = PhiA * (PhiB/p11 - onemPhiB/p10) +
@@ -734,7 +741,7 @@ binom2.rho.control <- function(save.weight=TRUE, ...)
run.varcov = ((ii-1) * run.varcov +
temp3[,ind1$row.index] * temp3[,ind1$col.index]) / ii
}
- wz = if(intercept.only)
+ wz = if (intercept.only)
matrix(colMeans(run.varcov),
n, ncol(run.varcov), byrow=TRUE) else run.varcov
@@ -778,10 +785,10 @@ my.dbinom <- function(x,
size.binomial <- function(prob=0.5, link="loge", earg=list())
{
- if(any(prob<=0 || prob>=1))
+ if (any(prob<=0 || prob>=1))
stop("some values of prob out of range")
- if(!missing(link)) link <- as.character(substitute(link))
- if(!is.list(earg)) earg = list()
+ if (!missing(link)) link <- as.character(substitute(link))
+ if (!is.list(earg)) earg = list()
new("vglmff",
blurb=c("Binomial with n unknown, prob known (prob=",prob,")\n",
@@ -793,7 +800,7 @@ size.binomial <- function(prob=0.5, link="loge", earg=list())
initialize=eval(substitute(expression({
predictors.names <- "size"
extra$temp2 <- rep( .prob , length=n)
- if(is.null(etastart)) {
+ if (is.null(etastart)) {
nvec <- (y+0.1)/extra$temp2
etastart <- theta2eta(nvec, .link)
}
@@ -813,7 +820,7 @@ size.binomial <- function(prob=0.5, link="loge", earg=list())
loglikelihood=eval(substitute(
function(mu, y, w, res=FALSE,eta, extra=NULL) {
nvec <- mu/extra$temp2
- if(residuals) stop("loglikelihood residuals not implemented yet") else {
+ if (residuals) stop("loglikelihood residuals not implemented yet") else {
sum(w * (lgamma(nvec+1) - lgamma(y+1) - lgamma(nvec-y+1) +
y * log(.prob / (1- .prob)) + nvec * log1p(- .prob)))
@@ -841,20 +848,24 @@ size.binomial <- function(prob=0.5, link="loge", earg=list())
dbetabin.ab = function(x, size, shape1, shape2, log = FALSE) {
log.arg = log
rm(log)
- if(!is.Numeric(x)) stop("bad input for argument 'x'")
- if(!is.Numeric(size, posit=TRUE, integer=TRUE))
+ if (!is.Numeric(x)) stop("bad input for argument 'x'")
+ if (!is.Numeric(size, posit=TRUE, integer=TRUE))
stop("bad input for argument 'size'")
- if(!is.Numeric(shape1, pos=TRUE)) stop("bad input for argument 'shape1'")
- if(!is.Numeric(shape2, pos=TRUE)) stop("bad input for argument 'shape2'")
- L = max(length(x), length(size), length(shape1), length(shape2))
- x = rep(x, len=L); size = rep(size, len=L);
- shape1 = rep(shape1, len=L); shape2 = rep(shape2, len=L);
+ if (!is.Numeric(shape1, pos=TRUE)) stop("bad input for argument 'shape1'")
+ if (!is.Numeric(shape2, pos=TRUE)) stop("bad input for argument 'shape2'")
+
+ LLL = max(length(x), length(size), length(shape1), length(shape2))
+ if (length(x) != LLL) x = rep(x, len=LLL)
+ if (length(size) != LLL) size = rep(size, len=LLL)
+ if (length(shape1) != LLL) shape1 = rep(shape1, len=LLL)
+ if (length(shape2) != LLL) shape2 = rep(shape2, len=LLL)
+
answer = 0 * x
- ok <- round(x) == x & x >= 0 & x <= size
+ ok <- (round(x) == x) & (x >= 0) & (x <= size)
answer[ok] = lchoose(size[ok], x[ok]) +
lbeta(shape1[ok]+x[ok], shape2[ok]+size[ok]-x[ok]) -
lbeta(shape1[ok], shape2[ok])
- if(log.arg) {
+ if (log.arg) {
answer[!ok] = log(0.0)
} else {
answer[ok] = exp(answer[ok])
@@ -864,44 +875,54 @@ dbetabin.ab = function(x, size, shape1, shape2, log = FALSE) {
pbetabin.ab = function(q, size, shape1, shape2, log.p=FALSE) {
- if(!is.Numeric(q)) stop("bad input for argument 'q'")
- if(!is.Numeric(size, posit=TRUE, integer=TRUE))
+ if (!is.Numeric(q)) stop("bad input for argument 'q'")
+ if (!is.Numeric(size, posit=TRUE, integer=TRUE))
stop("bad input for argument 'size'")
- if(!is.Numeric(shape1, pos=TRUE)) stop("bad input for argument 'shape1'")
- if(!is.Numeric(shape2, pos=TRUE)) stop("bad input for argument 'shape2'")
- N = max(length(q), length(size), length(shape1), length(shape2))
- q = rep(q, len=N); shape1 = rep(shape1, len=N); shape2 = rep(shape2, len=N)
- size = rep(size, len=N);
+ if (!is.Numeric(shape1, pos=TRUE)) stop("bad input for argument 'shape1'")
+ if (!is.Numeric(shape2, pos=TRUE)) stop("bad input for argument 'shape2'")
+ LLL = max(length(q), length(size), length(shape1), length(shape2))
+
+ 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(size) != LLL) size = rep(size, len=LLL);
+
ans = q * 0 # Retains names(q)
- if(max(abs(size-size[1])) < 1.0e-08 &&
+ if (max(abs(size-size[1])) < 1.0e-08 &&
max(abs(shape1-shape1[1])) < 1.0e-08 &&
max(abs(shape2-shape2[1])) < 1.0e-08) {
qstar = floor(q)
- temp = if(max(qstar) >= 0) dbetabin.ab(0:max(qstar),
+ temp = if (max(qstar) >= 0) dbetabin.ab(0:max(qstar),
size=size[1], shape1=shape1[1], shape2=shape2[1]) else 0*qstar
unq = unique(qstar)
for(ii in unq) {
index = qstar == ii
- ans[index] = if(ii >= 0) sum(temp[1:(1+ii)]) else 0
+ ans[index] = if (ii >= 0) sum(temp[1:(1+ii)]) else 0
}
} else
- for(ii in 1:N) {
+ for(ii in 1:LLL) {
qstar = floor(q[ii])
- ans[ii] = if(qstar >= 0) sum(dbetabin.ab(x=0:qstar, size=size[ii],
+ ans[ii] = if (qstar >= 0) sum(dbetabin.ab(x=0:qstar, size=size[ii],
shape1=shape1[ii], shape2=shape2[ii])) else 0
}
- if(log.p) log(ans) else ans
+ if (log.p) log(ans) else ans
}
+
+
rbetabin.ab = function(n, size, shape1, shape2) {
- if(!is.Numeric(n,integ=TRUE, allow=1)) stop("bad input for argument 'n'")
- if(!is.Numeric(size, posit=TRUE, integer=TRUE))
+ if (!is.Numeric(size, posit=TRUE, integer=TRUE))
stop("bad input for argument 'size'")
- if(!is.Numeric(shape1, pos=TRUE)) stop("bad input for argument 'shape1'")
- if(!is.Numeric(shape2, pos=TRUE)) stop("bad input for argument 'shape2'")
- size = rep(size, len=n);
- shape1 = rep(shape1, len=n); shape2 = rep(shape2, len=n);
- rbinom(n=n, size=size, prob=rbeta(n=n, shape1=shape1, shape2=shape2))
+ if (!is.Numeric(shape1, pos=TRUE)) stop("bad input for argument 'shape1'")
+ if (!is.Numeric(shape2, pos=TRUE)) stop("bad input for argument 'shape2'")
+
+ use.n = if ((length.n <- length(n)) > 1) length.n else
+ if (!is.Numeric(n, integ=TRUE, allow=1, posit=TRUE))
+ stop("bad input for argument 'n'") else n
+ if (length(size) != use.n) size = rep(size, len=use.n)
+ if (length(shape1) != use.n) shape1 = rep(shape1, len=use.n)
+ if (length(shape2) != use.n) shape2 = rep(shape2, len=use.n)
+ rbinom(n=use.n, size=size, prob=rbeta(n=n, shape1=shape1, shape2=shape2))
}
@@ -910,7 +931,7 @@ dbetabin = function(x, size, prob, rho, log = FALSE) {
shape2=(1-prob)*(1-rho)/rho, log=log)
}
-pbetabin = function(q, size, prob, rho, log.p=FALSE) {
+pbetabin = function(q, size, prob, rho, log.p = FALSE) {
pbetabin.ab(q=q, size=size, shape1=prob*(1-rho)/rho,
shape2=(1-prob)*(1-rho)/rho, log.p=log.p)
}
@@ -923,10 +944,10 @@ rbetabin = function(n, size, prob, rho) {
expected.betabin.ab = function(nvec, shape1, shape2, first) {
- N = length(nvec)
- ans = rep(0.0, len=N)
- if(first) {
- for(ii in 1:N) {
+ NN = length(nvec)
+ ans = rep(0.0, len=NN)
+ if (first) {
+ for(ii in 1:NN) {
temp639 = lbeta(shape1[ii], shape2[ii])
yy = 0:nvec[ii]
ans[ii] = ans[ii] + sum(trigamma(shape1[ii]+yy) *
@@ -934,7 +955,7 @@ rbetabin = function(n, size, prob, rho) {
lbeta(shape1[ii]+yy, shape2[ii]+nvec[ii]-yy) - temp639))
}
} else {
- for(ii in 1:N) {
+ for(ii in 1:NN) {
temp639 = lbeta(shape1[ii], shape2[ii])
yy = 0:nvec[ii]
ans[ii] = ans[ii] + sum(trigamma(nvec[ii]+shape2[ii]-yy) *
@@ -956,20 +977,21 @@ betabin.ab.control <- function(save.weight=TRUE, ...)
betabin.ab = function(lshape12="loge", earg = list(),
i1=1, i2=NULL, method.init=1,
shrinkage.init=0.95, nsimEIM=NULL, zero=NULL) {
- if(mode(lshape12) != "character" && mode(lshape12) != "name")
+ if (mode(lshape12) != "character" && mode(lshape12) != "name")
lshape12 = as.character(substitute(lshape12))
- if(!is.Numeric(i1, positive=TRUE)) stop("bad input for argument 'i1'")
- if(length(i2) && !is.Numeric(i2, pos=TRUE))
+ if (!is.Numeric(i1, positive=TRUE)) stop("bad input for argument 'i1'")
+ if (length(i2) && !is.Numeric(i2, pos=TRUE))
stop("bad input for argument 'i2'")
- if(!is.list(earg)) earg = list()
- if(!is.null(nsimEIM)) {
- if(!is.Numeric(nsimEIM, allow=1, integ=TRUE))
+ if (!is.list(earg)) earg = list()
+ if (!is.null(nsimEIM)) {
+ if (!is.Numeric(nsimEIM, allow=1, integ=TRUE))
stop("bad input for argument 'nsimEIM'")
- if(nsimEIM <= 10)
+ if (nsimEIM <= 10)
warning("'nsimEIM' should be an integer greater than 10, say")
}
- if(!is.Numeric(method.init, allow=1, integ=TRUE, posit=TRUE) ||
- method.init > 3) stop("argument 'method.init' must be 1, 2 or 3")
+ if (!is.Numeric(method.init, allow=1, integ=TRUE, posit=TRUE) ||
+ method.init > 3)
+ stop("argument 'method.init' must be 1, 2 or 3")
new("vglmff",
blurb=c("Beta-binomial model\n",
@@ -982,7 +1004,7 @@ betabin.ab.control <- function(save.weight=TRUE, ...)
constraints <- cm.zero.vgam(constraints, x, .zero, M)
}), list( .zero=zero ))),
initialize=eval(substitute(expression({
- if(is.null( .nsimEIM)) {
+ if (is.null( .nsimEIM)) {
save.weight <- control$save.weight <- FALSE
}
@@ -991,21 +1013,22 @@ betabin.ab.control <- function(save.weight=TRUE, ...)
predictors.names=c(namesof("shape1", .lshape12, earg= .earg, tag=FALSE),
namesof("shape2", .lshape12, earg= .earg, tag=FALSE))
- if(!length(etastart)) {
+ if (!length(etastart)) {
shape1 = rep( .i1, len=n)
- shape2 = if(length( .i2)) rep( .i2,len=n) else {
- if( .method.init == 1) {
+ shape2 = if (length( .i2)) rep( .i2,len=n) else {
+ if ( .method.init == 1) {
shape1 * (1 / weighted.mean(y, w) - 1)
- } else if( .method.init == 2) {
+ } else if ( .method.init == 2) {
temp777 = .sinit * weighted.mean(y, w) + (1- .sinit) * y
shape1 * (1 / temp777 - 1)
} else {
- shape1 * (1 / mustart - 1)
+ shape1 * (1 / weighted.mean(mustart, w) - 1)
}
}
ycounts = y * w # Convert proportions to counts
- if(max(abs(ycounts-round(ycounts))) > 1.0e-6)
- stop("ycounts not integer")
+ if (max(abs(ycounts-round(ycounts))) > 1.0e-6)
+ warning("the response (as counts) does not appear to be integer-valued. ",
+ "Am rounding to integer values.")
ycounts = round(ycounts) # Make sure it is an integer
etastart = cbind(theta2eta(shape1, .lshape12, earg= .earg),
theta2eta(shape2, .lshape12, earg= .earg))
@@ -1029,10 +1052,16 @@ betabin.ab.control <- function(save.weight=TRUE, ...)
loglikelihood=eval(substitute(
function(mu,y,w,residuals=FALSE,eta, extra=NULL) {
ycounts = y * w # Convert proportions to counts
+
+ smallno = 1.0e4 * .Machine$double.eps
+ if (max(abs(ycounts - round(y * w))) > smallno)
+ warning("converting 'ycounts' to integer in @loglikelihood")
+ ycounts = round(ycounts)
+
shape1 = eta2theta(eta[,1], .lshape12, earg= .earg)
shape2 = eta2theta(eta[,2], .lshape12, earg= .earg)
nvec = w
- if(residuals) stop("loglikelihood residuals not implemented yet") else {
+ if (residuals) stop("loglikelihood residuals not implemented yet") else {
sum(dbetabin.ab(x=ycounts, size=nvec, shape1=shape1,
shape2=shape2, log=TRUE))
}
@@ -1053,7 +1082,7 @@ betabin.ab.control <- function(save.weight=TRUE, ...)
cbind(dl.dshape1 * dshape1.deta, dl.dshape2 * dshape2.deta)
}), list( .lshape12=lshape12, .earg=earg ))),
weight=eval(substitute(expression({
- if(is.null( .nsimEIM)) {
+ if (is.null( .nsimEIM)) {
wz = matrix(as.numeric(NA), n, dimm(M)) #3=dimm(2)
wz[,iam(1,1,M)] = -(expected.betabin.ab(nvec,shape1,shape2, TRUE) -
trigamma(shape1+shape2+nvec) -
@@ -1085,7 +1114,7 @@ betabin.ab.control <- function(save.weight=TRUE, ...)
run.varcov = ((ii-1) * run.varcov +
temp3[,ind1$row.index]*temp3[,ind1$col.index]) / ii
}
- wz = if(intercept.only)
+ wz = if (intercept.only)
matrix(colMeans(run.varcov),
n, ncol(run.varcov), byrow=TRUE) else run.varcov
@@ -1102,18 +1131,18 @@ betabin.ab.control <- function(save.weight=TRUE, ...)
iprob = NULL, ishape = 0.1,
moreSummation=c(2,100), tolerance=1.0e-10, zero=NULL)
{
- if(mode(lprob) != "character" && mode(lprob) != "name")
+ if (mode(lprob) != "character" && mode(lprob) != "name")
lprob = as.character(substitute(lprob))
- if(mode(lshape) != "character" && mode(lshape) != "name")
+ if (mode(lshape) != "character" && mode(lshape) != "name")
lshape = as.character(substitute(lshape))
- if(!is.Numeric(ishape, positive=TRUE))
+ if (!is.Numeric(ishape, positive=TRUE))
stop("bad input for argument 'ishape'")
- if(!is.Numeric(moreSummation, positive=TRUE, allow=2, integ=TRUE))
+ if (!is.Numeric(moreSummation, positive=TRUE, allow=2, integ=TRUE))
stop("bad input for argument 'moreSummation'")
- if(!is.Numeric(tolerance, positive=TRUE, allow=1) || 1.0-tolerance >= 1.0)
+ if (!is.Numeric(tolerance, positive=TRUE, allow=1) || 1.0-tolerance >= 1.0)
stop("bad input for argument 'tolerance'")
- if(!is.list(eprob)) eprob = list()
- if(!is.list(eshape)) eshape = list()
+ if (!is.list(eprob)) eprob = list()
+ if (!is.list(eshape)) eshape = list()
new("vglmff",
blurb=c("Beta-geometric distribution\n",
@@ -1124,13 +1153,13 @@ betabin.ab.control <- function(save.weight=TRUE, ...)
}), list( .zero=zero ))),
initialize=eval(substitute(expression({
eval(geometric()@initialize)
- predictors.names = c(namesof("prob", .lprob, earg= .eprob, tag=FALSE),
+ predictors.names = c(namesof("prob", .lprob, earg= .eprob, tag=FALSE),
namesof("shape", .lshape, earg= .eshape, short=FALSE))
- if(length( .iprob))
+ if (length( .iprob))
prob.init = rep( .iprob, len=n)
- if(!length(etastart) || ncol(cbind(etastart)) != 2) {
+ if (!length(etastart) || ncol(cbind(etastart)) != 2) {
shape.init = rep( .ishape, len=n)
- etastart = cbind(theta2eta(prob.init, .lprob, earg= .eprob),
+ etastart = cbind(theta2eta(prob.init, .lprob, earg= .eprob),
theta2eta(shape.init, .lshape, earg= .eshape))
}
}), list( .iprob=iprob, .ishape=ishape, .lprob=lprob,
@@ -1146,7 +1175,7 @@ betabin.ab.control <- function(save.weight=TRUE, ...)
last=eval(substitute(expression({
misc$link = c("prob" = .lprob, "shape" = .lshape)
misc$earg <- list(prob = .eprob, shape = .eshape)
- if(intercept.only) {
+ if (intercept.only) {
misc$shape1 = shape1[1] # These quantities computed in @deriv
misc$shape2 = shape2[1]
}
@@ -1163,7 +1192,7 @@ betabin.ab.control <- function(save.weight=TRUE, ...)
shape = eta2theta(eta[,2], .lshape, earg= .eshape)
ans = log(prob)
maxy = max(y)
- if(residuals) stop("loglikelihood residuals not implemented yet") else {
+ if (residuals) stop("loglikelihood residuals not implemented yet") else {
for(ii in 1:maxy) {
index = ii <= y
ans[index]=ans[index] + log1p(-prob[index]+(ii-1)*shape[index])-
@@ -1174,7 +1203,6 @@ betabin.ab.control <- function(save.weight=TRUE, ...)
-
sum(w * ans)
}
}, list( .lprob=lprob, .lshape=lshape,
@@ -1214,7 +1242,7 @@ betabin.ab.control <- function(save.weight=TRUE, ...)
wz[,iam(1,2,M)] = wz[,iam(1,2,M)] - (ii-2) * temp7 / denom1
wz[,iam(2,2,M)] = wz[,iam(2,2,M)] + (ii-2)^2 * temp7 / denom1 -
(ii-1)^2 * temp7 / denom2
- if(max(temp7) < .tolerance ) break;
+ if (max(temp7) < .tolerance ) break;
}
ii = 2
temp7 = 1 - pbetageom(q=ii-1-1, shape1=shape1, shape2=shape2)
@@ -1239,18 +1267,18 @@ seq2binomial = function(lprob1="logit", lprob2="logit",
iprob1 = NULL, iprob2 = NULL,
zero=NULL)
{
- if(mode(lprob1) != "character" && mode(lprob1) != "name")
+ if (mode(lprob1) != "character" && mode(lprob1) != "name")
lprob1 = as.character(substitute(lprob1))
- if(mode(lprob2) != "character" && mode(lprob2) != "name")
+ if (mode(lprob2) != "character" && mode(lprob2) != "name")
lprob2 = as.character(substitute(lprob2))
- if(length(iprob1) &&
+ if (length(iprob1) &&
(!is.Numeric(iprob1, positive=TRUE) || max(iprob1) >= 1))
stop("bad input for argument 'iprob1'")
- if(length(iprob2) &&
+ 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",
@@ -1260,27 +1288,27 @@ seq2binomial = function(lprob1="logit", lprob2="logit",
constraints <- cm.zero.vgam(constraints, x, .zero, M)
}), list( .zero=zero ))),
initialize=eval(substitute(expression({
- if(!is.vector(w))
+ if (!is.vector(w))
stop("the 'weights' argument must be a vector")
- if(any(w != round(w)))
+ if (any(w != round(w)))
warning("the 'weights' argument should be integer-valued")
- if(ncol(y <- cbind(y)) != 2)
+ if (ncol(y <- cbind(y)) != 2)
stop("the response must be a 2-column matrix")
- if(any(y < 0 | y > 1))
+ if (any(y < 0 | y > 1))
stop("the response must have values between 0 and 1")
rvector = w * y[,1]
- if(any(abs(rvector - round(rvector)) > 1.0e-8))
+ 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))
+ 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
+ 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, len=n) else
+ prob2.init = if (is.Numeric( .iprob2)) rep( .iprob2, len=n) else
rep(weighted.mean(y[,2], w=w*y[,1]), len=n)
- if(!length(etastart)) {
+ if (!length(etastart)) {
etastart = cbind(theta2eta(prob1.init, .lprob1, earg= .eprob1),
theta2eta(prob2.init, .lprob2, earg= .eprob2))
}
@@ -1312,7 +1340,7 @@ seq2binomial = function(lprob1="logit", lprob2="logit",
prob2 = pmin(prob2, 1-smallno)
rvector = w * y[,1]
svector = rvector * y[,2]
- if(residuals) stop("loglikelihood residuals not implemented yet") else {
+ if (residuals) stop("loglikelihood residuals not implemented yet") else {
sum(rvector * log(prob1) + (mvector-rvector)*log1p(-prob1) +
svector * log(prob2) + (rvector-svector)*log1p(-prob2))
}
@@ -1354,18 +1382,18 @@ zipebcom = function(lmu12="cloglog", lphi12="logit", loratio="loge",
addRidge=0.001)
{
- if(mode(lphi12) != "character" && mode(lphi12) != "name")
+ if (mode(lphi12) != "character" && mode(lphi12) != "name")
lphi12 = as.character(substitute(lphi12))
- if(mode(loratio) != "character" && mode(loratio) != "name")
+ if (mode(loratio) != "character" && mode(loratio) != "name")
loratio = as.character(substitute(loratio))
- if(!is.Numeric(tol, positive=TRUE, allow=1) || tol > 0.1)
+ if (!is.Numeric(tol, positive=TRUE, allow=1) || tol > 0.1)
stop("bad input for argument 'tol'")
- if(!is.Numeric(addRidge, allow=1, posit=TRUE) || addRidge > 0.5)
+ if (!is.Numeric(addRidge, allow=1, posit=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(lmu12 != "cloglog")
+ 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'")
new("vglmff",
@@ -1387,18 +1415,18 @@ zipebcom = function(lmu12="cloglog", lphi12="logit", loratio="loge",
propY1.eq.0 = weighted.mean(y[,'00'], w) + weighted.mean(y[,'01'], w)
propY2.eq.0 = weighted.mean(y[,'00'], w) + weighted.mean(y[,'10'], w)
- if(length( .iphi12) && any(.iphi12 > propY1.eq.0))
+ if (length( .iphi12) && any(.iphi12 > propY1.eq.0))
warning("iphi12 must be less than the sample proportion of Y1==0")
- if(length( .iphi12) && any(.iphi12 > propY2.eq.0))
+ if (length( .iphi12) && any(.iphi12 > propY2.eq.0))
warning("iphi12 must be less than the sample proportion of Y2==0")
- if(!length(etastart)) {
+ if (!length(etastart)) {
pstar.init = ((mu[,3]+mu[,4]) + (mu[,2]+mu[,4])) / 2
- phi.init = if(length(.iphi12)) rep(.iphi12, len=n) else
+ phi.init = if (length(.iphi12)) rep(.iphi12, len=n) else
min(propY1.eq.0 * 0.95, propY2.eq.0 * 0.95, pstar.init/1.5)
- oratio.init = if(length( .ioratio)) rep( .ioratio, len=n) else
+ oratio.init = if (length( .ioratio)) rep( .ioratio, len=n) else
mu[,4]*mu[,1]/(mu[,2]*mu[,3])
- mu12.init = if(length(.imu12)) rep(.imu12, len=n) else
+ mu12.init = if (length(.imu12)) rep(.imu12, len=n) else
pstar.init / (1-phi.init)
etastart = cbind(
theta2eta(mu12.init, .lmu12, earg= .emu12),
@@ -1434,7 +1462,7 @@ zipebcom = function(lmu12="cloglog", lphi12="logit", loratio="loge",
.lmu12=lmu12, .lphi12=lphi12, .loratio=loratio,
.emu12=emu12, .ephi12=ephi12, .eoratio=eoratio ))),
loglikelihood= function(mu, y, w, residuals = FALSE, eta, extra=NULL)
- if(residuals) stop("loglikelihood residuals not implemented yet") else {
+ if (residuals) stop("loglikelihood residuals not implemented yet") else {
sum(dmultinomial(x=w*y, size=w, prob=mu, log=TRUE, docheck=FALSE))
},
vfamily=c("zipebcom"),
diff --git a/R/family.bivariate.q b/R/family.bivariate.R
similarity index 79%
rename from R/family.bivariate.q
rename to R/family.bivariate.R
index 897a873..9c4c35a 100644
--- a/R/family.bivariate.q
+++ b/R/family.bivariate.R
@@ -1,5 +1,5 @@
# These functions are
-# Copyright (C) 1998-2009 T.W. Yee, University of Auckland. All rights reserved.
+# Copyright (C) 1998-2010 T.W. Yee, University of Auckland. All rights reserved.
@@ -21,11 +21,11 @@ bilogistic4.control <- function(save.weight=TRUE, ...)
iloc1=NULL, iscale1=NULL,
iloc2=NULL, iscale2=NULL,
method.init=1, zero=NULL) {
- if(mode(llocation) != "character" && mode(llocation) != "name")
+ if (mode(llocation) != "character" && mode(llocation) != "name")
llocation = as.character(substitute(llocation))
- if(mode(lscale) != "character" && mode(lscale) != "name")
+ if (mode(lscale) != "character" && mode(lscale) != "name")
lscale = as.character(substitute(lscale))
- if(!is.Numeric(method.init, allow=1, integ=TRUE, posit=TRUE) ||
+ if (!is.Numeric(method.init, allow=1, integ=TRUE, posit=TRUE) ||
method.init > 2) stop("method.init must be 1 or 2")
new("vglmff",
@@ -41,14 +41,14 @@ bilogistic4.control <- function(save.weight=TRUE, ...)
constraints = cm.zero.vgam(constraints, x, .zero, M)
}), list(.zero=zero))),
initialize=eval(substitute(expression({
- if(!is.matrix(y) || ncol(y) != 2)
+ if (!is.matrix(y) || ncol(y) != 2)
stop("the response must be a 2 column matrix")
predictors.names = c(namesof("location1", .llocation, tag= FALSE),
namesof("scale1", .lscale, tag= FALSE),
namesof("location2", .llocation, tag= FALSE),
namesof("scale2", .lscale, tag= FALSE))
- if(!length(etastart)) {
- if( .method.init == 1) {
+ if (!length(etastart)) {
+ if ( .method.init == 1) {
location.init1 = y[,1]
scale.init1 = sqrt(3) * sd(y[,1]) / pi
location.init2 = y[,2]
@@ -59,16 +59,16 @@ bilogistic4.control <- function(save.weight=TRUE, ...)
scale.init1=sqrt(3)*sum(w*(y[,1]-location.init1)^2)/(sum(w)*pi)
scale.init2=sqrt(3)*sum(w*(y[,2]-location.init2)^2)/(sum(w)*pi)
}
- loc1.init = if(length(.iloc1)) rep(.iloc1, len=n) else
+ loc1.init = if (length(.iloc1)) rep(.iloc1, len=n) else
rep(location.init1, len=n)
- loc2.init = if(length(.iloc2)) rep(.iloc2, len=n) else
+ loc2.init = if (length(.iloc2)) rep(.iloc2, len=n) else
rep(location.init2, len=n)
- scale1.init = if(length(.iscale1)) rep(.iscale1, len=n) else
+ scale1.init = if (length(.iscale1)) rep(.iscale1, len=n) else
rep(1, len=n)
- scale2.init = if(length(.iscale2)) rep(.iscale2, len=n) else
+ scale2.init = if (length(.iscale2)) rep(.iscale2, len=n) else
rep(1, len=n)
- if(.llocation=="loge") location.init1 = abs(location.init1) + 0.001
- if(.llocation=="loge") location.init2 = abs(location.init2) + 0.001
+ if (.llocation=="loge") location.init1 = abs(location.init1) + 0.001
+ if (.llocation=="loge") location.init2 = abs(location.init2) + 0.001
etastart = cbind(theta2eta(location.init1, .llocation),
theta2eta(scale1.init, .lscale),
theta2eta(location.init2, .llocation),
@@ -94,7 +94,7 @@ bilogistic4.control <- function(save.weight=TRUE, ...)
Scale2 = eta2theta(eta[,4], .lscale)
zedd1 = (y[,1]-loc1) / Scale1
zedd2 = (y[,2]-loc2) / Scale2
- if(residuals) stop("loglikelihood residuals not implemented yet") else
+ if (residuals) stop("loglikelihood residuals not implemented yet") else
sum(w * (-zedd1 - zedd2 - 3 * log1p(exp(-zedd1)+exp(-zedd2)) -
log(Scale1) - log(Scale2)))
}, list(.lscale=lscale, .llocation=llocation))),
@@ -117,7 +117,7 @@ bilogistic4.control <- function(save.weight=TRUE, ...)
dloc2.deta = dtheta.deta(loc2, .llocation)
dscale1.deta = dtheta.deta(Scale1, .lscale)
dscale2.deta = dtheta.deta(Scale2, .lscale)
- if(iter == 1) {
+ if (iter == 1) {
etanew = eta
} else {
derivold = derivnew
@@ -131,7 +131,7 @@ bilogistic4.control <- function(save.weight=TRUE, ...)
derivnew
}), list(.lscale=lscale, .llocation=llocation))),
weight=eval(substitute(expression({
- if(iter == 1) {
+ if (iter == 1) {
wznew = cbind(matrix(w, n, M), matrix(0, n, dimm(M)-M))
} else {
wzold = wznew
@@ -146,9 +146,9 @@ bilogistic4.control <- function(save.weight=TRUE, ...)
rbilogis4 = function(n, loc1=0, scale1=1, loc2=0, scale2=1) {
- if(!is.Numeric(n, posit=TRUE,allow=1,integ=TRUE)) stop("bad input for 'n'")
- if(!is.Numeric(scale1, posit=TRUE)) stop("bad input for 'scale1'")
- if(!is.Numeric(scale2, posit=TRUE)) stop("bad input for 'scale2'")
+ if (!is.Numeric(n, posit=TRUE,allow=1,integ=TRUE)) stop("bad input for 'n'")
+ if (!is.Numeric(scale1, posit=TRUE)) stop("bad input for 'scale1'")
+ if (!is.Numeric(scale2, posit=TRUE)) stop("bad input for 'scale2'")
y1 = rlogis(n, loc=loc1, scale=scale1)
ezedd1 = exp(-(y1-loc1)/scale1)
y2 = loc2 - scale2 * log(1/sqrt(runif(n) / (1 + ezedd1)^2) - 1 - ezedd1)
@@ -156,17 +156,17 @@ rbilogis4 = function(n, loc1=0, scale1=1, loc2=0, scale2=1) {
}
pbilogis4 = function(q1, q2, loc1=0, scale1=1, loc2=0, scale2=1) {
- if(!is.Numeric(q1)) stop("bad input for 'q1'")
- if(!is.Numeric(q2)) stop("bad input for 'q2'")
- if(!is.Numeric(scale1, posit=TRUE)) stop("bad input for 'scale1'")
- if(!is.Numeric(scale2, posit=TRUE)) stop("bad input for 'scale2'")
+ if (!is.Numeric(q1)) stop("bad input for 'q1'")
+ if (!is.Numeric(q2)) stop("bad input for 'q2'")
+ if (!is.Numeric(scale1, posit=TRUE)) stop("bad input for 'scale1'")
+ if (!is.Numeric(scale2, posit=TRUE)) stop("bad input for 'scale2'")
1 / (1 + exp(-(q1-loc1)/scale1) + exp(-(q2-loc2)/scale2))
}
dbilogis4 = function(x1, x2, loc1=0, scale1=1, loc2=0, scale2=1, log=FALSE) {
- if(!is.logical(log.arg <- log))
+ if (!is.logical(log.arg <- log))
stop("bad input for argument 'log'")
rm(log)
@@ -180,7 +180,7 @@ dbilogis4 = function(x1, x2, loc1=0, scale1=1, loc2=0, scale2=1, log=FALSE) {
zedd2 = (-(x2-loc2)/scale2)
logdensity = log(2) + log(zedd1) + log(zedd2) - log(scale1) -
log(scale1) - 3 * log1p(exp(zedd1) + exp(zedd2))
- if(log.arg) logdensity else exp(logdensity)
+ if (log.arg) logdensity else exp(logdensity)
}
@@ -193,13 +193,13 @@ dbilogis4 = function(x1, x2, loc1=0, scale1=1, loc2=0, scale2=1, log=FALSE) {
ia=NULL, iap=NULL, ib=NULL, ibp=NULL,
independent=FALSE,
zero=NULL) {
- if(mode(la) != "character" && mode(la) != "name")
+ if (mode(la) != "character" && mode(la) != "name")
la = as.character(substitute(la))
- if(mode(lap) != "character" && mode(lap) != "name")
+ if (mode(lap) != "character" && mode(lap) != "name")
lap = as.character(substitute(lap))
- if(mode(lb) != "character" && mode(lb) != "name")
+ if (mode(lb) != "character" && mode(lb) != "name")
lb = as.character(substitute(lb))
- if(mode(lbp) != "character" && mode(lbp) != "name")
+ if (mode(lbp) != "character" && mode(lbp) != "name")
lbp = as.character(substitute(lbp))
new("vglmff",
@@ -215,27 +215,27 @@ dbilogis4 = function(x1, x2, loc1=0, scale1=1, loc2=0, scale2=1, log=FALSE) {
constraints = cm.zero.vgam(constraints, x, .zero, M)
}), list(.independent=independent, .zero=zero))),
initialize=eval(substitute(expression({
- if(!is.matrix(y) || ncol(y) != 2)
+ if (!is.matrix(y) || ncol(y) != 2)
stop("the response must be a 2 column matrix")
predictors.names = c(namesof("a", .la, short=TRUE),
namesof("ap", .lap, short=TRUE),
namesof("b", .lb, short=TRUE),
namesof("bp", .lbp, short=TRUE))
extra$y1.lt.y2 = y[,1] < y[,2]
- if(!(arr <- sum(extra$y1.lt.y2)) || arr==n)
+ if (!(arr <- sum(extra$y1.lt.y2)) || arr==n)
stop("identifiability problem: either all y1<y2 or y2<y1")
- if(!length(etastart)) {
+ if (!length(etastart)) {
sumx = sum(y[extra$y1.lt.y2,1]); sumxp = sum(y[!extra$y1.lt.y2,1])
sumy = sum(y[extra$y1.lt.y2,2]); sumyp = sum(y[!extra$y1.lt.y2,2])
- if(FALSE) { # Noise:
+ if (FALSE) { # Noise:
arr = min(arr + n/10, n*0.95)
sumx = sumx * 1.1; sumxp = sumxp * 1.2;
sumy = sumy * 1.2; sumyp = sumyp * 1.3;
}
- ainit = if(length(.ia)) rep(.ia, len=n) else arr / (sumx + sumyp)
- apinit = if(length(.iap)) rep(.iap,len=n) else (n-arr)/(sumxp-sumyp)
- binit = if(length(.ib)) rep(.ib, len=n) else (n-arr)/(sumx +sumyp)
- bpinit = if(length(.ib)) rep(.ibp,len=n) else arr / (sumy - sumx)
+ ainit = if (length(.ia)) rep(.ia, len=n) else arr / (sumx + sumyp)
+ apinit = if (length(.iap)) rep(.iap,len=n) else (n-arr)/(sumxp-sumyp)
+ binit = if (length(.ib)) rep(.ib, len=n) else (n-arr)/(sumx +sumyp)
+ bpinit = if (length(.ib)) rep(.ibp,len=n) else arr / (sumy - sumx)
etastart = cbind(theta2eta(rep(ainit, len=n), .la),
theta2eta(rep(apinit, len=n), .lap),
theta2eta(rep(binit, len=n), .lb),
@@ -260,7 +260,7 @@ dbilogis4 = function(x1, x2, loc1=0, scale1=1, loc2=0, scale2=1, log=FALSE) {
alphap = eta2theta(eta[,2], .lap)
beta = eta2theta(eta[,3], .lb)
betap = eta2theta(eta[,4], .lbp)
- if(residuals) stop("loglikelihood residuals not implemented yet") else {
+ if (residuals) stop("loglikelihood residuals not implemented yet") else {
tmp88 = extra$y1.lt.y2
ell1 = log(alpha[tmp88]) + log(betap[tmp88]) -
betap[tmp88] * y[tmp88,2] -
@@ -316,16 +316,16 @@ dbilogis4 = function(x1, x2, loc1=0, scale1=1, loc2=0, scale2=1, log=FALSE) {
ip=1,
iq=1,
zero=NULL) {
- if(mode(la) != "character" && mode(la) != "name")
+ if (mode(la) != "character" && mode(la) != "name")
la = as.character(substitute(la))
- if(mode(lp) != "character" && mode(lp) != "name")
+ if (mode(lp) != "character" && mode(lp) != "name")
lp = as.character(substitute(lp))
- if(mode(lq) != "character" && mode(lq) != "name")
+ if (mode(lq) != "character" && mode(lq) != "name")
lq = as.character(substitute(lq))
- if(!is.Numeric(ip, positive = TRUE) || !is.Numeric(iq, positive = TRUE))
- stop("initial values for ip and iq must be positive")
- if(is.Numeric(ia) && any(ia <= 0))
- stop("ia must be positive or NULL")
+ if (!is.Numeric(ip, positive = TRUE) || !is.Numeric(iq, positive = TRUE))
+ stop("initial values for 'ip' and 'iq' must be positive")
+ if (is.Numeric(ia) && any(ia <= 0))
+ stop("'ia' must be positive or NULL")
new("vglmff",
blurb=c("McKay's Bivariate Gamma Distribution\n",
@@ -337,20 +337,21 @@ dbilogis4 = function(x1, x2, loc1=0, scale1=1, loc2=0, scale2=1, log=FALSE) {
constraints = cm.zero.vgam(constraints, x, .zero, M)
}), list(.zero=zero))),
initialize=eval(substitute(expression({
- if(!is.matrix(y) || ncol(y) != 2)
+ if (!is.matrix(y) || ncol(y) != 2)
stop("the response must be a 2 column matrix")
sorty1 = pmin(y[,1], y[,2])
sorty2 = pmax(y[,1], y[,2])
- if(any(sorty2-sorty1 <= 0))
+ if (any(sorty2 - sorty1 <= 0))
stop("Delete those observations that are identical")
predictors.names = c(namesof("a", .la, short=TRUE),
namesof("p", .lp, short=TRUE),
namesof("q", .lq, short=TRUE))
- if(!length(etastart)) {
+ if (!length(etastart)) {
pinit = rep(.ip, len=n)
qinit = rep(.iq, len=n)
- # Computing ainit from pinit and qinit is easy
- ainit = if(length(.ia)) rep(.ia, len=n) else (pinit+qinit)/(sorty1+0.1)
+ ainit = if (length(.ia)) {
+ rep(.ia, len=n)
+ } else (pinit+qinit)/(sorty1+0.1)
etastart = cbind(theta2eta(ainit, .la),
theta2eta(pinit, .lp),
theta2eta(qinit, .lq))
@@ -372,7 +373,7 @@ dbilogis4 = function(x1, x2, loc1=0, scale1=1, loc2=0, scale2=1, log=FALSE) {
q = eta2theta(eta[,3], .lq)
y = cbind(pmin(y[,1], y[,2]), pmax(y[,1], y[,2])) # Sort so y[,1]<y[,2]
# Note that, after sorting, y[,1] < y[,2] is needed:
- if(residuals) stop("loglikelihood residuals not implemented yet") else
+ if (residuals) stop("loglikelihood residuals not implemented yet") else
sum(w * ((p+q)*log(a) - lgamma(p) - lgamma(q) +
(p-1)*log(y[,1]) + (q-1)*log(y[,2]-y[,1]) - a*y[,2] ))
}, list(.la=la, .lp=lp, .lq=lq))),
@@ -412,8 +413,8 @@ dbilogis4 = function(x1, x2, loc1=0, scale1=1, loc2=0, scale2=1, log=FALSE) {
rfrank = function(n, alpha) {
- if(!is.Numeric(n, posit=TRUE, allow=1, integ=TRUE)) stop("bad input for 'n'")
- if(!is.Numeric(alpha, posit=TRUE)) stop("bad input for 'alpha'")
+ if (!is.Numeric(n, posit=TRUE, allow=1, integ=TRUE)) stop("bad input for 'n'")
+ if (!is.Numeric(alpha, posit=TRUE)) stop("bad input for 'alpha'")
alpha = rep(alpha, len=n)
U = runif(n)
V = runif(n)
@@ -421,11 +422,11 @@ rfrank = function(n, alpha) {
X = U
index = abs(alpha-1) < .Machine$double.eps
Y = U
- if(any(!index))
+ if (any(!index))
Y[!index] = logb(T[!index]/(T[!index]+(1-alpha[!index])*V[!index]),
base=alpha[!index])
ans = matrix(c(X,Y), nrow=n, ncol=2)
- if(any(index)) {
+ if (any(index)) {
ans[index,1] = runif(sum(index)) # Uniform density for alpha==1
ans[index,2] = runif(sum(index))
}
@@ -433,9 +434,9 @@ rfrank = function(n, alpha) {
}
pfrank = function(q1, q2, alpha) {
- if(!is.Numeric(q1)) stop("bad input for 'q1'")
- if(!is.Numeric(q2)) stop("bad input for 'q2'")
- if(!is.Numeric(alpha, posit=TRUE)) stop("bad input for 'alpha'")
+ if (!is.Numeric(q1)) stop("bad input for 'q1'")
+ if (!is.Numeric(q2)) stop("bad input for 'q2'")
+ if (!is.Numeric(alpha, posit=TRUE)) stop("bad input for 'alpha'")
L = max(length(q1), length(q2), length(alpha))
alpha = rep(alpha, len=L)
@@ -446,7 +447,7 @@ pfrank = function(q1, q2, alpha) {
index = (x>=1 & y<1) | (y>=1 & x<1) | (x<=0 | y<=0) | (x>=1 & y>=1) |
(abs(alpha-1) < .Machine$double.eps)
ans = as.numeric(index)
- if(any(!index))
+ if (any(!index))
ans[!index] = logb(1 + ((alpha[!index])^(x[!index])-1)*
((alpha[!index])^(y[!index])-1)/(alpha[!index]-1),
base=alpha[!index])
@@ -460,20 +461,20 @@ pfrank = function(q1, q2, alpha) {
}
dfrank = function(x1, x2, alpha, log = FALSE) {
- if(!is.logical(log.arg <- log))
+ if (!is.logical(log.arg <- log))
stop("bad input for argument 'log'")
rm(log)
- if(!is.Numeric(x1)) stop("bad input for 'x1'")
- if(!is.Numeric(x2)) stop("bad input for 'x2'")
- if(!is.Numeric(alpha, posit=TRUE)) stop("bad input for 'alpha'")
+ if (!is.Numeric(x1)) stop("bad input for 'x1'")
+ if (!is.Numeric(x2)) stop("bad input for 'x2'")
+ if (!is.Numeric(alpha, posit=TRUE)) stop("bad input for 'alpha'")
L = max(length(x1), length(x2), length(alpha))
alpha = rep(alpha, len=L)
x1 = rep(x1, len=L)
x2 = rep(x2, len=L)
- if(log.arg) {
+ if (log.arg) {
denom = alpha-1 + (alpha^x1 -1) * (alpha^x2 -1)
denom = abs(denom) # Needed; Genest (1987) uses this too, eqn (4.1)
log((alpha-1) * log(alpha)) + (x1+x2)*log(alpha) - 2 * log(denom)
@@ -481,7 +482,7 @@ dfrank = function(x1, x2, alpha, log = FALSE) {
temp = (alpha-1) + (alpha^x1 - 1) * (alpha^x2 - 1)
index = (abs(alpha-1) < .Machine$double.eps)
ans = x1
- if(any(!index))
+ if (any(!index))
ans[!index] = (alpha[!index]-1) * log(alpha[!index]) *
(alpha[!index])^(x1[!index]+x2[!index]) / (temp[!index])^2
ans[x1<=0 | x2<=0 | x1>=1 | x2>=1] = 0
@@ -501,12 +502,12 @@ frank.control <- function(save.weight=TRUE, ...)
frank = function(lapar="loge", eapar=list(), iapar=2, nsimEIM=250) {
- if(mode(lapar) != "character" && mode(lapar) != "name")
+ if (mode(lapar) != "character" && mode(lapar) != "name")
lapar = as.character(substitute(lapar))
- if(!is.Numeric(iapar, positive = TRUE))
+ if (!is.Numeric(iapar, positive = TRUE))
stop("'iapar' must be positive")
- if(!is.list(eapar)) eapar = list()
- if(length(nsimEIM) &&
+ if (!is.list(eapar)) eapar = list()
+ if (length(nsimEIM) &&
(!is.Numeric(nsimEIM, allow=1, integ=TRUE) || nsimEIM <= 50))
stop("'nsimEIM' should be an integer greater than 50")
@@ -515,14 +516,14 @@ frank.control <- function(save.weight=TRUE, ...)
"Links: ",
namesof("apar", lapar, earg= eapar )),
initialize=eval(substitute(expression({
- if(!is.matrix(y) || ncol(y) != 2)
+ if (!is.matrix(y) || ncol(y) != 2)
stop("the response must be a 2 column matrix")
- if(any(y <= 0) || any(y >= 1))
+ if (any(y <= 0) || any(y >= 1))
stop("the response must have values between 0 and 1")
predictors.names = c(namesof("apar", .lapar, earg= .eapar, short=TRUE))
- if(length(dimnames(y)))
+ if (length(dimnames(y)))
extra$dimnamesy2 = dimnames(y)[[2]]
- if(!length(etastart)) {
+ if (!length(etastart)) {
apar.init = rep(.iapar, len=n)
etastart = cbind(theta2eta(apar.init, .lapar, earg= .eapar ))
}
@@ -530,7 +531,7 @@ frank.control <- function(save.weight=TRUE, ...)
inverse=eval(substitute(function(eta, extra=NULL) {
apar = eta2theta(eta, .lapar, earg= .eapar )
fv.matrix = matrix(0.5, length(apar), 2)
- if(length(extra$dimnamesy2))
+ if (length(extra$dimnamesy2))
dimnames(fv.matrix) = list(names(eta), extra$dimnamesy2)
fv.matrix
}, list(.lapar=lapar, .eapar=eapar ))),
@@ -544,7 +545,7 @@ frank.control <- function(save.weight=TRUE, ...)
loglikelihood= eval(substitute(
function(mu, y, w, residuals = FALSE, eta, extra=NULL) {
apar = eta2theta(eta, .lapar, earg= .eapar )
- if(residuals) stop("loglikelihood residuals not implemented yet") else {
+ if (residuals) stop("loglikelihood residuals not implemented yet") else {
sum(w * dfrank(x1=y[,1], x2=y[,2], alpha=apar, log = TRUE))
}
}, list(.lapar=lapar, .eapar=eapar ))),
@@ -566,7 +567,7 @@ frank.control <- function(save.weight=TRUE, ...)
w * Dl.dapar * dapar.deta
}), list(.lapar=lapar, .eapar=eapar, .nsimEIM=nsimEIM ))),
weight=eval(substitute(expression({
- if( is.Numeric( .nsimEIM)) {
+ if ( is.Numeric( .nsimEIM)) {
pooled.weight = FALSE # For @last
@@ -581,7 +582,7 @@ frank.control <- function(save.weight=TRUE, ...)
temp3 = -d2l.dthetas2[,1,1] # M=1
run.mean = ((ii-1) * run.mean + temp3) / ii
}
- wz = if(intercept.only)
+ wz = if (intercept.only)
matrix(mean(run.mean), n, dimm(M)) else run.mean
wz = wz * dapar.deta^2
@@ -596,7 +597,7 @@ frank.control <- function(save.weight=TRUE, ...)
(nump / denom - (numerator/denom)^2)
d2apar.deta2 = d2theta.deta2(apar, .lapar)
wz = w * (dapar.deta^2 * D2l.dapar2 - Dl.dapar * d2apar.deta2)
- if(TRUE && intercept.only) {
+ if (TRUE && intercept.only) {
wz = cbind(wz)
sumw = sum(w)
for(iii in 1:ncol(wz))
@@ -613,9 +614,9 @@ frank.control <- function(save.weight=TRUE, ...)
gammahyp = function(ltheta="loge", itheta=NULL, expected=FALSE) {
- if(mode(ltheta) != "character" && mode(ltheta) != "name")
+ if (mode(ltheta) != "character" && mode(ltheta) != "name")
ltheta = as.character(substitute(ltheta))
- if(!is.logical(expected) || length(expected)!=1)
+ if (!is.logical(expected) || length(expected)!=1)
stop("'expected' must be a single logical")
new("vglmff",
@@ -623,13 +624,13 @@ frank.control <- function(save.weight=TRUE, ...)
"Links: ",
namesof("theta", ltheta)),
initialize=eval(substitute(expression({
- if(!is.matrix(y) || ncol(y) != 2)
+ if (!is.matrix(y) || ncol(y) != 2)
stop("the response must be a 2 column matrix")
- if(any(y[,1] <= 0) || any(y[,2] <= 1))
+ if (any(y[,1] <= 0) || any(y[,2] <= 1))
stop("the response has values that are out of range")
predictors.names = c(namesof("theta", .ltheta, short=TRUE))
- if(!length(etastart)) {
- theta.init = if(length( .itheta)) rep(.itheta, len=n) else {
+ if (!length(etastart)) {
+ theta.init = if (length( .itheta)) rep(.itheta, len=n) else {
1 / (y[,2] - 1 + 0.01)
}
etastart = cbind(theta2eta(theta.init, .ltheta))
@@ -646,7 +647,7 @@ frank.control <- function(save.weight=TRUE, ...)
loglikelihood= eval(substitute(
function(mu, y, w, residuals = FALSE, eta, extra=NULL) {
theta = eta2theta(eta, .ltheta)
- if(residuals) stop("loglikelihood residuals not implemented yet") else {
+ if (residuals) stop("loglikelihood residuals not implemented yet") else {
sum(w * (-exp(-theta)*y[,1]/theta - theta*y[,2]))
}
}, list(.ltheta=ltheta))),
@@ -659,7 +660,7 @@ frank.control <- function(save.weight=TRUE, ...)
}), list(.ltheta=ltheta))),
weight=eval(substitute(expression({
temp300 = 2 + theta * (2 + theta)
- if( .expected) {
+ if ( .expected) {
D2l.dtheta2 = temp300 / theta^2
wz = w * Dtheta.deta^2 * D2l.dtheta2
} else {
@@ -675,16 +676,16 @@ frank.control <- function(save.weight=TRUE, ...)
morgenstern = function(lapar="rhobit", earg=list(), iapar=NULL, tola0=0.01,
method.init=1) {
- if(mode(lapar) != "character" && mode(lapar) != "name")
+ if (mode(lapar) != "character" && mode(lapar) != "name")
lapar = as.character(substitute(lapar))
- if(!is.list(earg)) earg = list()
- if(length(iapar) && (!is.Numeric(iapar, allow=1) || abs(iapar) >= 1))
+ if (!is.list(earg)) earg = list()
+ if (length(iapar) && (!is.Numeric(iapar, allow=1) || abs(iapar) >= 1))
stop("'iapar' must be a single number between -1 and 1")
- if(!is.Numeric(tola0, allow=1, posit=TRUE))
+ if (!is.Numeric(tola0, allow=1, posit=TRUE))
stop("'tola0' must be a single positive number")
- if(length(iapar) && abs(iapar) <= tola0)
+ if (length(iapar) && abs(iapar) <= tola0)
stop("'iapar' must not be between -tola0 and tola0")
- if(!is.Numeric(method.init, allow=1, integ=TRUE, positi=TRUE) ||
+ if (!is.Numeric(method.init, allow=1, integ=TRUE, positi=TRUE) ||
method.init > 2.5)
stop("argument 'method.init' must be 1 or 2")
@@ -693,17 +694,17 @@ frank.control <- function(save.weight=TRUE, ...)
"Links: ",
namesof("apar", lapar, earg= earg )),
initialize=eval(substitute(expression({
- if(!is.matrix(y) || ncol(y) != 2)
+ if (!is.matrix(y) || ncol(y) != 2)
stop("the response must be a 2 column matrix")
- if(any(y < 0))
+ if (any(y < 0))
stop("the response must have non-negative values only")
predictors.names = c(namesof("apar", .lapar, earg= .earg , short=TRUE))
- if(length(dimnames(y)))
+ if (length(dimnames(y)))
extra$dimnamesy2 = dimnames(y)[[2]]
- if(!length(etastart)) {
- ainit = if(length(.iapar)) rep(.iapar, len=n) else {
- mean1 = if( .method.init == 1) median(y[,1]) else mean(y[,1])
- mean2 = if( .method.init == 1) median(y[,2]) else mean(y[,2])
+ if (!length(etastart)) {
+ ainit = if (length(.iapar)) rep(.iapar, len=n) else {
+ mean1 = if ( .method.init == 1) median(y[,1]) else mean(y[,1])
+ mean2 = if ( .method.init == 1) median(y[,2]) else mean(y[,2])
Finit = 0.01 + mean(y[,1] <= mean1 & y[,2] <= mean2)
((Finit+expm1(-mean1)+exp(-mean2)) / exp(-mean1-mean2)-1)/(
expm1(-mean1) * expm1(-mean2))
@@ -715,7 +716,7 @@ frank.control <- function(save.weight=TRUE, ...)
inverse=eval(substitute(function(eta, extra=NULL) {
alpha = eta2theta(eta, .lapar, earg= .earg )
fv.matrix = matrix(1, length(alpha), 2)
- if(length(extra$dimnamesy2))
+ if (length(extra$dimnamesy2))
dimnames(fv.matrix) = list(names(eta), extra$dimnamesy2)
fv.matrix
}, list( .lapar=lapar, .earg=earg ))),
@@ -729,7 +730,7 @@ frank.control <- function(save.weight=TRUE, ...)
function(mu, y, w, residuals = FALSE, eta, extra=NULL) {
alpha = eta2theta(eta, .lapar, earg= .earg )
alpha[abs(alpha) < .tola0 ] = .tola0
- if(residuals) stop("loglikelihood residuals not implemented yet") else {
+ if (residuals) stop("loglikelihood residuals not implemented yet") else {
denom = (1 + alpha - 2*alpha*(exp(-y[,1]) + exp(-y[,2])) +
4*alpha*exp(-y[,1] - y[,2]))
sum(w * (-y[,1] - y[,2] + log(denom)))
@@ -750,7 +751,7 @@ frank.control <- function(save.weight=TRUE, ...)
d2l.dalpha2 = dl.dalpha^2
d2alpha.deta2 = d2theta.deta2(alpha, .lapar, earg= .earg )
wz = w * (dalpha.deta^2 * d2l.dalpha2 - d2alpha.deta2 * dl.dalpha)
- if(TRUE &&
+ if (TRUE &&
intercept.only) {
wz = cbind(wz)
sumw = sum(w)
@@ -768,9 +769,9 @@ frank.control <- function(save.weight=TRUE, ...)
rfgm = function(n, alpha) {
- if(!is.Numeric(n, posit=TRUE, allow=1, integ=TRUE)) stop("bad input for 'n'")
- if(!is.Numeric(alpha)) stop("bad input for 'alpha'")
- if(any(abs(alpha) > 1)) stop("'alpha' values out of range")
+ if (!is.Numeric(n, posit=TRUE, allow=1, integ=TRUE)) stop("bad input for 'n'")
+ if (!is.Numeric(alpha)) stop("bad input for 'alpha'")
+ if (any(abs(alpha) > 1)) stop("'alpha' values out of range")
y1 = V1 = runif(n)
V2 = runif(n)
@@ -786,24 +787,24 @@ rfgm = function(n, alpha) {
dfgm = function(x1, x2, alpha, log=FALSE) {
log.arg = log
rm(log)
- if(!is.Numeric(alpha)) stop("bad input for 'alpha'")
- if(any(abs(alpha) > 1)) stop("'alpha' values out of range")
- if( !is.logical( log.arg ) || length( log.arg )!=1 )
+ if (!is.Numeric(alpha)) stop("bad input for 'alpha'")
+ if (any(abs(alpha) > 1)) stop("'alpha' values out of range")
+ if ( !is.logical( log.arg ) || length( log.arg )!=1 )
stop("bad input for 'log'")
L = max(length(x1), length(x2), length(alpha))
- if(length(x1) != L) x1 = rep(x1, len=L)
- if(length(x2) != L) x2 = rep(x2, len=L)
- if(length(alpha) != L) alpha = rep(alpha, len=L)
+ if (length(x1) != L) x1 = rep(x1, len=L)
+ if (length(x2) != L) x2 = rep(x2, len=L)
+ if (length(alpha) != L) alpha = rep(alpha, len=L)
ans = 0 * x1
xnok = (x1 <= 0) | (x1 >= 1) | (x2 <= 0) | (x2 >= 1)
- if( log.arg ) {
+ if ( log.arg ) {
ans[!xnok] = log1p(alpha[!xnok] * (1-2*x1[!xnok]) * (1-2*x2[!xnok]))
ans[xnok] = log(0)
} else {
ans[!xnok] = 1 + alpha[!xnok] * (1-2*x1[!xnok]) * (1-2*x2[!xnok])
ans[xnok] = 0
- if(any(ans<0))
+ if (any(ans<0))
stop("negative values in the density (alpha out of range)")
}
ans
@@ -811,20 +812,20 @@ dfgm = function(x1, x2, alpha, log=FALSE) {
pfgm = function(q1, q2, alpha) {
- if(!is.Numeric(q1)) stop("bad input for 'q1'")
- if(!is.Numeric(q2)) stop("bad input for 'q2'")
- if(!is.Numeric(alpha)) stop("bad input for 'alpha'")
- if(any(abs(alpha) > 1)) stop("'alpha' values out of range")
+ if (!is.Numeric(q1)) stop("bad input for 'q1'")
+ if (!is.Numeric(q2)) stop("bad input for 'q2'")
+ if (!is.Numeric(alpha)) stop("bad input for 'alpha'")
+ if (any(abs(alpha) > 1)) stop("'alpha' values out of range")
L = max(length(q1), length(q2), length(alpha))
- if(length(q1) != L) q1 = rep(q1, len=L)
- if(length(q2) != L) q2 = rep(q2, len=L)
- if(length(alpha) != L) alpha = rep(alpha, len=L)
+ if (length(q1) != L) q1 = rep(q1, len=L)
+ if (length(q2) != L) q2 = rep(q2, len=L)
+ if (length(alpha) != L) alpha = rep(alpha, len=L)
x=q1; y=q2
index = (x>=1 & y<1) | (y>=1 & x<1) | (x<=0 | y<=0) | (x>=1 & y>=1)
ans = as.numeric(index)
- if(any(!index)) {
+ if (any(!index)) {
ans[!index] = q1[!index] * q2[!index] * (1 + alpha[!index] *
(1-q1[!index])*(1-q2[!index]))
}
@@ -846,16 +847,16 @@ fgm.control <- function(save.weight=TRUE, ...)
fgm = function(lapar="rhobit", earg=list(), iapar=NULL,
method.init=1, nsimEIM=200) {
- if(mode(lapar) != "character" && mode(lapar) != "name")
+ if (mode(lapar) != "character" && mode(lapar) != "name")
lapar = as.character(substitute(lapar))
- if(!is.list(earg)) earg = list()
- if(!is.Numeric(method.init, allow=1, integ=TRUE, positi=TRUE) ||
+ if (!is.list(earg)) earg = list()
+ if (!is.Numeric(method.init, allow=1, integ=TRUE, positi=TRUE) ||
method.init > 2.5)
stop("argument 'method.init' must be 1 or 2")
- if(!length(nsimEIM) ||
+ if (!length(nsimEIM) ||
(!is.Numeric(nsimEIM, allow=1, integ=TRUE) || nsimEIM <= 50))
stop("'nsimEIM' should be an integer greater than 50")
- if(length(iapar) &&
+ if (length(iapar) &&
(abs(iapar) >= 1))
stop("'iapar' should be less than 1 in absolute value")
@@ -864,18 +865,18 @@ fgm.control <- function(save.weight=TRUE, ...)
"Links: ",
namesof("apar", lapar, earg= earg )),
initialize=eval(substitute(expression({
- if(!is.matrix(y) || ncol(y) != 2)
+ if (!is.matrix(y) || ncol(y) != 2)
stop("the response must be a 2 column matrix")
- if(any(y < 0) || any(y > 1))
+ if (any(y < 0) || any(y > 1))
stop("the response must have values in the unit square")
predictors.names = namesof("apar", .lapar, earg= .earg, short=TRUE)
- if(length(dimnames(y)))
+ if (length(dimnames(y)))
extra$dimnamesy2 = dimnames(y)[[2]]
- if(!length(etastart)) {
- ainit = if(length( .iapar )) .iapar else {
- mean1 = if( .method.init == 1) weighted.mean(y[,1],w) else
+ if (!length(etastart)) {
+ ainit = if (length( .iapar )) .iapar else {
+ mean1 = if ( .method.init == 1) weighted.mean(y[,1],w) else
median(y[,1])
- mean2 = if( .method.init == 1) weighted.mean(y[,2],w) else
+ mean2 = if ( .method.init == 1) weighted.mean(y[,2],w) else
median(y[,2])
Finit = weighted.mean(y[,1] <= mean1 & y[,2] <= mean2, w)
(Finit / (mean1 * mean2) - 1) / ((1-mean1) * (1-mean2))
@@ -890,7 +891,7 @@ fgm.control <- function(save.weight=TRUE, ...)
inverse=eval(substitute(function(eta, extra=NULL) {
alpha = eta2theta(eta, .lapar, earg= .earg )
fv.matrix = matrix(0.5, length(alpha), 2)
- if(length(extra$dimnamesy2))
+ if (length(extra$dimnamesy2))
dimnames(fv.matrix) = list(names(eta), extra$dimnamesy2)
fv.matrix
}, list( .lapar=lapar, .earg=earg ))),
@@ -903,7 +904,7 @@ fgm.control <- function(save.weight=TRUE, ...)
loglikelihood= eval(substitute(
function(mu, y, w, residuals = FALSE, eta, extra=NULL) {
alpha = eta2theta(eta, .lapar, earg= .earg )
- if(residuals) stop("loglikelihood residuals not implemented yet") else {
+ if (residuals) stop("loglikelihood residuals not implemented yet") else {
sum(w * dfgm(x1=y[,1], x2=y[,2], alpha=alpha, log=TRUE))
}
}, list( .lapar=lapar, .earg=earg ))),
@@ -915,7 +916,7 @@ fgm.control <- function(save.weight=TRUE, ...)
denom = 1 + alpha * numerator
mytolerance = .Machine$double.eps
bad <- (denom <= mytolerance) # Range violation
- if(any(bad)) {
+ if (any(bad)) {
cat("There are some range violations in @deriv\n")
flush.console()
denom[bad] = 2 * mytolerance
@@ -934,7 +935,7 @@ fgm.control <- function(save.weight=TRUE, ...)
temp3 = dl.dalpha
run.var = ((ii-1) * run.var + temp3^2) / ii
}
- wz = if(intercept.only)
+ wz = if (intercept.only)
matrix(colMeans(cbind(run.var)),
n, dimm(M), byrow=TRUE) else cbind(run.var)
@@ -947,12 +948,12 @@ fgm.control <- function(save.weight=TRUE, ...)
gumbelIbiv = function(lapar="identity", earg=list(),
iapar=NULL, method.init=1) {
- if(mode(lapar) != "character" && mode(lapar) != "name")
+ if (mode(lapar) != "character" && mode(lapar) != "name")
lapar = as.character(substitute(lapar))
- if(!is.list(earg)) earg = list()
- if(length(iapar) && !is.Numeric(iapar, allow=1))
+ if (!is.list(earg)) earg = list()
+ if (length(iapar) && !is.Numeric(iapar, allow=1))
stop("'iapar' must be a single number")
- if(!is.Numeric(method.init, allow=1, integ=TRUE, positi=TRUE) ||
+ if (!is.Numeric(method.init, allow=1, integ=TRUE, positi=TRUE) ||
method.init > 2.5)
stop("argument 'method.init' must be 1 or 2")
@@ -961,15 +962,15 @@ fgm.control <- function(save.weight=TRUE, ...)
"Links: ",
namesof("apar", lapar, earg= earg )),
initialize=eval(substitute(expression({
- if(!is.matrix(y) || ncol(y) != 2)
+ if (!is.matrix(y) || ncol(y) != 2)
stop("the response must be a 2 column matrix")
- if(any(y < 0))
+ if (any(y < 0))
stop("the response must have non-negative values only")
predictors.names = c(namesof("apar", .lapar, earg= .earg , short=TRUE))
- if(!length(etastart)) {
- ainit = if(length( .iapar )) rep( .iapar, len=n) else {
- mean1 = if( .method.init == 1) median(y[,1]) else mean(y[,1])
- mean2 = if( .method.init == 1) median(y[,2]) else mean(y[,2])
+ if (!length(etastart)) {
+ ainit = if (length( .iapar )) rep( .iapar, len=n) else {
+ mean1 = if ( .method.init == 1) median(y[,1]) else mean(y[,1])
+ mean2 = if ( .method.init == 1) median(y[,2]) else mean(y[,2])
Finit = 0.01 + mean(y[,1] <= mean1 & y[,2] <= mean2)
(log(Finit+expm1(-mean1)+exp(-mean2))+mean1+mean2)/(mean1*mean2)
}
@@ -991,11 +992,11 @@ fgm.control <- function(save.weight=TRUE, ...)
loglikelihood= eval(substitute(
function(mu, y, w, residuals = FALSE, eta, extra=NULL) {
alpha = eta2theta(eta, .lapar, earg= .earg )
- if(residuals) stop("loglikelihood residuals not implemented yet") else {
+ if (residuals) stop("loglikelihood residuals not implemented yet") else {
denom = (alpha*y[,1] - 1) * (alpha*y[,2] - 1) + alpha
mytolerance = .Machine$double.xmin
bad <- (denom <= mytolerance) # Range violation
- if(any(bad)) {
+ if (any(bad)) {
cat("There are some range violations in @deriv\n")
flush.console()
}
@@ -1018,7 +1019,7 @@ fgm.control <- function(save.weight=TRUE, ...)
d2l.dalpha2 = (numerator/denom)^2 - 2*y[,1]*y[,2] / denom
d2alpha.deta2 = d2theta.deta2(alpha, .lapar, earg= .earg )
wz = w * (dalpha.deta^2 * d2l.dalpha2 - d2alpha.deta2 * dl.dalpha)
- if(TRUE &&
+ if (TRUE &&
intercept.only) {
wz = cbind(wz)
sumw = sum(w)
@@ -1039,20 +1040,20 @@ fgm.control <- function(save.weight=TRUE, ...)
pplack = function(q1, q2, oratio) {
- if(!is.Numeric(q1)) stop("bad input for 'q1'")
- if(!is.Numeric(q2)) stop("bad input for 'q2'")
- if(!is.Numeric(oratio, posit=TRUE)) stop("bad input for 'oratio'")
+ if (!is.Numeric(q1)) stop("bad input for 'q1'")
+ if (!is.Numeric(q2)) stop("bad input for 'q2'")
+ if (!is.Numeric(oratio, posit=TRUE)) stop("bad input for 'oratio'")
L = max(length(q1), length(q2), length(oratio))
- if(length(q1) != L) q1 = rep(q1, len=L)
- if(length(q2) != L) q2 = rep(q2, len=L)
- if(length(oratio) != L) oratio = rep(oratio, len=L)
+ if (length(q1) != L) q1 = rep(q1, len=L)
+ if (length(q2) != L) q2 = rep(q2, len=L)
+ if (length(oratio) != L) oratio = rep(oratio, len=L)
x=q1; y=q2
index = (x>=1 & y<1) | (y>=1 & x<1) | (x<=0 | y<=0) | (x>=1 & y>=1) |
(abs(oratio-1) < 1.0e-6) # .Machine$double.eps
ans = as.numeric(index)
- if(any(!index)) {
+ if (any(!index)) {
temp1 = 1 + (oratio[!index] -1) * (q1[!index] + q2[!index])
temp2 = temp1 - sqrt(temp1^2 - 4 * oratio[!index] *
(oratio[!index]-1) * q1[!index] * q2[!index])
@@ -1071,9 +1072,9 @@ pplack = function(q1, q2, oratio) {
rplack = function(n, oratio) {
- if(!is.Numeric(n, posit=TRUE, allow=1, integ=TRUE)) stop("bad input for 'n'")
- if(!is.Numeric(oratio, posit=TRUE)) stop("bad input for 'oratio'")
- if(length(oratio) != n) oratio = rep(oratio, len=n)
+ if (!is.Numeric(n, posit=TRUE, allow=1, integ=TRUE)) stop("bad input for 'n'")
+ if (!is.Numeric(oratio, posit=TRUE)) stop("bad input for 'oratio'")
+ if (length(oratio) != n) oratio = rep(oratio, len=n)
y1 = U = runif(n)
V = runif(n)
@@ -1090,15 +1091,15 @@ rplack = function(n, oratio) {
dplack = function(x1, x2, oratio, log=FALSE) {
log.arg = log
rm(log)
- if(!is.Numeric(oratio, posit=TRUE)) stop("bad input for 'oratio'")
+ if (!is.Numeric(oratio, posit=TRUE)) stop("bad input for 'oratio'")
L = max(length(x1), length(x2), length(oratio))
- if(length(x1) != L) x1 = rep(x1, len=L)
- if(length(x2) != L) x2 = rep(x2, len=L)
- if(length(oratio) != L) oratio = rep(oratio, len=L)
- if( !is.logical( log.arg ) || length( log.arg )!=1 )
+ if (length(x1) != L) x1 = rep(x1, len=L)
+ if (length(x2) != L) x2 = rep(x2, len=L)
+ if (length(oratio) != L) oratio = rep(oratio, len=L)
+ if ( !is.logical( log.arg ) || length( log.arg )!=1 )
stop("bad input for 'log'")
- if( log.arg ) {
+ if ( log.arg ) {
ans = log(oratio) + log1p((oratio-1) *
(x1+x2-2*x1*x2)) - 1.5 *
log((1 + (x1+x2)*(oratio-1))^2 - 4 * oratio * (oratio-1)*x1*x2)
@@ -1122,12 +1123,12 @@ plackett.control <- function(save.weight=TRUE, ...)
plackett = function(link="loge", earg=list(),
ioratio=NULL, method.init=1, nsimEIM=200) {
- if(mode(link) != "character" && mode(link) != "name")
+ if (mode(link) != "character" && mode(link) != "name")
link = as.character(substitute(link))
- if(!is.list(earg)) earg = list()
- if(length(ioratio) && (!is.Numeric(ioratio, posit=TRUE)))
+ if (!is.list(earg)) earg = list()
+ if (length(ioratio) && (!is.Numeric(ioratio, posit=TRUE)))
stop("'ioratio' must be positive")
- if(!is.Numeric(method.init, allow=1, integ=TRUE, posit=TRUE) ||
+ if (!is.Numeric(method.init, allow=1, integ=TRUE, posit=TRUE) ||
method.init > 2) stop("method.init must be 1 or 2")
new("vglmff",
@@ -1135,21 +1136,21 @@ plackett.control <- function(save.weight=TRUE, ...)
"Links: ",
namesof("oratio", link, earg= earg )),
initialize=eval(substitute(expression({
- if(!is.matrix(y) || ncol(y) != 2)
+ if (!is.matrix(y) || ncol(y) != 2)
stop("the response must be a 2 column matrix")
- if(any(y < 0) || any(y > 1))
+ if (any(y < 0) || any(y > 1))
stop("the response must have values in the unit square")
predictors.names = namesof("oratio", .link, earg= .earg, short=TRUE)
- if(length(dimnames(y)))
+ if (length(dimnames(y)))
extra$dimnamesy2 = dimnames(y)[[2]]
- if(!length(etastart)) {
- orinit = if(length( .ioratio )) .ioratio else {
- if( .method.init == 2) {
+ if (!length(etastart)) {
+ orinit = if (length( .ioratio )) .ioratio else {
+ if ( .method.init == 2) {
scorp = cor(y)[1,2]
- if(abs(scorp) <= 0.1) 1 else
- if(abs(scorp) <= 0.3) 3^sign(scorp) else
- if(abs(scorp) <= 0.6) 5^sign(scorp) else
- if(abs(scorp) <= 0.8) 20^sign(scorp) else 40^sign(scorp)
+ if (abs(scorp) <= 0.1) 1 else
+ if (abs(scorp) <= 0.3) 3^sign(scorp) else
+ if (abs(scorp) <= 0.6) 5^sign(scorp) else
+ if (abs(scorp) <= 0.8) 20^sign(scorp) else 40^sign(scorp)
} else {
y10 = weighted.mean(y[,1], w)
y20 = weighted.mean(y[,2], w)
@@ -1166,7 +1167,7 @@ plackett.control <- function(save.weight=TRUE, ...)
inverse=eval(substitute(function(eta, extra=NULL) {
oratio = eta2theta(eta, .link, earg= .earg )
fv.matrix = matrix(0.5, length(oratio), 2)
- if(length(extra$dimnamesy2))
+ if (length(extra$dimnamesy2))
dimnames(fv.matrix) = list(dimnames(eta)[[1]], extra$dimnamesy2)
fv.matrix
}, list( .link=link, .earg=earg ))),
@@ -1180,7 +1181,7 @@ plackett.control <- function(save.weight=TRUE, ...)
loglikelihood= eval(substitute(
function(mu, y, w, residuals = FALSE, eta, extra=NULL) {
oratio = eta2theta(eta, .link, earg= .earg )
- if(residuals) stop("loglikelihood residuals not implemented yet") else {
+ if (residuals) stop("loglikelihood residuals not implemented yet") else {
sum(w * dplack(x1= y[,1], x2= y[,2], oratio=oratio, log=TRUE))
}
}, list( .link=link, .earg=earg ))),
@@ -1215,7 +1216,7 @@ plackett.control <- function(save.weight=TRUE, ...)
temp3 = dl.doratio
run.var = ((ii-1) * run.var + temp3^2) / ii
}
- wz = if(intercept.only)
+ wz = if (intercept.only)
matrix(colMeans(cbind(run.var)),
n, dimm(M), byrow=TRUE) else cbind(run.var)
@@ -1230,16 +1231,16 @@ plackett.control <- function(save.weight=TRUE, ...)
damh = function(x1, x2, alpha, log=FALSE) {
log.arg = log
rm(log)
- if(!is.Numeric(x1)) stop("bad input for 'x1'")
- if(!is.Numeric(x2)) stop("bad input for 'x2'")
- if(!is.Numeric(alpha)) stop("bad input for 'alpha'")
- if(any(abs(alpha) > 1)) stop("'alpha' values out of range")
+ if (!is.Numeric(x1)) stop("bad input for 'x1'")
+ if (!is.Numeric(x2)) stop("bad input for 'x2'")
+ if (!is.Numeric(alpha)) stop("bad input for 'alpha'")
+ if (any(abs(alpha) > 1)) stop("'alpha' values out of range")
L = max(length(x1), length(x2), length(alpha))
alpha = rep(alpha, len=L)
x1 = rep(x1, len=L)
x2 = rep(x2, len=L)
temp = 1-alpha*(1-x1)*(1-x2)
- if(log.arg) {
+ if (log.arg) {
ans = log1p(-alpha+2*alpha*x1*x2/temp) - 2*log(temp)
ans[(x1 <= 0) | (x1 >= 1) | (x2 <= 0) | (x2 >= 1)] = log(0)
} else {
@@ -1250,20 +1251,20 @@ damh = function(x1, x2, alpha, log=FALSE) {
}
pamh = function(q1, q2, alpha) {
- if(!is.Numeric(q1)) stop("bad input for 'q1'")
- if(!is.Numeric(q2)) stop("bad input for 'q2'")
- if(!is.Numeric(alpha)) stop("bad input for 'alpha'")
- if(any(abs(alpha) > 1)) stop("'alpha' values out of range")
+ if (!is.Numeric(q1)) stop("bad input for 'q1'")
+ if (!is.Numeric(q2)) stop("bad input for 'q2'")
+ if (!is.Numeric(alpha)) stop("bad input for 'alpha'")
+ if (any(abs(alpha) > 1)) stop("'alpha' values out of range")
L = max(length(q1), length(q2), length(alpha))
- if(length(q1) != L) q1 = rep(q1, len=L)
- if(length(q2) != L) q2 = rep(q2, len=L)
- if(length(alpha) != L) alpha = rep(alpha, len=L)
+ if (length(q1) != L) q1 = rep(q1, len=L)
+ if (length(q2) != L) q2 = rep(q2, len=L)
+ if (length(alpha) != L) alpha = rep(alpha, len=L)
x=q1; y=q2
index = (x>=1 & y<1) | (y>=1 & x<1) | (x<=0 | y<=0) | (x>=1 & y>=1)
ans = as.numeric(index)
- if(any(!index)) {
+ if (any(!index)) {
ans[!index] = (q1[!index]*q2[!index]) / (1 -
alpha[!index]*(1-q1[!index])*(1-q2[!index]))
}
@@ -1275,9 +1276,9 @@ pamh = function(q1, q2, alpha) {
}
ramh = function(n, alpha) {
- if(!is.Numeric(n, posit=TRUE, allow=1, integ=TRUE)) stop("bad input for 'n'")
- if(!is.Numeric(alpha)) stop("bad input for 'alpha'")
- if(any(abs(alpha) > 1)) stop("'alpha' values out of range")
+ if (!is.Numeric(n, posit=TRUE, allow=1, integ=TRUE)) stop("bad input for 'n'")
+ if (!is.Numeric(alpha)) stop("bad input for 'alpha'")
+ if (any(abs(alpha) > 1)) stop("'alpha' values out of range")
U1 = V1 = runif(n)
V2 = runif(n)
@@ -1296,14 +1297,14 @@ amh.control <- function(save.weight=TRUE, ...)
amh = function(lalpha="rhobit", ealpha=list(), ialpha=NULL,
method.init=1, nsimEIM=250)
{
- if(mode(lalpha) != "character" && mode(lalpha) != "name")
+ if (mode(lalpha) != "character" && mode(lalpha) != "name")
lalpha = as.character(substitute(lalpha))
- if(!is.list(ealpha)) ealpha = list()
- if(length(ialpha) && (abs(ialpha) > 1))
+ if (!is.list(ealpha)) ealpha = list()
+ if (length(ialpha) && (abs(ialpha) > 1))
stop("'ialpha' should be less than or equal to 1 in absolute value")
- if(!is.Numeric(method.init, allow=1, integ=TRUE, posit=TRUE) ||
+ if (!is.Numeric(method.init, allow=1, integ=TRUE, posit=TRUE) ||
method.init > 2) stop("method.init must be 1 or 2")
- if(length(nsimEIM) &&
+ if (length(nsimEIM) &&
(!is.Numeric(nsimEIM, allow=1, integ=TRUE) || nsimEIM <= 50))
stop("'nsimEIM' should be an integer greater than 50")
@@ -1312,18 +1313,18 @@ amh.control <- function(save.weight=TRUE, ...)
"Links: ",
namesof("alpha", lalpha, earg= ealpha )),
initialize=eval(substitute(expression({
- if(!is.matrix(y) || ncol(y) != 2)
+ if (!is.matrix(y) || ncol(y) != 2)
stop("the response must be a 2 column matrix")
- if(any(y < 0) || any(y > 1))
+ if (any(y < 0) || any(y > 1))
stop("the response must have values in the unit square")
predictors.names=c(namesof("alpha", .lalpha, earg= .ealpha, short=TRUE))
- if(length(dimnames(y)))
+ if (length(dimnames(y)))
extra$dimnamesy2 = dimnames(y)[[2]]
- if(!length(etastart)) {
- ainit = if(length( .ialpha )) .ialpha else {
- mean1 = if( .method.init == 1) weighted.mean(y[,1],w) else
+ if (!length(etastart)) {
+ ainit = if (length( .ialpha )) .ialpha else {
+ mean1 = if ( .method.init == 1) weighted.mean(y[,1],w) else
median(y[,1])
- mean2 = if( .method.init == 1) weighted.mean(y[,2],w) else
+ mean2 = if ( .method.init == 1) weighted.mean(y[,2],w) else
median(y[,2])
Finit = weighted.mean(y[,1] <= mean1 & y[,2] <= mean2, w)
(1 - (mean1 * mean2 / Finit)) / ((1-mean1) * (1-mean2))
@@ -1336,7 +1337,7 @@ amh.control <- function(save.weight=TRUE, ...)
inverse=eval(substitute(function(eta, extra=NULL) {
alpha = eta2theta(eta, .lalpha, earg= .ealpha )
fv.matrix = matrix(0.5, length(alpha), 2)
- if(length(extra$dimnamesy2))
+ if (length(extra$dimnamesy2))
dimnames(fv.matrix) = list(names(eta), extra$dimnamesy2)
fv.matrix
}, list(.lalpha=lalpha, .ealpha=ealpha ))),
@@ -1349,7 +1350,7 @@ amh.control <- function(save.weight=TRUE, ...)
loglikelihood= eval(substitute(
function(mu, y, w, residuals = FALSE, eta, extra=NULL) {
alpha = eta2theta(eta, .lalpha, earg= .ealpha )
- if(residuals) stop("loglikelihood residuals not implemented yet") else {
+ if (residuals) stop("loglikelihood residuals not implemented yet") else {
sum(w * damh(x1=y[,1], x2=y[,2], alpha=alpha, log=TRUE))
}
}, list( .lalpha=lalpha, .earg=ealpha ))),
@@ -1382,7 +1383,7 @@ amh.control <- function(save.weight=TRUE, ...)
temp3 = dl.dalpha
run.var = ((ii-1) * run.var + temp3^2) / ii
}
- wz = if(intercept.only)
+ wz = if (intercept.only)
matrix(colMeans(cbind(run.var)),
n, dimm(M), byrow=TRUE) else cbind(run.var)
wz = wz * dalpha.deta^2
diff --git a/R/family.categorical.q b/R/family.categorical.R
similarity index 81%
rename from R/family.categorical.q
rename to R/family.categorical.R
index cd0ee39..216a5bd 100644
--- a/R/family.categorical.q
+++ b/R/family.categorical.R
@@ -1,5 +1,5 @@
# These functions are
-# Copyright (C) 1998-2009 T.W. Yee, University of Auckland. All rights reserved.
+# Copyright (C) 1998-2010 T.W. Yee, University of Auckland. All rights reserved.
@@ -9,33 +9,33 @@
dmultinomial = function(x, size = NULL, prob, log = FALSE,
dochecking=TRUE, smallno = 1.0e-7) {
- if(!is.logical(log.arg <- log))
+ 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)
+ 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)
+ if (dochecking) {
+ if (min(prob) < 0)
stop("'prob' contains some negative values")
- if(any(abs((rsprob <- rowSums(prob)) - 1) > smallno))
+ 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))
+ if (any(abs(x - round(x)) > smallno))
stop("'x' should be integer valued")
- if(length(size)) {
- if(any(abs(size - rowSums(x)) > smallno))
+ if (length(size)) {
+ if (any(abs(size - rowSums(x)) > smallno))
stop("rowSums(x) does not agree with 'size'")
} else {
size = round(rowSums(x))
}
} else {
- if(!length(size))
+ 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)
+ if (log.arg) logdensity else exp(logdensity)
}
@@ -52,8 +52,7 @@ process.categorical.data.vgam = expression({
-
- if(!is.matrix(y)) {
+ if (!is.matrix(y)) {
yf = as.factor(y)
lev = levels(yf)
llev = length(lev)
@@ -62,39 +61,44 @@ process.categorical.data.vgam = expression({
y[cbind(1:nn,as.vector(unclass(yf)))] = 1
dimnames(y) = list(names(yf), lev)
- if(llev <= 1)
+ if (llev <= 1)
stop("the response matrix does not have 2 or more columns")
} else
nn = nrow(y)
- nvec = drop(y %*% rep(1,ncol(y)))
+ nvec = rowSums(y)
- if(!exists("delete.zero.colns") ||
- (exists("delete.zero.colns") && delete.zero.colns)) {
- sumy2 = as.vector(t(y) %*% rep(1,nrow(y)))
- if(any(index <- sumy2==0)) {
- y = y[,!index,drop = FALSE]
+ 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(paste("Deleted", sum(!index),
- "columns of the response matrix (zero counts)"))
+ 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(any(miss <- nvec==0)) {
- warning(paste(sm <- sum(miss),
- "observation(s) deleted (zero counts)"))
+
+ 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 - sm
+ nn = nn - smiss
}
w = w * nvec
nvec[nvec == 0] = 1
- y = y / nvec # Convert to proportions
+ y = prop.table(y, 1) # Convert to proportions
- if(!length(mustart)) {
+ if (!length(mustart)) {
mustart = (nvec * y + 1/ncol(y)) / (nvec+1)
mustart = y + (1/ncol(y) - y)/nvec
}
@@ -110,7 +114,7 @@ Deviance.categorical.data.vgam <-
- if(ncol(y) == 1 || ncol(mu) == 1)
+ if (ncol(y) == 1 || ncol(mu) == 1)
stop("y and mu must have at least 2 columns")
double.eps = .Machine$double.eps # ^0.75
@@ -118,7 +122,7 @@ Deviance.categorical.data.vgam <-
nz = y != 0
devy[nz] = y[nz] * log(y[nz])
devmu = y * log(mu)
- if(any(small <- mu * (1 - mu) < double.eps)) {
+ if (any((small <- mu * (1 - mu)) < double.eps)) {
warning("fitted values close to 0 or 1")
smu = mu[small]
sy = y[small]
@@ -127,9 +131,9 @@ Deviance.categorical.data.vgam <-
}
devi = 2 * (devy - devmu)
- if(residuals) {
- M = if(is.matrix(eta)) ncol(eta) else 1
- if(M > 1)
+ if (residuals) {
+ M = if (is.matrix(eta)) ncol(eta) else 1
+ if (M > 1)
return(NULL)
devi = devi %*% rep(1, ncol(devi)) # deviance = \sum_i devi[i]
return(c(sign(y[,1] - mu[,1]) * sqrt(abs(devi) * w)))
@@ -144,9 +148,11 @@ Deviance.categorical.data.vgam <-
sratio = function(link="logit", earg=list(),
parallel=FALSE, reverse=FALSE, zero=NULL)
{
- if(mode(link) != "character" && mode(link) != "name")
+ if (mode(link) != "character" && mode(link) != "name")
link = as.character(substitute(link))
- if(!is.list(earg)) earg = list()
+ 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",
@@ -164,21 +170,21 @@ Deviance.categorical.data.vgam <-
delete.zero.colns = TRUE
eval(process.categorical.data.vgam)
M = ncol(y) - 1
- mynames = if( .reverse)
+ 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
+ extra$mymat = if ( .reverse ) tapplymat1(y, "cumsum") else
tapplymat1(y[,ncol(y):1], "cumsum")[,ncol(y):1]
- if(length(dimnames(y)))
+ if (length(dimnames(y)))
extra$dimnamesy2 = dimnames(y)[[2]]
}), list( .earg=earg, .link=link, .reverse=reverse ))),
inverse=eval(substitute( function(eta, extra=NULL) {
- if(!is.matrix(eta))
+ if (!is.matrix(eta))
eta = as.matrix(eta)
fv.matrix =
- if( .reverse ) {
+ if ( .reverse ) {
M = ncol(eta)
djr = eta2theta(eta, .link, earg= .earg )
temp = tapplymat1(1-djr[,M:1], "cumprod")[,M:1]
@@ -188,7 +194,7 @@ Deviance.categorical.data.vgam <-
temp = tapplymat1(1-dj, "cumprod")
cbind(dj,1) * cbind(1, temp)
}
- if(length(extra$dimnamesy2))
+ if (length(extra$dimnamesy2))
dimnames(fv.matrix) = list(dimnames(eta)[[1]], extra$dimnamesy2)
fv.matrix
}, list( .earg=earg, .link=link, .reverse=reverse) )),
@@ -206,26 +212,26 @@ Deviance.categorical.data.vgam <-
}), list( .earg=earg, .link=link, .reverse=reverse ))),
link=eval(substitute( function(mu, extra=NULL) {
cump = tapplymat1(mu, "cumsum")
- if( .reverse ) {
+ 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)]))
+ 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 {
+ if (residuals) stop("loglikelihood residuals not implemented yet") else {
sum(dmultinomial(x=w*y, size=w, prob=mu, log=TRUE, docheck=FALSE))
},
vfamily=c("sratio", "vcategorical"),
deriv=eval(substitute(expression({
- if(!length(extra$mymat)) {
- extra$mymat = if( .reverse ) tapplymat1(y, "cumsum") else
+ if (!length(extra$mymat)) {
+ extra$mymat = if ( .reverse ) tapplymat1(y, "cumsum") else
tapplymat1(y[,ncol(y):1], "cumsum")[,ncol(y):1]
}
- if( .reverse ) {
+ if ( .reverse ) {
djr = eta2theta(eta, .link, earg= .earg )
Mp1 = ncol(extra$mymat)
w * (y[,-1]/djr - extra$mymat[,-Mp1]/(1-djr)) *
@@ -237,7 +243,7 @@ Deviance.categorical.data.vgam <-
}
}), list( .earg=earg, .link=link, .reverse=reverse) )),
weight= eval(substitute(expression({
- if( .reverse ) {
+ if ( .reverse ) {
cump = tapplymat1(mu, "cumsum")
ddjr.deta = dtheta.deta(djr, .link, earg= .earg )
wz = w * ddjr.deta^2 * (mu[,-1]/djr^2 + cump[,1:M]/(1-djr)^2)
@@ -257,9 +263,11 @@ Deviance.categorical.data.vgam <-
cratio = function(link="logit", earg=list(),
parallel=FALSE, reverse=FALSE, zero=NULL)
{
- if(mode(link) != "character" && mode(link) != "name")
+ if (mode(link) != "character" && mode(link) != "name")
link = as.character(substitute(link))
- if(!is.list(earg)) earg = list()
+ 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",
@@ -277,21 +285,21 @@ Deviance.categorical.data.vgam <-
delete.zero.colns = TRUE
eval(process.categorical.data.vgam)
M = ncol(y) - 1
- mynames = if( .reverse )
+ 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
+ extra$mymat = if ( .reverse ) tapplymat1(y, "cumsum") else
tapplymat1(y[,ncol(y):1], "cumsum")[,ncol(y):1]
- if(length(dimnames(y)))
+ if (length(dimnames(y)))
extra$dimnamesy2 = dimnames(y)[[2]]
}), list( .earg=earg, .link=link, .reverse=reverse ))),
inverse=eval(substitute( function(eta, extra=NULL) {
- if(!is.matrix(eta))
+ if (!is.matrix(eta))
eta = as.matrix(eta)
fv.matrix =
- if( .reverse ) {
+ if ( .reverse ) {
M = ncol(eta)
djrs = eta2theta(eta, .link, earg= .earg )
temp = tapplymat1(djrs[,M:1], "cumprod")[,M:1]
@@ -301,7 +309,7 @@ Deviance.categorical.data.vgam <-
temp = tapplymat1(djs, "cumprod")
cbind(1-djs,1) * cbind(1, temp)
}
- if(length(extra$dimnamesy2))
+ if (length(extra$dimnamesy2))
dimnames(fv.matrix) = list(dimnames(eta)[[1]], extra$dimnamesy2)
fv.matrix
}, list( .earg=earg, .link=link, .reverse=reverse) )),
@@ -317,26 +325,26 @@ Deviance.categorical.data.vgam <-
}), list( .earg=earg, .link=link, .reverse=reverse ))),
link=eval(substitute( function(mu, extra=NULL) {
cump = tapplymat1(mu, "cumsum")
- if( .reverse ) {
+ 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)]))
+ 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 {
+ if (residuals) stop("loglikelihood residuals not implemented yet") else {
sum(w * y * log(mu))
},
vfamily=c("cratio", "vcategorical"),
deriv=eval(substitute(expression({
- if(!length(extra$mymat)) {
- extra$mymat = if( .reverse ) tapplymat1(y, "cumsum") else
+ if (!length(extra$mymat)) {
+ extra$mymat = if ( .reverse ) tapplymat1(y, "cumsum") else
tapplymat1(y[,ncol(y):1], "cumsum")[,ncol(y):1]
}
- if( .reverse ) {
+ if ( .reverse ) {
djrs = eta2theta(eta, .link, earg= .earg )
Mp1 = ncol(extra$mymat)
-w * (y[,-1]/(1-djrs) - extra$mymat[,-Mp1]/djrs) *
@@ -348,7 +356,7 @@ Deviance.categorical.data.vgam <-
}
}), list( .earg=earg, .link=link, .reverse=reverse) )),
weight= eval(substitute(expression({
- if( .reverse ) {
+ if ( .reverse ) {
cump = tapplymat1(mu, "cumsum")
ddjrs.deta = dtheta.deta(djrs, .link, earg= .earg )
wz = w * ddjrs.deta^2 * (mu[,-1]/(1-djrs)^2 + cump[,1:M]/djrs^2)
@@ -367,7 +375,7 @@ Deviance.categorical.data.vgam <-
vglm.multinomial.deviance.control = function(maxit=21, panic=FALSE, ...)
{
- if(maxit < 1) {
+ if (maxit < 1) {
warning("bad value of maxit; using 21 instead")
maxit = 21
}
@@ -377,12 +385,12 @@ vglm.multinomial.deviance.control = function(maxit=21, panic=FALSE, ...)
vglm.multinomial.control = function(maxit=21, panic=FALSE,
criterion=c("aic1", "aic2", names( .min.criterion.VGAM )), ...)
{
- if(mode(criterion) != "character" && mode(criterion) != "name")
+ if (mode(criterion) != "character" && mode(criterion) != "name")
criterion = as.character(substitute(criterion))
criterion = match.arg(criterion,
c("aic1", "aic2", names( .min.criterion.VGAM )))[1]
- if(maxit < 1) {
+ if (maxit < 1) {
warning("bad value of maxit; using 21 instead")
maxit = 21
}
@@ -394,7 +402,7 @@ vglm.multinomial.control = function(maxit=21, panic=FALSE,
vglm.vcategorical.control = function(maxit=30, trace=FALSE, panic=TRUE, ...)
{
- if(maxit < 1) {
+ if (maxit < 1) {
warning("bad value of maxit; using 200 instead")
maxit = 200
}
@@ -406,24 +414,24 @@ vglm.vcategorical.control = function(maxit=30, trace=FALSE, panic=TRUE, ...)
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"')
+ 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")
+ } 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, allow=1, integer=TRUE, posit=TRUE))
+ if (!is.Numeric(refLevel, allow=1, integer=TRUE, posit=TRUE))
stop("could not coerce 'refLevel' into a single positive integer")
- } else if(!is.Numeric(refLevel, allow=1, integer=TRUE, posit=TRUE))
+ } else if (!is.Numeric(refLevel, allow=1, integer=TRUE, posit=TRUE))
stop("'refLevel' must be a single positive integer")
new("vglmff",
blurb=c("Multinomial logit model\n\n",
- if(refLevel < 0)
+ if (refLevel < 0)
"Links: log(mu[,j]/mu[,M+1]), j=1:M,\n" else {
- if(refLevel==1)
+ if (refLevel==1)
paste("Links: log(mu[,j]/mu[,", refLevel,
"]), j=2:(M+1),\n", sep="") else
paste("Links: log(mu[,j]/mu[,", refLevel,
@@ -449,8 +457,8 @@ vglm.vcategorical.control = function(maxit=30, trace=FALSE, panic=TRUE, ...)
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))
+ 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,
@@ -458,51 +466,51 @@ vglm.vcategorical.control = function(maxit=30, trace=FALSE, panic=TRUE, ...)
y.names = paste("mu", 1:(M+1), sep="")
}), list( .refLevel = refLevel ))),
inverse=eval(substitute( function(eta, extra=NULL) {
- if(any(is.na(eta)))
+ if (any(is.na(eta)))
warning("there are NAs in eta in slot inverse")
M = ncol(cbind(eta))
- if( (.refLevel < 0) || (.refLevel == M+1)) {
+ if ( (.refLevel < 0) || (.refLevel == M+1)) {
phat = cbind(exp(eta), 1)
- } else if( .refLevel == 1) {
+ } else if ( .refLevel == 1) {
phat = cbind(1, exp(eta))
} else {
- use.refLevel = if( .refLevel < 0) M+1 else .refLevel
+ 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)))
+ 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$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]]))
+ if (!is.null(dy[[2]]))
dimnames(fit$fitted.values) = dy
}), list( .refLevel = refLevel ))),
link=eval(substitute( function(mu, extra=NULL) {
- if( .refLevel < 0) {
+ if ( .refLevel < 0) {
log(mu[,-ncol(mu)] / mu[,ncol(mu)])
} else {
- use.refLevel = if( .refLevel < 0) ncol(mu) else .refLevel
+ 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 {
+ if (residuals) stop("loglikelihood residuals not implemented yet") else {
sum(dmultinomial(x=w*y, size=w, prob=mu, log=TRUE, docheck=FALSE))
},
vfamily=c("multinomial", "vcategorical"),
deriv=eval(substitute(expression({
- if( .refLevel < 0) {
+ if ( .refLevel < 0) {
w * (y[,-ncol(y)] - mu[,-ncol(y)])
} else {
- use.refLevel = if( .refLevel < 0) M+1 else .refLevel
+ use.refLevel = if ( .refLevel < 0) M+1 else .refLevel
w * (y[,-use.refLevel] - mu[,-use.refLevel])
}
}), list( .refLevel=refLevel ))),
@@ -510,9 +518,9 @@ vglm.vcategorical.control = function(maxit=30, trace=FALSE, panic=TRUE, ...)
mytiny = (mu < sqrt(.Machine$double.eps)) |
(mu > 1 - 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 {
+ 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
@@ -524,8 +532,8 @@ vglm.vcategorical.control = function(maxit=30, trace=FALSE, panic=TRUE, ...)
}
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) +
+ 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
@@ -541,10 +549,13 @@ vglm.vcategorical.control = function(maxit=30, trace=FALSE, panic=TRUE, ...)
mv=FALSE,
intercept.apply = FALSE)
{
- if(mode(link) != "character" && mode(link) != "name")
+ if (mode(link) != "character" && mode(link) != "name")
link = as.character(substitute(link))
- if(!is.logical(mv) || length(mv)!=1) stop("'mv' must be a single logical")
- if(!is.list(earg)) earg = list()
+ 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"),
@@ -555,8 +566,8 @@ vglm.vcategorical.control = function(maxit=30, trace=FALSE, panic=TRUE, ...)
"Links: ",
namesof(if(reverse) "P[Y>=j+1]" else "P[Y<=j]", link, earg=earg)),
constraints=eval(substitute(expression({
- if( .mv ) {
- if( !length(constraints) ) {
+ if ( .mv ) {
+ if ( !length(constraints) ) {
Llevels = extra$Llevels
NOS = extra$NOS
Hk.matrix = kronecker(diag(NOS), matrix(1,Llevels-1,1))
@@ -571,7 +582,7 @@ vglm.vcategorical.control = function(maxit=30, trace=FALSE, panic=TRUE, ...)
deviance=eval(substitute(
function(mu, y, w, residuals=FALSE, eta, extra=NULL) {
answer =
- if( .mv ) {
+ if ( .mv ) {
totdev = 0
NOS = extra$NOS
Llevels = extra$Llevels
@@ -592,13 +603,13 @@ vglm.vcategorical.control = function(maxit=30, trace=FALSE, panic=TRUE, ...)
}, list( .earg=earg, .link=link, .mv = mv ) )),
initialize=eval(substitute(expression({
- if(colnames(x)[1] != "(Intercept)")
+ if (colnames(x)[1] != "(Intercept)")
stop("there is no intercept term!")
extra$mv = .mv
- if( .mv ) {
+ if ( .mv ) {
checkCut(y) # Check the input; stops if there is an error.
- if(any(w != 1) || ncol(cbind(w)) != 1)
+ 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
@@ -618,7 +629,7 @@ vglm.vcategorical.control = function(maxit=30, trace=FALSE, panic=TRUE, ...)
for(iii in 1:NOS) {
Y.names = paste("Y", iii, sep="")
mu.names = paste("mu", iii, ".", sep="")
- mynames = c(mynames, if( .reverse )
+ 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=""))
@@ -630,29 +641,29 @@ vglm.vcategorical.control = function(maxit=30, trace=FALSE, panic=TRUE, ...)
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
+ 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 (ncol(cbind(w)) == 1) {
for(iii in 1:ncol(y))
mustart[,iii] = weighted.mean(y[,iii], w)
}
- if(length(dimnames(y)))
+ if (length(dimnames(y)))
extra$dimnamesy2 = dimnames(y)[[2]]
}
}), list( .link=link, .reverse=reverse, .mv = mv, .earg = earg ))),
inverse=eval(substitute( function(eta, extra=NULL) {
answer =
- if( .mv ) {
+ if ( .mv ) {
NOS = extra$NOS
Llevels = extra$Llevels
fv.matrix = matrix(0, nrow(eta), NOS*Llevels)
for(iii in 1:NOS) {
cindex = (iii-1)*(Llevels-1) + 1:(Llevels-1)
aindex = (iii-1)*(Llevels) + 1:(Llevels)
- if( .reverse ) {
+ if ( .reverse ) {
ccump = cbind(1,eta2theta(eta[,cindex,drop=FALSE], .link,
earg= .earg))
fv.matrix[,aindex] =
@@ -667,21 +678,21 @@ vglm.vcategorical.control = function(maxit=30, trace=FALSE, panic=TRUE, ...)
fv.matrix
} else {
fv.matrix =
- if( .reverse ) {
+ if ( .reverse ) {
ccump = cbind(1, eta2theta(eta, .link, earg= .earg))
cbind(-tapplymat1(ccump, "diff"), ccump[,ncol(ccump)])
} else {
cump = cbind(eta2theta(eta, .link, earg= .earg), 1)
cbind(cump[,1], tapplymat1(cump, "diff"))
}
- if(length(extra$dimnamesy2))
+ if (length(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 ) {
+ if ( .mv ) {
misc$link = .link
misc$earg = list( .earg )
} else {
@@ -700,7 +711,7 @@ vglm.vcategorical.control = function(maxit=30, trace=FALSE, panic=TRUE, ...)
.mv = mv, .earg= earg ))),
link=eval(substitute( function(mu, extra=NULL) {
answer =
- if( .mv ) {
+ if ( .mv ) {
NOS = extra$NOS
Llevels = extra$Llevels
eta.matrix = matrix(0, nrow(mu), NOS*(Llevels-1))
@@ -722,14 +733,14 @@ vglm.vcategorical.control = function(maxit=30, trace=FALSE, panic=TRUE, ...)
answer
}, list( .link=link, .reverse=reverse, .earg=earg, .mv=mv ))),
loglikelihood= function(mu, y, w, residuals = FALSE, eta, extra=NULL)
- if(residuals) stop("loglikelihood residuals not implemented yet") else {
+ if (residuals) stop("loglikelihood residuals not implemented yet") else {
sum(dmultinomial(x=w*y, size=w, prob=mu, log=TRUE, docheck=FALSE))
},
vfamily=c("cumulative", "vcategorical"),
deriv=eval(substitute(expression({
mu.use = pmax(mu, .Machine$double.eps * 1.0e-0)
deriv.answer =
- if( .mv ) {
+ if ( .mv ) {
NOS = extra$NOS
Llevels = extra$Llevels
dcump.deta = resmat = matrix(0, n, NOS * (Llevels-1))
@@ -752,7 +763,7 @@ vglm.vcategorical.control = function(maxit=30, trace=FALSE, panic=TRUE, ...)
deriv.answer
}), list( .link=link, .reverse=reverse, .earg= earg, .mv=mv ))),
weight= eval(substitute(expression({
- if( .mv ) {
+ if ( .mv ) {
NOS = extra$NOS
Llevels = extra$Llevels
wz = matrix(0, n, NOS*(Llevels-1)) # Diagonal elts only for a start
@@ -762,13 +773,13 @@ vglm.vcategorical.control = function(maxit=30, trace=FALSE, panic=TRUE, ...)
wz[,cindex] = w * dcump.deta[,cindex,drop=FALSE]^2 *
(1/mu.use[,aindex,drop=FALSE] + 1/mu.use[,1+aindex,drop=FALSE])
}
- if(Llevels-1 > 1) {
+ if (Llevels-1 > 1) {
iii = 1
oindex = (iii-1)*(Llevels-1) + 1:(Llevels-2)
wz = cbind(wz, -w * dcump.deta[,oindex] * dcump.deta[,1+oindex])
- if(NOS > 1) {
+ 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) {
@@ -785,7 +796,7 @@ vglm.vcategorical.control = function(maxit=30, trace=FALSE, panic=TRUE, ...)
}
} else {
wz = w * dcump.deta^2 * (1/mu.use[,1:M] + 1/mu.use[,-1])
- if(M > 1)
+ if (M > 1)
wz = cbind(wz, -w * dcump.deta[,-M] *
dcump.deta[,2:M] / mu.use[,2:M])
}
@@ -795,12 +806,25 @@ vglm.vcategorical.control = function(maxit=30, trace=FALSE, panic=TRUE, ...)
+
+
+ propodds = function(reverse=TRUE) {
+ if (!is.logical(reverse) || length(reverse) != 1)
+ stop("argument 'reverse' must be a single logical")
+
+ cumulative(parallel=TRUE, reverse=reverse)
+}
+
+
+
acat = function(link="loge", earg = list(),
parallel=FALSE, reverse=FALSE, zero=NULL)
{
- if(mode(link) != "character" && mode(link) != "name")
+ if (mode(link) != "character" && mode(link) != "name")
link = as.character(substitute(link))
- if(!is.list(earg)) earg = list()
+ 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",
@@ -819,20 +843,20 @@ vglm.vcategorical.control = function(maxit=30, trace=FALSE, panic=TRUE, ...)
delete.zero.colns = TRUE
eval(process.categorical.data.vgam)
M = ncol(y) - 1
- mynames = if( .reverse )
+ 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)))
+ if (length(dimnames(y)))
extra$dimnamesy2 = dimnames(y)[[2]]
}), list( .earg=earg, .link=link, .reverse=reverse ))),
inverse=eval(substitute( function(eta, extra=NULL) {
- if(!is.matrix(eta))
+ if (!is.matrix(eta))
eta = as.matrix(eta)
M = ncol(eta)
fv.matrix =
- if( .reverse ) {
+ 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)))
@@ -841,7 +865,7 @@ vglm.vcategorical.control = function(maxit=30, trace=FALSE, panic=TRUE, ...)
temp = tapplymat1(zeta, "cumprod")
cbind(1,temp) / drop(1 + temp %*% rep(1,ncol(temp)))
}
- if(length(extra$dimnamesy2))
+ if (length(extra$dimnamesy2))
dimnames(fv.matrix) = list(dimnames(eta)[[1]], extra$dimnamesy2)
fv.matrix
}, list( .earg=earg, .link=link, .reverse=reverse) )),
@@ -862,7 +886,7 @@ vglm.vcategorical.control = function(maxit=30, trace=FALSE, panic=TRUE, ...)
.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 {
+ if (residuals) stop("loglikelihood residuals not implemented yet") else {
sum(dmultinomial(x=w*y, size=w, prob=mu, log=TRUE, docheck=FALSE))
},
vfamily=c("acat", "vcategorical"),
@@ -871,7 +895,7 @@ vglm.vcategorical.control = function(maxit=30, trace=FALSE, panic=TRUE, ...)
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 ) {
+ if ( .reverse ) {
cumy = tapplymat1(y, "cumsum")
w * dzeta.deta * (cumy[,1:M]/zeta - score)
} else {
@@ -884,12 +908,12 @@ vglm.vcategorical.control = function(maxit=30, trace=FALSE, panic=TRUE, ...)
hess = attr(d1, "hessian") / d1
- if(M>1)
+ 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 ) {
+ if ( .reverse ) {
cump = tapplymat1(mu, "cumsum")
wz[,1:M] = (cump[,1:M]/zeta^2 - score^2) * dzeta.deta^2
} else {
@@ -900,12 +924,13 @@ vglm.vcategorical.control = function(maxit=30, trace=FALSE, panic=TRUE, ...)
}), list( .earg=earg, .link=link, .reverse=reverse ))))
}
+
acat.deriv = function(zeta, reverse, M, n)
{
alltxt = NULL
for(ii in 1:M) {
- index = if(reverse) ii:M else 1:ii
+ index = if (reverse) ii:M else 1:ii
vars = paste("zeta", index, sep="")
txt = paste(vars, collapse="*")
alltxt = c(alltxt, txt)
@@ -932,11 +957,11 @@ acat.deriv = function(zeta, reverse, M, n)
refvalue = 1,
init.alpha = 1)
{
- if(!is.Numeric(init.alpha, posit=TRUE))
+ if (!is.Numeric(init.alpha, posit=TRUE))
stop("'init.alpha' must contain positive values only")
- if(!is.Numeric(refvalue, allow=1, posit=TRUE))
+ if (!is.Numeric(refvalue, allow=1, posit=TRUE))
stop("'refvalue' must be a single positive value")
- if(!is.character(refgp) &&
+ if (!is.character(refgp) &&
!is.Numeric(refgp, allow=1, integer=TRUE, posit=TRUE))
stop("'refgp' must be a single positive integer")
@@ -946,19 +971,19 @@ acat.deriv = function(zeta, reverse, M, n)
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)
+ 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'")
+ 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)
+ 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 ) ]
+ 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 ))),
@@ -982,13 +1007,13 @@ acat.deriv = function(zeta, reverse, M, n)
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 {
+ if (residuals) stop("loglikelihood residuals not implemented yet") else {
sum(dmultinomial(x=w*y, size=w, prob=mu, log=TRUE, docheck=FALSE))
},
vfamily=c("brat"),
deriv=eval(substitute(expression({
ans = NULL
- uindex = if( .refgp =="last") 1:M else (1:(M+1))[-( .refgp ) ]
+ 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()),
@@ -1016,7 +1041,7 @@ acat.deriv = function(zeta, reverse, M, n)
(ymat[aa,uindex] + ymat[uindex,aa]) * alpha[aa] *
alpha[uindex] / (alpha[aa] + alpha[uindex])^2
}
- if(M > 1) {
+ 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])] +
@@ -1038,13 +1063,13 @@ bratt = function(refgp="last",
init.alpha = 1,
i0 = 0.01)
{
- if(!is.Numeric(i0, allow=1, positi=TRUE))
+ if (!is.Numeric(i0, allow=1, positi=TRUE))
stop("'i0' must be a single positive value")
- if(!is.Numeric(init.alpha, positi=TRUE))
+ if (!is.Numeric(init.alpha, positi=TRUE))
stop("'init.alpha' must contain positive values only")
- if(!is.Numeric(refvalue, allow=1, positi=TRUE))
+ if (!is.Numeric(refvalue, allow=1, positi=TRUE))
stop("'refvalue' must be a single positive value")
- if(!is.character(refgp) &&
+ if (!is.character(refgp) &&
!is.Numeric(refgp, allow=1, integer=TRUE, positi=TRUE))
stop("'refgp' must be a single positive integer")
new("vglmff",
@@ -1054,12 +1079,12 @@ bratt = function(refgp="last",
initialize=eval(substitute(expression({
try.index = 1:400
M = (1:length(try.index))[(try.index*(try.index-1)) == ncol(y)]
- if(!is.Numeric(M, allow=1, integ=TRUE)) stop("cannot determine 'M'")
+ if (!is.Numeric(M, allow=1, integ=TRUE)) stop("cannot determine 'M'")
NCo = M # number of contestants
are.ties = attr(y, "are.ties") # If Brat() was used
- if(is.logical(are.ties)) {
- if(!are.ties)
+ if (is.logical(are.ties)) {
+ if (!are.ties)
stop("use brat(), not bratt(), when there are no ties")
ties = attr(y, "ties")
} else {
@@ -1073,13 +1098,13 @@ bratt = function(refgp="last",
n, NCo-1, byrow=TRUE),
theta2eta( rep(ialpha0, len=n), "loge"))
refgp = .refgp
- if(!intercept.only)
+ 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 ]
+ uindex = if (refgp=="last") 1:(NCo-1) else (1:(NCo))[-refgp ]
predictors.names=c(
namesof(paste("alpha",uindex,sep=""),"loge",short=TRUE),
@@ -1098,7 +1123,7 @@ bratt = function(refgp="last",
probs = rbind(probs, alpha1/(alpha1+alpha2+alpha0)) #
qprobs = rbind(qprobs, alpha0/(alpha1+alpha2+alpha0)) #
}
- if(length(extra$dnties))
+ if (length(extra$dnties))
dimnames(qprobs) = extra$dnties
attr(probs, "probtie") = qprobs
probs
@@ -1112,7 +1137,7 @@ bratt = function(refgp="last",
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 {
+ if (residuals) stop("loglikelihood residuals not implemented yet") else {
sum(w * (y * log(mu) + 0.5 * extra$ties * log(attr(mu, "probtie"))))
},
vfamily=c("bratt"),
@@ -1120,7 +1145,7 @@ bratt = function(refgp="last",
ans = NULL
ties = extra$ties
NCo = M
- uindex = if( .refgp =="last") 1:(M-1) else (1:(M))[-( .refgp )]
+ 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)
@@ -1162,7 +1187,7 @@ bratt = function(refgp="last",
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)
+ 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
@@ -1171,7 +1196,7 @@ bratt = function(refgp="last",
(1-qab) / (qab * Dab^2)
}
}
- if(NCo > 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])
@@ -1195,18 +1220,18 @@ bratt = function(refgp="last",
.brat.alpha = function(vec, value, posn) {
- if(is.character(posn))
- if(posn!="last")
+ if (is.character(posn))
+ if (posn!="last")
stop("can only handle \"last\"") else return(c(vec, value))
c(if(posn==1) NULL else vec[1:(posn-1)], value,
- if(posn==length(vec)+1) NULL else vec[posn:length(vec)])
+ if (posn==length(vec)+1) NULL else vec[posn:length(vec)])
}
.brat.indices = function(NCo, are.ties=FALSE) {
- if(!is.Numeric(NCo, allow=1, integ=TRUE) || NCo < 2)
+ if (!is.Numeric(NCo, allow=1, integ=TRUE) || NCo < 2)
stop("bad input for 'NCo'")
m = diag(NCo)
- if(are.ties) {
+ if (are.ties) {
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)])
@@ -1215,22 +1240,22 @@ bratt = function(refgp="last",
Brat = function(mat, ties=0*mat, string=c(" > "," == ")) {
allargs = list(mat) # ,...
- callit = if(length(names(allargs))) names(allargs) else
+ 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])
+ 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)))
+ 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)))
+ if (any(is.na(m)))
stop("missing values not allowed (except on the diagonal)")
diag(m) = NA
@@ -1262,19 +1287,19 @@ InverseBrat = function(yvec, NCo=
for(mul in 1:multiplicity)
for(i1 in 1:(NCo))
for(i2 in 1:(NCo))
- if(i1 != i2) {
+ if (i1 != i2) {
ans[i2,i1,mul] = yvec[ptr]
ptr = ptr + 1
}
- ans = if(multiplicity>1) ans else matrix(ans, NCo, NCo)
+ ans = if (multiplicity>1) ans else matrix(ans, NCo, NCo)
- if(is.array(yvec.orig) || is.matrix(yvec.orig)) {
+ 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) {
+ if (multiplicity>1) {
dimnames(ans) = list(cal, cal, dimnames(yvec.orig)[[1]])
} else
dimnames(ans) = list(cal, cal)
@@ -1289,14 +1314,14 @@ tapplymat1 = function(mat, function.arg=c("cumsum", "diff", "cumprod"))
{
- if(!missing(function.arg))
+ if (!missing(function.arg))
function.arg = as.character(substitute(function.arg))
function.arg = match.arg(function.arg, c("cumsum", "diff", "cumprod"))[1]
type = switch(function.arg, cumsum=1, diff=2, cumprod=3,
stop("function.arg not matched"))
- if(!is.matrix(mat))
+ if (!is.matrix(mat))
mat = as.matrix(mat)
nr = nrow(mat)
nc = ncol(mat)
@@ -1318,21 +1343,21 @@ tapplymat1 = function(mat, function.arg=c("cumsum", "diff", "cumprod"))
countdata=FALSE, NOS=NULL, Levels=NULL,
init.mu = NULL, parallel=FALSE, zero=NULL,
link="loge", earg = list()) {
- if(mode(link) != "character" && mode(link) != "name")
+ if (mode(link) != "character" && mode(link) != "name")
link = as.character(substitute(link))
- if(!is.list(earg)) earg = list()
+ if (!is.list(earg)) earg = list()
fcutpoints = cutpoints[is.finite(cutpoints)]
- if(!is.Numeric(fcutpoints, integ=TRUE) || any(fcutpoints < 0))
+ if (!is.Numeric(fcutpoints, integ=TRUE) || any(fcutpoints < 0))
stop("'cutpoints' must have non-negative integer or Inf values only")
- if(is.finite(cutpoints[length(cutpoints)]))
+ if (is.finite(cutpoints[length(cutpoints)]))
cutpoints = c(cutpoints, Inf)
- if(!is.logical(countdata) || length(countdata)!=1)
- stop("'countdata' must be a single logical")
- if(countdata) {
- if(!is.Numeric(NOS, integ=TRUE, posit=TRUE))
+ if (!is.logical(countdata) || length(countdata) != 1)
+ stop("argument 'countdata' must be a single logical")
+ if (countdata) {
+ if (!is.Numeric(NOS, integ=TRUE, posit=TRUE))
stop("'NOS' must have integer values only")
- if(!is.Numeric(Levels, integ=TRUE, posit=TRUE) || any(Levels < 2))
+ if (!is.Numeric(Levels, integ=TRUE, posit=TRUE) || any(Levels < 2))
stop("'Levels' must have integer values (>= 2) only")
Levels = rep(Levels, length=NOS)
}
@@ -1347,17 +1372,17 @@ tapplymat1 = function(mat, function.arg=c("cumsum", "diff", "cumprod"))
}), list( .parallel=parallel, .zero=zero ))),
initialize=eval(substitute(expression({
orig.y = cbind(y) # Convert y into a matrix if necessary
- if( .countdata ) {
+ if ( .countdata ) {
extra$NOS = M = NOS = .NOS
extra$Levels = Levels = .Levels
y.names = dimnames(y)[[2]] # Hopefully the user inputted them
} else {
- if(any(w != 1) || ncol(cbind(w)) != 1)
+ if (any(w != 1) || ncol(cbind(w)) != 1)
stop("the 'weights' argument must be a vector of all ones")
- extra$NOS = M = NOS = if(is.Numeric( .NOS )) .NOS else
+ extra$NOS = M = NOS = if (is.Numeric( .NOS )) .NOS else
ncol(orig.y)
- Levels = rep( if(is.Numeric( .Levels )) .Levels else 0, len=NOS)
- if(!is.Numeric( .Levels ))
+ 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])))
}
@@ -1365,19 +1390,19 @@ tapplymat1 = function(mat, function.arg=c("cumsum", "diff", "cumprod"))
}
- 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))
+ use.y = if ( .countdata ) y else matrix(0, n, sum(Levels))
use.etastart = matrix(0, n, M)
cptr = 1
for(iii in 1:NOS) {
y = factor(orig.y[,iii], levels=(1:Levels[iii]))
- if( !( .countdata )) {
+ if ( !( .countdata )) {
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]
}
@@ -1394,7 +1419,7 @@ tapplymat1 = function(mat, function.arg=c("cumsum", "diff", "cumprod"))
extra$countdata = .countdata
extra$cutpoints = cp.vector
extra$n = n
- mynames = if(M > 1) paste("mu",1:M,sep="") else "mu"
+ mynames = if (M > 1) paste("mu",1:M,sep="") else "mu"
predictors.names = namesof(mynames, .link, short=TRUE, earg= .earg)
}), list( .link=link, .countdata = countdata, .earg = earg,
.cutpoints=cutpoints, .NOS=NOS, .Levels=Levels,
@@ -1406,7 +1431,7 @@ tapplymat1 = function(mat, function.arg=c("cumsum", "diff", "cumprod"))
mu
}, list( .link=link, .earg= earg, .countdata = countdata ))),
last=eval(substitute(expression({
- if( .countdata ) {
+ if ( .countdata ) {
misc$link = .link
misc$earg = list( .earg )
} else {
@@ -1421,7 +1446,7 @@ tapplymat1 = function(mat, function.arg=c("cumsum", "diff", "cumprod"))
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) {
- if(residuals) stop("loglikelihood residuals not implemented yet") else {
+ if (residuals) stop("loglikelihood residuals not implemented yet") else {
probs = ordpoissonProbs(extra, mu)
index0 = y == 0
probs[index0] = 1
@@ -1470,7 +1495,7 @@ tapplymat1 = function(mat, function.arg=c("cumsum", "diff", "cumprod"))
ordpoissonProbs = function(extra, mu, deriv=0) {
cp.vector = extra$cutpoints
NOS = extra$NOS
- if(deriv == 1) {
+ if (deriv == 1) {
dprob.dmu = matrix(0, extra$n, extra$ncoly)
} else {
probs = matrix(0, extra$n, extra$ncoly)
@@ -1478,14 +1503,14 @@ ordpoissonProbs = function(extra, mu, deriv=0) {
mu = cbind(mu)
cptr = 1
for(iii in 1:NOS) {
- if(deriv == 1) {
+ if (deriv == 1) {
dprob.dmu[,cptr] = -dpois(x=cp.vector[cptr], lamb=mu[,iii])
} else {
probs[,cptr] = ppois(q=cp.vector[cptr], lambda=mu[,iii])
}
cptr = cptr + 1
while(is.finite(cp.vector[cptr])) {
- if(deriv == 1) {
+ if (deriv == 1) {
dprob.dmu[,cptr] = dpois(x=cp.vector[cptr-1], lamb=mu[,iii]) -
dpois(x=cp.vector[cptr], lambda=mu[,iii])
} else {
@@ -1494,7 +1519,7 @@ ordpoissonProbs = function(extra, mu, deriv=0) {
}
cptr = cptr + 1
}
- if(deriv == 1) {
+ if (deriv == 1) {
dprob.dmu[,cptr] = dpois(x=cp.vector[cptr-1], lamb=mu[,iii]) -
dpois(x=cp.vector[cptr], lambda=mu[,iii])
} else {
@@ -1503,7 +1528,7 @@ ordpoissonProbs = function(extra, mu, deriv=0) {
}
cptr = cptr + 1
}
- if(deriv == 1) dprob.dmu else probs
+ if (deriv == 1) dprob.dmu else probs
}
@@ -1511,22 +1536,23 @@ ordpoissonProbs = function(extra, mu, deriv=0) {
- if(FALSE)
+ if (FALSE)
scumulative = function(link="logit", earg = list(),
lscale="loge", escale = list(),
parallel=FALSE, sparallel=TRUE, reverse=FALSE,
iscale = 1)
{
stop("sorry, not working yet")
- if(mode(link) != "character" && mode(link) != "name")
+ if (mode(link) != "character" && mode(link) != "name")
link = as.character(substitute(link))
- if(!is.list(earg)) earg = list()
- if(mode(lscale) != "character" && mode(lscale) != "name")
+ if (!is.list(earg)) earg = list()
+ if (mode(lscale) != "character" && mode(lscale) != "name")
lscale = as.character(substitute(lscale))
- if(!is.list(escale)) escale = list()
- if(!is.Numeric(iscale, posit=TRUE))
+ if (!is.list(escale)) escale = list()
+ if (!is.Numeric(iscale, posit=TRUE))
stop("bad input for argument 'iscale'")
-
+ if (!is.logical(reverse) || length(reverse) != 1)
+ stop("argument 'reverse' must be a single logical")
new("vglmff",
blurb=c(paste("Scaled cumulative", link, "model\n\n"),
@@ -1562,14 +1588,14 @@ ordpoissonProbs = function(extra, mu, deriv=0) {
answer
}, list( .earg=earg, .link=link ) )),
initialize=eval(substitute(expression({
- if(intercept.only)
+ if (intercept.only)
stop("use cumulative() for intercept-only models")
delete.zero.colns = TRUE # Cannot have FALSE since then prob(Y=jay)=0
eval(process.categorical.data.vgam)
M = 2*(ncol(y)-1)
J = M / 2
extra$J = J
- mynames = if( .reverse ) paste("P[Y>=",2:(1+J),"]", sep="") else
+ 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),
@@ -1577,7 +1603,7 @@ ordpoissonProbs = function(extra, mu, deriv=0) {
.lscale, short=TRUE, earg= .escale))
y.names = paste("mu", 1:(J+1), sep="")
- if(length(dimnames(y)))
+ if (length(dimnames(y)))
extra$dimnamesy2 = dimnames(y)[[2]]
predictors.names = predictors.names[interleave.VGAM(M, M=2)]
@@ -1591,14 +1617,14 @@ ordpoissonProbs = function(extra, mu, deriv=0) {
etamat2 = eta[,2*(1:J), drop=FALSE]
scalemat = eta2theta(etamat2, .lscale, earg= .escale)
fv.matrix =
- if( .reverse ) {
+ if ( .reverse ) {
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)
cbind(cump[,1], tapplymat1(cump, "diff"))
}
- if(length(extra$dimnamesy2))
+ if (length(extra$dimnamesy2))
dimnames(fv.matrix) = list(dimnames(eta)[[1]], extra$dimnamesy2)
fv.matrix
}, list( .link=link, .lscale=lscale, .reverse=reverse,
@@ -1633,7 +1659,7 @@ ordpoissonProbs = function(extra, mu, deriv=0) {
}, 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 {
+ if (residuals) stop("loglikelihood residuals not implemented yet") else {
sum(dmultinomial(x=w*y, size=w, prob=mu, log=TRUE, docheck=FALSE))
},
vfamily=c("scumulative", "vcategorical"),
@@ -1656,7 +1682,7 @@ ordpoissonProbs = function(extra, mu, deriv=0) {
ans = cbind(dl.dcump * dcump.deta / scalemat,
dl.dcump * dcump.dscale * dscale.deta)
ans = ans[,interleave.VGAM(M, M=2)]
- if(ooz) ans[,c(TRUE,FALSE)] = 0 else ans[,c(FALSE,TRUE)] = 0
+ if (ooz) ans[,c(TRUE,FALSE)] = 0 else ans[,c(FALSE,TRUE)] = 0
ans
}), list( .link=link, .lscale=lscale, .reverse=reverse,
.earg= earg, .escale=escale ))),
@@ -1664,28 +1690,28 @@ ordpoissonProbs = function(extra, mu, deriv=0) {
wz = matrix(0, n, 2*(2*M-3))
- wz[,2*(1:J)-1] = if(ooz) w * (dcump.deta / scalemat)^2 *
+ wz[,2*(1:J)-1] = if (ooz) w * (dcump.deta / scalemat)^2 *
(1/mu.use[,1:J] + 1/mu.use[,-1]) else 1
- wz[,2*(1:J)] = if(ooz) 1 else w * (dcump.dscale * dscale.deta)^2 *
+ wz[,2*(1:J)] = if (ooz) 1 else w * (dcump.dscale * dscale.deta)^2 *
(1/mu.use[,1:J] + 1/mu.use[,-1])
wz0 = w * (dcump.deta / scalemat) *
(dcump.dscale * dscale.deta) *
(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) {
+ if (J > 1) {
wz0 = -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
+ wz[,iam(2*ii-1,2*ii+1,M=M)] = if (ooz) wz0[,ii] else 0
wz0 = -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
@@ -1693,12 +1719,12 @@ ordpoissonProbs = function(extra, mu, deriv=0) {
(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
+ wz[,iam(2*ii-1,2*ii+2,M=M)] = if (ooz) wz0[,ii] else 0
wz0 = -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, .escale=escale ))))
@@ -1711,21 +1737,21 @@ ordpoissonProbs = function(extra, mu, deriv=0) {
margeff = function(object, subset=NULL) {
ii = ii.save = subset
- if(!is(object, "vglm"))
+ if (!is(object, "vglm"))
stop("'object' is not a vglm() object")
- if(!any(temp.logical <- is.element(c("multinomial","cumulative"),
+ if (!any(temp.logical <- is.element(c("multinomial","cumulative"),
object at family@vfamily)))
stop("'object' is not a 'multinomial' or 'cumulative' VGLM!")
model.multinomial = temp.logical[1]
- if(is(object, "vgam"))
+ if (is(object, "vgam"))
stop("'object' is a vgam() object")
- if(length(object at control$xij))
+ if (length(object at control$xij))
stop("'object' contains 'xij' terms")
- if(length(object at misc$form2))
+ if (length(object at misc$form2))
stop("'object' contains 'form2' terms")
oassign = object at misc$orig.assign
- if(any(unlist(lapply(oassign, length)) > 1))
+ if (any(unlist(lapply(oassign, length)) > 1))
warning("some terms in 'object' create more than one column of ",
"the LM design matrix")
@@ -1733,15 +1759,15 @@ margeff = function(object, subset=NULL) {
M = object at misc$M # ncol(B) # length(pvec) - 1
- if(model.multinomial) {
+ if (model.multinomial) {
rlev = object at misc$refLevel
cfit = coefvlm(object, matrix=TRUE)
- B = if(!length(rlev)) {
+ B = if (!length(rlev)) {
cbind(cfit, 0)
} else {
- if(rlev == M+1) { # Default
+ if (rlev == M+1) { # Default
cbind(cfit, 0)
- } else if(rlev == 1) {
+ } else if (rlev == 1) {
cbind(0, cfit)
} else {
cbind(cfit[,1:(rlev-1)], 0, cfit[,rlev:M])
@@ -1749,10 +1775,10 @@ margeff = function(object, subset=NULL) {
}
ppp = nrow(B)
pvec1 = fitted(object)[ 1,]
- colnames(B) = if(length(names(pvec1))) names(pvec1) else
+ colnames(B) = if (length(names(pvec1))) names(pvec1) else
paste("mu", 1:(M+1), sep="")
- if(is.null(ii)) {
+ if (is.null(ii)) {
BB = array(B, c(ppp, M+1, nnn))
pvec = c(t(fitted(object)))
pvec = rep(pvec, each=ppp)
@@ -1767,14 +1793,14 @@ margeff = function(object, subset=NULL) {
dimnames(B)[[2]], dimnames(fitted(object))[[1]]))
ans
} else
- if(is.numeric(ii) && (length(ii) == 1)) {
+ if (is.numeric(ii) && (length(ii) == 1)) {
pvec = fitted(object)[ii,]
temp1 = B * matrix(pvec, ppp, M+1, byrow=TRUE)
temp2 = matrix(rowSums(temp1), ppp, M+1)
temp3 = matrix(pvec, nrow(B), M+1, byrow=TRUE)
(B - temp2) * temp3
} else {
- if(is.logical(ii))
+ if (is.logical(ii))
ii = (1:nnn)[ii]
ans = array(0, c(ppp, M+1, length(ii)), dimnames=list(dimnames(B)[[1]],
@@ -1790,7 +1816,7 @@ margeff = function(object, subset=NULL) {
}
} else {
- if(is.logical(is.multivariateY <- object at misc$mv) && is.multivariateY)
+ 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
@@ -1809,7 +1835,7 @@ margeff = function(object, subset=NULL) {
resmat[,1] = ifelse(reverse, -1, 1) * hdot[,1] * cfit[,1]
- if(M > 1) {
+ if (M > 1) {
resmat[,2:M] = ifelse(reverse, -1, 1) *
(hdot[,(2:M) ] * cfit[,(2:M) ] -
hdot[,(2:M)-1] * cfit[,(2:M)-1])
@@ -1822,10 +1848,10 @@ margeff = function(object, subset=NULL) {
dimnames(fitted(object))[[2]]))
temp1 = aperm(temp1, c(1,3,2)) # ppp x (M+1) x nnn
- if(is.null(ii)) {
+ if (is.null(ii)) {
return(temp1)
} else
- if(is.numeric(ii) && (length(ii) == 1)) {
+ if (is.numeric(ii) && (length(ii) == 1)) {
return(temp1[,,ii])
} else {
return(temp1[,,ii])
@@ -1840,4 +1866,77 @@ margeff = function(object, subset=NULL) {
+prplot = function(object,
+ control=prplot.control(...), ...) {
+
+
+ if (!any(slotNames(object) == "family") ||
+ !any(object at family@vfamily == "vcategorical"))
+ stop("'object' does not seem to be a VGAM categorical model object")
+
+ if (!any(object at family@vfamily == "cumulative"))
+ stop("'object' is not seem to be a VGAM categorical model object")
+
+ control = prplot.control(...)
+
+
+ object = plotvgam(object, plot.arg=FALSE, raw=FALSE) # , ...
+
+ if (length(names(object at preplot)) != 1)
+ stop("object needs to have only one term")
+
+
+ MM = object at misc$M
+ use.y = cbind((object at preplot[[1]])$y)
+ Constant = attr(object at preplot, "Constant")
+ if (is.numeric(Constant) && length(Constant) == ncol(use.y))
+ use.y = use.y + matrix(Constant, nrow(use.y), ncol(use.y), byrow=TRUE)
+ for(ii in 1:MM) {
+ use.y[,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
+ 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),
+ main=mymain)
+ if (control$rug.arg)
+ rug(use.x, col=control$rcol, lwd=control$rlwd)
+
+ invisible(object)
+}
+
+
+
+
+ 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,
+ 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)
+}
+
+
+
+
diff --git a/R/family.censored.q b/R/family.censored.R
similarity index 89%
rename from R/family.censored.q
rename to R/family.censored.R
index 2597d76..360d68c 100644
--- a/R/family.censored.q
+++ b/R/family.censored.R
@@ -1,5 +1,7 @@
# These functions are
-# Copyright (C) 1998-2009 T.W. Yee, University of Auckland. All rights reserved.
+# Copyright (C) 1998-2010 T.W. Yee, University of Auckland. All rights reserved.
+
+
@@ -10,9 +12,9 @@
cenpoisson = function(link = "loge", earg = list(), imu = NULL) {
- if(mode(link) != "character" && mode(link) != "name")
+ if (mode(link) != "character" && mode(link) != "name")
link = as.character(substitute(link))
- if(!is.list(earg))
+ if (!is.list(earg))
earg = list()
new("vglmff",
@@ -20,13 +22,13 @@ cenpoisson = function(link = "loge", earg = list(), imu = NULL) {
"Link: ", namesof("mu", link, earg = earg), "\n",
"Variance: mu"),
initialize = eval(substitute(expression({
- if(any(is.na(y)))
+ if (any(is.na(y)))
stop("NAs are not allowed in the response")
- if(any(y != round(y)))
+ if (any(y != round(y)))
warning("the response should be integer-valued")
centype = attr(y, "type")
- if(centype=="right") {
+ if (centype=="right") {
temp = y[, 2]
extra$uncensored = ifelse(temp == 1, TRUE, FALSE)
extra$rightcensored = ifelse(temp == 0, TRUE, FALSE)
@@ -34,7 +36,7 @@ cenpoisson = function(link = "loge", earg = list(), imu = NULL) {
extra$interval = rep(FALSE, len=n)
init.mu = pmax(y[,1], 1/8)
} else
- if(centype=="left") {
+ if (centype=="left") {
temp = y[, 2]
extra$uncensored = ifelse(temp == 1, TRUE, FALSE)
extra$rightcensored = rep(FALSE, len=n)
@@ -42,31 +44,31 @@ cenpoisson = function(link = "loge", earg = list(), imu = NULL) {
extra$interval = rep(FALSE, len=n)
init.mu = pmax(y[,1], 1/8)
} else
- if(centype=="interval" || centype=="interval2") {
+ if (centype=="interval" || centype=="interval2") {
temp = y[, 3]
extra$uncensored = ifelse(temp == 1, TRUE, FALSE)
extra$rightcensored = ifelse(temp == 0, TRUE, FALSE)
extra$leftcensored = ifelse(temp == 2, TRUE, FALSE)
extra$intervalcensored = ifelse(temp == 3, TRUE, FALSE)
init.mu = pmax((y[,1] + y[,2])/2, 1/8) # for intervalcensored
- if(any(extra$uncensored))
+ if (any(extra$uncensored))
init.mu[extra$uncensored] = pmax(y[extra$uncensored,1], 1/8)
- if(any(extra$rightcensored))
+ if (any(extra$rightcensored))
init.mu[extra$rightcensored] = pmax(y[extra$rightcensored,1], 1/8)
- if(any(extra$leftcensored))
+ if (any(extra$leftcensored))
init.mu[extra$leftcensored] = pmax(y[extra$leftcensored,1], 1/8)
} else
- if(centype=="counting") {
+ if (centype=="counting") {
stop("type=='counting' not compatible with cenpoisson()")
init.mu = pmax(y[,1], 1/8)
stop("currently not working")
} else
stop("response have to be in a class of SurvS4")
- if(length( .imu )) init.mu = 0 * y[,1] + .imu
+ if (length( .imu )) init.mu = 0 * y[,1] + .imu
predictors.names = namesof("mu", .link, earg= .earg, short=TRUE)
- if(!length(etastart))
+ if (!length(etastart))
etastart = theta2eta(init.mu, link = .link, earg = .earg)
}), list( .link = link, .earg = earg, .imu = imu))),
inverse = eval(substitute(function(eta, extra = NULL) {
@@ -86,7 +88,7 @@ cenpoisson = function(link = "loge", earg = list(), imu = NULL) {
cenL = extra$leftcensored
cenU = extra$rightcensored
cenI = extra$intervalcensored
- if(residuals){
+ if (residuals){
stop("loglikelihood residuals not implemented yet")
} else {
sum(w[cen0] * dpois(y[cen0,1], mu[cen0], log=TRUE)) +
@@ -105,19 +107,19 @@ cenpoisson = function(link = "loge", earg = list(), imu = NULL) {
lambda = eta2theta(eta, link = .link, earg = .earg)
dl.dlambda = (y[,1] - lambda)/lambda # uncensored
yllim = yulim = y[,1] # uncensored
- if(any(cenU)) {
+ if (any(cenU)) {
yllim[cenU] = y[cenU,1]
densm1 = dpois(yllim-1, lambda)
queue = ppois(yllim-1, lambda, lower=FALSE) # Right tail probability
dl.dlambda[cenU] = densm1[cenU] / queue[cenU]
}
- if(any(cenL)) {
+ if (any(cenL)) {
yulim[cenL] = y[cenL,1]-1
densm0 = dpois(yulim, lambda)
Queue = ppois(yulim, lambda) # Left tail probability
dl.dlambda[cenL] = -densm0[cenL] / Queue[cenL]
}
- if(any(cenI)) {
+ if (any(cenI)) {
yllim[cenI] = y[cenI,1]+1
yulim[cenI] = y[cenI,2]
Queue1 = ppois(yllim-1, lambda)
@@ -133,17 +135,17 @@ cenpoisson = function(link = "loge", earg = list(), imu = NULL) {
weight = eval(substitute(expression({
d2lambda.deta2 = d2theta.deta2(theta=lambda, link= .link, earg= .earg)
d2l.dlambda2 = 1 / lambda # uncensored; Fisher scoring
- if(any(cenU)) {
+ if (any(cenU)) {
densm2 = dpois(yllim-2, lambda)
d2l.dlambda2[cenU] = (dl.dlambda[cenU])^2 -
(densm2[cenU]-densm1[cenU])/queue[cenU]
}
- if(any(cenL)) {
+ if (any(cenL)) {
densm1 = dpois(yulim-1, lambda)
d2l.dlambda2[cenL] = (dl.dlambda[cenL])^2 -
(densm0[cenL]-densm1[cenL])/Queue[cenL]
}
- if(any(cenI)) {
+ if (any(cenI)) {
densm03 = dpois(yulim-1, lambda)
densm13 = dpois(yllim-2, lambda)
d2l.dlambda2[cenI] = (dl.dlambda[cenI])^2 -
@@ -158,13 +160,13 @@ cenpoisson = function(link = "loge", earg = list(), imu = NULL) {
-if(FALSE)
+if (FALSE)
cexpon =
ecexpon = function(link="loge", location=0)
{
- if(!is.Numeric(location, allow=1))
+ if (!is.Numeric(location, allow=1))
stop("bad input for 'location'")
- if(mode(link) != "character" && mode(link) != "name")
+ if (mode(link) != "character" && mode(link) != "name")
link = as.character(substitute(link))
new("vglmff",
@@ -173,11 +175,11 @@ ecexpon = function(link="loge", location=0)
"Mean: ", "mu = ", location, " + 1 / ",
namesof("rate", link, tag= FALSE), "\n",
"Variance: ",
- if(location==0) "Exponential: mu^2" else
+ if (location==0) "Exponential: mu^2" else
paste("(mu-", location, ")^2", sep="")),
initialize=eval(substitute(expression({
extra$location = .location # This is passed into, e.g., link, deriv etc.
- if(any(y[,1] <= extra$location))
+ if (any(y[,1] <= extra$location))
stop("all responses must be greater than ", extra$location)
predictors.names = namesof("rate", .link, tag= FALSE)
type <- attr(y, "type")
@@ -189,7 +191,7 @@ ecexpon = function(link="loge", location=0)
mu = ifelse(temp==3, y[,2] + (abs(y[,2] - extra$location) < 0.001)/8,
y[,1] + (abs(y[,1] - extra$location) < 0.001) / 8)
}
- if(!length(etastart))
+ if (!length(etastart))
etastart = theta2eta(1/(mu-extra$location), .link)
if (type=="right") {
@@ -244,7 +246,7 @@ ecexpon = function(link="loge", location=0)
cenL = extra$leftcensored
cenU = extra$rightcensored
cenI = extra$interval
- if(residuals) stop("loglikelihood residuals not implemented yet") else
+ if (residuals) stop("loglikelihood residuals not implemented yet") else
sum(w[cenL] * log1p(-exp(-rate[cenL]*(y[cenL,1]-extra$location)))) +
sum(w[cenU] * (-rate[cenU]*(y[cenU,1]-extra$location))) +
sum(w[cen0] * (log(rate[cen0]) - rate[cen0]*(y[cen0,1]-extra$location)))+
@@ -261,12 +263,12 @@ ecexpon = function(link="loge", location=0)
dl.drate = 1/rate - (y[,1]-extra$location) # uncensored
tmp200 = exp(-rate*(y[,1]-extra$location))
tmp200b = exp(-rate*(y[,2]-extra$location)) # for interval censored
- if(any(cenL))
+ if (any(cenL))
dl.drate[cenL] = (y[cenL,1]-extra$location) *
tmp200[cenL] / (1 - tmp200[cenL])
- if(any(cenU))
+ if (any(cenU))
dl.drate[cenU] = -(y[cenU,1]-extra$location)
- if(any(cenI))
+ if (any(cenI))
dl.drate[cenI] = ((y[cenI,2]-extra$location)*tmp200b[cenI]-
(y[cenI,1]-extra$location)*tmp200[cenI])/
(-tmp200b[cenI]+tmp200[cenI])
@@ -295,11 +297,11 @@ ecexpon = function(link="loge", location=0)
cnormal1 = function(lmu="identity", lsd="loge", imethod=1, zero=2)
{
- if(mode(lmu) != "character" && mode(lmu) != "name")
+ if (mode(lmu) != "character" && mode(lmu) != "name")
lmu = as.character(substitute(lmu))
- if(mode(lsd) != "character" && mode(lsd) != "name")
+ if (mode(lsd) != "character" && mode(lsd) != "name")
lsd = as.character(substitute(lsd))
- if(!is.Numeric(imethod, allow=1, integer=TRUE, positi=TRUE) || imethod > 2)
+ if (!is.Numeric(imethod, allow=1, integer=TRUE, positi=TRUE) || imethod > 2)
stop("imethod must be 1 or 2")
new("vglmff",
@@ -312,24 +314,24 @@ cnormal1 = function(lmu="identity", lsd="loge", imethod=1, zero=2)
}), list( .zero=zero ))),
initialize=eval(substitute(expression({
y = cbind(y)
- if(ncol(y)>1) stop("the response must be a vector or a 1-column matrix")
+ if (ncol(y)>1) stop("the response must be a vector or a 1-column matrix")
- if(!length(extra$leftcensored)) extra$leftcensored = rep(FALSE, len=n)
- if(!length(extra$rightcensored)) extra$rightcensored = rep(FALSE, len=n)
- if(any(extra$rightcensored & extra$leftcensored))
+ if (!length(extra$leftcensored)) extra$leftcensored = rep(FALSE, len=n)
+ if (!length(extra$rightcensored)) extra$rightcensored = rep(FALSE, len=n)
+ if (any(extra$rightcensored & extra$leftcensored))
stop("some observations are both right and left censored!")
predictors.names =
c(namesof("mu", .lmu, tag= FALSE),
namesof("sd", .lsd, tag= FALSE))
- if(!length(etastart)) {
+ if (!length(etastart)) {
anyc = extra$leftcensored | extra$rightcensored
- i11 = if( .imethod == 1) anyc else FALSE # can be all data
+ i11 = if ( .imethod == 1) anyc else FALSE # can be all data
junk=if(is.R()) lm.wfit(x=cbind(x[!i11,]),y=y[!i11],w=w[!i11]) else
lm.wfit(x=cbind(x[!i11,]), y=y[!i11], w=w[!i11],method="qr")
sd.y.est = sqrt( sum(w[!i11] * junk$resid^2) / junk$df.residual )
etastart = cbind(mu=y, rep(theta2eta(sd.y.est, .lsd), length=n))
- if(any(anyc)) etastart[anyc,1] = x[anyc,,drop=FALSE] %*% junk$coeff
+ if (any(anyc)) etastart[anyc,1] = x[anyc,,drop=FALSE] %*% junk$coeff
}
}), list( .lmu=lmu, .lsd=lsd, .imethod=imethod ))),
inverse=eval(substitute( function(eta, extra=NULL) {
@@ -351,7 +353,7 @@ cnormal1 = function(lmu="identity", lsd="loge", imethod=1, zero=2)
ell1 = -log(sd[cen0]) - 0.5 * ((y[cen0] - mum[cen0])/sd[cen0])^2
ell2 = log1p(-pnorm((mum[cenL] - Lower[cenL])/sd[cenL]))
ell3 = log1p(-pnorm(( Upper[cenU] - mum[cenU])/sd[cenU]))
- if(residuals) stop("loglikelihood residuals not implemented yet") else
+ if (residuals) stop("loglikelihood residuals not implemented yet") else
sum(w[cen0] * ell1) + sum(w[cenL] * ell2) + sum(w[cenU] * ell3)
}, list( .lmu=lmu, .lsd=lsd ))),
vfamily=c("tobit"),
@@ -367,7 +369,7 @@ cnormal1 = function(lmu="identity", lsd="loge", imethod=1, zero=2)
dl.dsd = (((y-mum)/sd)^2 - 1) / sd
dmu.deta = dtheta.deta(mum, .lmu)
dsd.deta = dtheta.deta(sd, .lsd)
- if(any(cenL)) {
+ if (any(cenL)) {
mumL = mum - Lower
temp21L = mumL[cenL] / sd[cenL]
PhiL = pnorm(temp21L)
@@ -377,7 +379,7 @@ cnormal1 = function(lmu="identity", lsd="loge", imethod=1, zero=2)
dl.dsd[cenL] = mumL[cenL] * fred21 / sd[cenL]^2
rm(fred21)
}
- if(any(cenU)) {
+ if (any(cenU)) {
mumU = Upper - mum
temp21U = mumU[cenU] / sd[cenU]
PhiU = pnorm(temp21U)
@@ -437,11 +439,11 @@ cnormal1 = function(lmu="identity", lsd="loge", imethod=1, zero=2)
crayleigh = function(link="loge", earg = list(), expected=FALSE) {
- if(mode(link) != "character" && mode(link) != "name")
+ if (mode(link) != "character" && mode(link) != "name")
link = as.character(substitute(link))
- if(!is.logical(expected) || length(expected) != 1)
+ if (!is.logical(expected) || length(expected) != 1)
stop("bad input for argument 'expected'")
- if(!is.list(earg)) earg = list()
+ if (!is.list(earg)) earg = list()
new("vglmff",
blurb=c("Censored Rayleigh distribution",
@@ -450,12 +452,12 @@ crayleigh = function(link="loge", earg = list(), expected=FALSE) {
namesof("a", link, earg= earg ), "\n", "\n",
"Mean: a * sqrt(pi / 2)"),
initialize=eval(substitute(expression({
- if(ncol(cbind(y)) != 1)
+ if (ncol(cbind(y)) != 1)
stop("response must be a vector or a one-column matrix")
- if(length(extra$leftcensored)) stop("cannot handle left-censored data")
- if(!length(extra$rightcensored)) extra$rightcensored = rep(FALSE, len=n)
+ if (length(extra$leftcensored)) stop("cannot handle left-censored data")
+ if (!length(extra$rightcensored)) extra$rightcensored = rep(FALSE, len=n)
predictors.names = namesof("a", .link, earg= .earg, tag= FALSE)
- if(!length(etastart)) {
+ if (!length(etastart)) {
a.init = (y+1/8) / sqrt(pi/2)
etastart = theta2eta(a.init, .link, earg= .earg )
}
@@ -474,7 +476,7 @@ crayleigh = function(link="loge", earg = list(), expected=FALSE) {
a = eta2theta(eta, .link, earg= .earg )
cen0 = !extra$rightcensored # uncensored obsns
cenU = extra$rightcensored
- if(residuals) stop("loglikelihood residuals not implemented yet") else
+ if (residuals) stop("loglikelihood residuals not implemented yet") else
sum(w[cen0]*(log(y[cen0]) - 2*log(a[cen0]) - 0.5*(y[cen0]/a[cen0])^2)) -
0.5 * sum(w[cenU] * (y[cenU]/a[cenU])^2)
}, list( .link=link, .earg=earg ))),
@@ -491,7 +493,7 @@ crayleigh = function(link="loge", earg = list(), expected=FALSE) {
weight=eval(substitute(expression({
ed2l.da2 = 4 / a^2
wz = da.deta^2 * ed2l.da2
- if( .expected) {
+ if ( .expected) {
ed2l.da2[cenU] = 6 / (a[cenU])^2
wz[cenU] = (da.deta[cenU])^2 * ed2l.da2[cenU]
} else {
@@ -512,17 +514,17 @@ weibull.sev = function(lshape="loge", lscale="loge",
imethod=1, zero=2)
{
- if(mode(lshape) != "character" && mode(lshape) != "name")
+ if (mode(lshape) != "character" && mode(lshape) != "name")
lshape = as.character(substitute(lshape))
- if(mode(lscale) != "character" && mode(lscale) != "name")
+ if (mode(lscale) != "character" && mode(lscale) != "name")
lscale = as.character(substitute(lscale))
- if(length(zero) && !is.Numeric(zero, integer=TRUE, posit=TRUE))
+ if (length(zero) && !is.Numeric(zero, integer=TRUE, posit=TRUE))
stop("bad input for argument 'zero'")
- if(!is.Numeric(imethod, allow=1, integer=TRUE, positi=TRUE) || imethod > 2)
+ if (!is.Numeric(imethod, allow=1, integer=TRUE, positi=TRUE) || imethod > 2)
stop("argument 'imethod' must be 1 or 2")
- if(!is.list(eshape)) eshape = list()
- if(!is.list(escale)) escale = list()
- if(!is.Numeric(nrfs, allow=1) || nrfs<0 || nrfs > 1)
+ if (!is.list(eshape)) eshape = list()
+ if (!is.list(escale)) escale = list()
+ if (!is.Numeric(nrfs, allow=1) || nrfs<0 || nrfs > 1)
stop("bad input for 'nrfs'")
new("vglmff",
@@ -537,24 +539,24 @@ weibull.sev = function(lshape="loge", lscale="loge",
}), list( .zero=zero ))),
initialize=eval(substitute(expression({
y = cbind(y)
- if(ncol(y)>1) stop("the response must be a vector or a 1-column matrix")
+ if (ncol(y)>1) stop("the response must be a vector or a 1-column matrix")
- if(is.SurvS4(y))
- stop("only uncensored observations are allowed; don't use Surv()")
+ if (is.SurvS4(y))
+ stop("only uncensored observations are allowed; don't use SurvS4()")
predictors.names =
c(namesof("shape", .lshape, earg= .eshape, tag=FALSE),
namesof("scale", .lscale, earg= .escale, tag=FALSE))
- if(!length(.ishape) || !length(.iscale)) {
+ if (!length(.ishape) || !length(.iscale)) {
anyc = FALSE # extra$leftcensored | extra$rightcensored
- i11 = if( .imethod == 1) anyc else FALSE # can be all data
+ i11 = if ( .imethod == 1) anyc else FALSE # can be all data
qvec = c(.25, .5, .75) # Arbitrary; could be made an argument
- init.shape = if(length( .ishape)) .ishape else 1
+ init.shape = if (length( .ishape)) .ishape else 1
xvec = log(-log1p(-qvec))
fit0 = lsfit(x=xvec, y=log(quantile(y[!i11], qvec)))
}
- if(!length(etastart)) {
+ if (!length(etastart)) {
shape = rep(if(length(.ishape)) .ishape else 1/fit0$coef["X"],len=n)
scale = rep(if(length(.iscale)) .iscale else
exp(fit0$coef["Intercept"]), len=n)
@@ -572,7 +574,7 @@ weibull.sev = function(lshape="loge", lscale="loge",
}, list( .lscale=lscale, .lshape=lshape,
.escale=escale, .eshape=eshape ) )),
last=eval(substitute(expression({
- if(regnotok <- any(shape <= 2))
+ if (regnotok <- any(shape <= 2))
warning(paste("MLE regularity conditions are violated",
"(shape <= 2) at the final iteration"))
misc$link = c(shape= .lshape, scale= .lscale)
@@ -587,7 +589,7 @@ weibull.sev = function(lshape="loge", lscale="loge",
scale = eta2theta(eta[,2], .lscale, earg= .escale )
ell1 = (log(shape) - log(scale) + (shape-1) *
log(y/scale) - (y / scale)^shape)
- if(residuals) stop("loglikelihood residuals not implemented yet") else
+ if (residuals) stop("loglikelihood residuals not implemented yet") else
sum(w * ell1)
}, list( .lscale=lscale, .lshape=lshape,
.escale=escale, .eshape=eshape ) )),
@@ -624,7 +626,7 @@ weibull.sev = function(lshape="loge", lscale="loge",
setOldClass(c("SurvS4","Surv"))
-Surv <-
+ SurvS4 <-
function (time, time2, event, type = c("right", "left", "interval",
"counting", "interval2"), origin = 0)
{
diff --git a/R/family.circular.q b/R/family.circular.R
similarity index 83%
rename from R/family.circular.q
rename to R/family.circular.R
index 02813ff..3dc9d80 100644
--- a/R/family.circular.q
+++ b/R/family.circular.R
@@ -1,5 +1,5 @@
# These functions are
-# Copyright (C) 1998-2009 T.W. Yee, University of Auckland. All rights reserved.
+# Copyright (C) 1998-2010 T.W. Yee, University of Auckland. All rights reserved.
@@ -10,7 +10,7 @@
dcard = function(x, mu, rho, log = FALSE) {
- if(!is.logical(log.arg <- log))
+ if (!is.logical(log.arg <- log))
stop("bad input for argument 'log'")
rm(log)
@@ -23,13 +23,13 @@ dcard = function(x, mu, rho, log = FALSE) {
logdensity[mu >= 2*pi] = NaN
logdensity[rho <= -0.5] = NaN
logdensity[rho >= 0.5] = NaN
- if(log.arg) logdensity else exp(logdensity)
+ if (log.arg) logdensity else exp(logdensity)
}
pcard = function(q, mu, rho) {
- if(!is.Numeric(mu) || any(mu < 0) || any(mu > 2*pi))
+ if (!is.Numeric(mu) || any(mu < 0) || any(mu > 2*pi))
stop("'mu' must be between 0 and 2*pi inclusive")
- if(!is.Numeric(rho) || max(abs(rho) > 0.5))
+ if (!is.Numeric(rho) || max(abs(rho) > 0.5))
stop("'rho' must be between -0.5 and 0.5 inclusive")
ans = (q + 2 * rho * (sin(q-mu) + sin(mu))) / (2*pi)
ans[q >= (2*pi)] = 1
@@ -38,11 +38,11 @@ pcard = function(q, mu, rho) {
}
qcard = function(p, mu, rho, tolerance=1.0e-7, maxits=500) {
- if(!is.Numeric(mu) || any(mu < 0) || any(mu > 2*pi))
+ if (!is.Numeric(mu) || any(mu < 0) || any(mu > 2*pi))
stop("'mu' must be between 0 and 2*pi inclusive")
- if(!is.Numeric(rho) || max(abs(rho) > 0.5))
+ if (!is.Numeric(rho) || max(abs(rho) > 0.5))
stop("'rho' must be between -0.5 and 0.5 inclusive")
- if(!is.Numeric(p, positive=TRUE) || any(p > 1))
+ if (!is.Numeric(p, positive=TRUE) || any(p > 1))
stop("'p' must be between 0 and 1")
nn = max(length(p), length(mu), length(rho))
p = rep(p, len=nn)
@@ -56,22 +56,22 @@ qcard = function(p, mu, rho, tolerance=1.0e-7, maxits=500) {
ans = oldans - (oldans + 2 * rho * (sin(oldans-mu)+sin(mu)) -
2*pi*p) / (1 + 2 * rho * cos(oldans - mu))
index = (ans <= 0) | (ans > 2*pi)
- if(any(index)) {
+ if (any(index)) {
ans[index] = runif(sum(index), 0, 2*pi)
}
- if(max(abs(ans - oldans)) < tolerance) break;
- if(its == maxits) {warning("did not converge"); break}
+ if (max(abs(ans - oldans)) < tolerance) break;
+ if (its == maxits) {warning("did not converge"); break}
oldans = ans
}
ans
}
rcard = function(n, mu, rho, ...) {
- if(!is.Numeric(mu) || any(mu < 0) || any(mu > 2*pi))
+ if (!is.Numeric(mu) || any(mu < 0) || any(mu > 2*pi))
stop("'mu' must be between 0 and 2*pi inclusive")
- if(!is.Numeric(rho) || max(abs(rho) > 0.5))
+ if (!is.Numeric(rho) || max(abs(rho) > 0.5))
stop("'rho' must be between -0.5 and 0.5 inclusive")
- if(!is.Numeric(n, positive=TRUE, integer=TRUE, allow=1))
+ if (!is.Numeric(n, positive=TRUE, integer=TRUE, allow=1))
stop("'n' must be a single positive integer")
mu = rep(mu, len=n)
rho = rep(rho, len=n)
@@ -92,17 +92,17 @@ cardioid.control <- function(save.weight=TRUE, ...)
imu=NULL, irho=0.3,
nsimEIM=100, zero=NULL)
{
- if(mode(lmu) != "character" && mode(lmu) != "name")
+ if (mode(lmu) != "character" && mode(lmu) != "name")
lmu = as.character(substitute(lmu))
- if(mode(lrho) != "character" && mode(lrho) != "name")
+ if (mode(lrho) != "character" && mode(lrho) != "name")
lrho = as.character(substitute(lrho))
- if(length(imu) && (!is.Numeric(imu, positive=TRUE) || any(imu > 2*pi)))
+ if (length(imu) && (!is.Numeric(imu, positive=TRUE) || any(imu > 2*pi)))
stop("bad input for argument 'imu'")
- if(!is.Numeric(irho) || max(abs(irho)) > 0.5)
+ if (!is.Numeric(irho) || max(abs(irho)) > 0.5)
stop("bad input for argument 'irho'")
- if(!is.list(emu)) emu = list()
- if(!is.list(erho)) erho = list()
- if(!is.Numeric(nsimEIM, allow=1, integ=TRUE) || nsimEIM <= 50)
+ if (!is.list(emu)) emu = list()
+ if (!is.list(erho)) erho = list()
+ if (!is.Numeric(nsimEIM, allow=1, integ=TRUE) || nsimEIM <= 50)
stop("'nsimEIM' should be an integer greater than 50")
new("vglmff",
@@ -117,14 +117,14 @@ cardioid.control <- function(save.weight=TRUE, ...)
constraints = cm.zero.vgam(constraints, x, .zero, M)
}), list( .zero=zero ))),
initialize=eval(substitute(expression({
- if(ncol(y <- cbind(y)) != 1)
+ if (ncol(y <- cbind(y)) != 1)
stop("the response must be a vector or one-column matrix")
- if(any((y <= 0) | (y >=2*pi)))
+ if (any((y <= 0) | (y >=2*pi)))
stop("the response must be in (0,2*pi)")
predictors.names = c(
namesof("mu", .lmu, earg= .emu, tag=FALSE),
namesof("rho", .lrho, earg= .erho, tag=FALSE))
- if(!length(etastart)) {
+ if (!length(etastart)) {
rho.init = rep(if(length(.irho)) .irho else 0.3, length=n)
cardioid.Loglikfun = function(mu, y, x, w, extraargs) {
@@ -132,7 +132,7 @@ cardioid.control <- function(save.weight=TRUE, ...)
sum(w * (-log(2*pi) + log1p(2*rho*cos(y-mu))))
}
mu.grid = seq(0.1, 6.0, len=19)
- mu.init = if(length( .imu )) .imu else
+ mu.init = if (length( .imu )) .imu else
getMaxMin(mu.grid, objfun=cardioid.Loglikfun, y=y, x=x, w=w,
extraargs=list(irho = rho.init))
mu.init = rep(mu.init, length=length(y))
@@ -160,7 +160,7 @@ cardioid.control <- function(save.weight=TRUE, ...)
function(mu,y,w,residuals=FALSE,eta,extra=NULL) {
mu = eta2theta(eta[,1], link= .lmu, earg= .emu)
rho = eta2theta(eta[,2], link= .lrho, earg= .erho)
- if(residuals) stop("loglikelihood residuals not implemented yet") else {
+ if (residuals) stop("loglikelihood residuals not implemented yet") else {
sum(w * dcard(x=y, mu=mu, rho=rho, log=TRUE))
}
}, list( .lmu=lmu, .lrho=lrho,
@@ -190,7 +190,7 @@ cardioid.control <- function(save.weight=TRUE, ...)
run.varcov = ((ii-1) * run.varcov +
temp3[,ind1$row.index]*temp3[,ind1$col.index]) / ii
}
- wz = if(intercept.only)
+ wz = if (intercept.only)
matrix(colMeans(run.varcov),
n, ncol(run.varcov), byrow=TRUE) else run.varcov
@@ -210,15 +210,15 @@ cardioid.control <- function(save.weight=TRUE, ...)
escale=list(),
ilocation=NULL, iscale=NULL,
method.init=1, zero=NULL) {
- if(mode(llocation) != "character" && mode(llocation) != "name")
+ if (mode(llocation) != "character" && mode(llocation) != "name")
llocation = as.character(substitute(llocation))
- if(mode(lscale) != "character" && mode(lscale) != "name")
+ if (mode(lscale) != "character" && mode(lscale) != "name")
lscale = as.character(substitute(lscale))
- if(!is.Numeric(method.init, allow=1, integ=TRUE, posit=TRUE) ||
+ if (!is.Numeric(method.init, allow=1, integ=TRUE, posit=TRUE) ||
method.init > 2) stop("argument 'method.init' must be 1 or 2")
- if(length(zero) && !is.Numeric(zero, integer=TRUE, posit=TRUE))
+ if (length(zero) && !is.Numeric(zero, integer=TRUE, posit=TRUE))
stop("bad input for argument 'zero'")
- if(!is.list(escale)) escale = list()
+ if (!is.list(escale)) escale = list()
new("vglmff",
blurb=c("Von Mises distribution\n\n",
@@ -231,13 +231,13 @@ cardioid.control <- function(save.weight=TRUE, ...)
constraints = cm.zero.vgam(constraints, x, .zero, M)
}), list( .zero=zero ))),
initialize=eval(substitute(expression({
- if(ncol(cbind(y)) != 1)
+ if (ncol(cbind(y)) != 1)
stop("response must be a vector or a one-column matrix")
predictors.names =
c(namesof("location", .llocation, earg= .elocation, tag=FALSE),
namesof("scale", .lscale, earg=.escale, tag=FALSE))
- if(!length(etastart)) {
- if( .method.init == 1) {
+ if (!length(etastart)) {
+ if ( .method.init == 1) {
location.init = mean(y)
rat10 = sqrt((sum(w*cos(y )))^2 + sum(w*sin(y))^2) / sum(w)
scale.init = sqrt(1 - rat10)
@@ -245,9 +245,9 @@ cardioid.control <- function(save.weight=TRUE, ...)
location.init = median(y)
scale.init = sqrt(sum(w*abs(y - location.init)) / sum(w))
}
- location.init = if(length(.ilocation)) rep(.ilocation, len=n) else
+ location.init = if (length(.ilocation)) rep(.ilocation, len=n) else
rep(location.init, len=n)
- scale.init= if(length(.iscale)) rep(.iscale,len=n) else rep(1,len=n)
+ scale.init= if (length(.iscale)) rep(.iscale,len=n) else rep(1,len=n)
etastart = cbind(
theta2eta(location.init, .llocation, earg= .elocation),
theta2eta(scale.init, .lscale, earg= .escale))
@@ -269,7 +269,7 @@ cardioid.control <- function(save.weight=TRUE, ...)
function(mu,y,w,residuals= FALSE,eta, extra=NULL) {
location = eta2theta(eta[,1], .llocation, earg= .elocation)
Scale = eta2theta(eta[,2], .lscale, earg= .escale)
- if(residuals) stop("loglikelihood residuals not implemented yet") else
+ if (residuals) stop("loglikelihood residuals not implemented yet") else
sum(w * (Scale * cos(y - location) -
log(mbesselI0(x=Scale ))))
}, list( .escale=escale, .lscale=lscale,
diff --git a/R/family.extremes.q b/R/family.extremes.R
similarity index 83%
rename from R/family.extremes.q
rename to R/family.extremes.R
index c1de526..980924f 100644
--- a/R/family.extremes.q
+++ b/R/family.extremes.R
@@ -1,5 +1,5 @@
# These functions are
-# Copyright (C) 1998-2009 T.W. Yee, University of Auckland. All rights reserved.
+# Copyright (C) 1998-2010 T.W. Yee, University of Auckland. All rights reserved.
@@ -12,23 +12,23 @@
rgev = function(n, location=0, scale=1, shape=0) {
- use.n = if((length.n <- length(n)) > 1) length.n else
- if(!is.Numeric(n, integ=TRUE, allow=1, posit=TRUE))
+ use.n = if ((length.n <- length(n)) > 1) length.n else
+ if (!is.Numeric(n, integ=TRUE, allow=1, posit=TRUE))
stop("bad input for argument 'n'") else n
- if(!is.Numeric(location))
+ if (!is.Numeric(location))
stop("bad input for argument argument 'location'")
- if(!is.Numeric(shape)) stop("bad input for argument argument 'shape'")
+ if (!is.Numeric(shape)) stop("bad input for argument argument 'shape'")
ans = numeric(use.n)
shape = rep(shape, len=use.n); location = rep(location, len=use.n);
scale = rep(scale, len=use.n)
scase = abs(shape) < sqrt(.Machine$double.eps)
nscase = sum(scase)
- if(use.n - nscase)
+ if (use.n - nscase)
ans[!scase] = location[!scase] + scale[!scase] *
((-log(runif(use.n-nscase)))^(-shape[!scase]) -1) / shape[!scase]
- if(nscase)
+ if (nscase)
ans[scase] = rgumbel(nscase, location[scase], scale[scase])
ans[scale <= 0] = NaN
ans
@@ -39,13 +39,13 @@ rgev = function(n, location=0, scale=1, shape=0) {
dgev = function(x, location=0, scale=1, shape=0, log = FALSE,
tolshape0 = sqrt(.Machine$double.eps),
oobounds.log = -Inf, giveWarning=FALSE) {
- if(!is.logical(log.arg <- log))
+ if (!is.logical(log.arg <- log))
stop("bad input for argument 'log'")
rm(log)
- if(oobounds.log > 0)
+ if (oobounds.log > 0)
stop("bad input for argument 'oobounds.log'")
- if(!is.Numeric(tolshape0, allow=1, posit=TRUE))
+ if (!is.Numeric(tolshape0, allow=1, posit=TRUE))
stop("bad input for argument 'tolshape0'")
use.n = max(length(x), length(location), length(scale), length(shape))
shape = rep(shape, len=use.n); location = rep(location, len=use.n);
@@ -55,35 +55,35 @@ dgev = function(x, location=0, scale=1, shape=0, log = FALSE,
logdensity = rep(log(0), len=use.n)
scase = abs(shape) < tolshape0
nscase = sum(scase)
- if(use.n - nscase) {
+ if (use.n - nscase) {
zedd = 1+shape*(x-location)/scale # pmax(0, (1+shape*xc/scale))
xok = (!scase) & (zedd > 0)
logdensity[xok] = -log(scale[xok]) - zedd[xok]^(-1/shape[xok]) -
(1 + 1/shape[xok]) * log(zedd[xok])
outofbounds = (!scase) & (zedd <= 0)
- if(any(outofbounds)) {
+ if (any(outofbounds)) {
logdensity[outofbounds] = oobounds.log
no.oob = sum(outofbounds)
- if(giveWarning)
+ if (giveWarning)
warning(no.oob, " observation",
ifelse(no.oob > 1, "s are", " is"), " out of bounds")
}
}
- if(nscase) {
+ if (nscase) {
logdensity[scase] = dgumbel(x[scase], loc=location[scase],
sc=scale[scase], log=TRUE)
}
logdensity[scale <= 0] = NaN
- if(log.arg) logdensity else exp(logdensity)
+ if (log.arg) logdensity else exp(logdensity)
}
pgev = function(q, location=0, scale=1, shape=0) {
- if(!is.Numeric(q)) stop("bad input for argument 'q'")
- if(!is.Numeric(location)) stop("bad input for argument 'location'")
- if(!is.Numeric(shape)) stop("bad input for argument 'shape'")
+ if (!is.Numeric(q)) stop("bad input for argument 'q'")
+ if (!is.Numeric(location)) stop("bad input for argument 'location'")
+ if (!is.Numeric(shape)) stop("bad input for argument 'shape'")
use.n = max(length(q), length(location), length(scale), length(shape))
ans = numeric(use.n)
@@ -91,11 +91,11 @@ pgev = function(q, location=0, scale=1, shape=0) {
scale = rep(scale, len=use.n); q = rep(q-location, len=use.n)
scase = abs(shape) < sqrt(.Machine$double.eps)
nscase = sum(scase)
- if(use.n - nscase) {
+ if (use.n - nscase) {
zedd = pmax(0,(1+shape*q/scale))
ans[!scase] = exp(-zedd[!scase]^(-1/shape[!scase]))
}
- if(nscase)
+ if (nscase)
ans[scase] = pgumbel(q[scase], location[scase], scale[scase])
ans[scale <= 0] = NaN
ans
@@ -104,9 +104,9 @@ pgev = function(q, location=0, scale=1, shape=0) {
qgev = function(p, location=0, scale=1, shape=0) {
- if(!is.Numeric(p, posit=TRUE) || any(p >= 1)) stop("0 < p < 1 is required")
- if(!is.Numeric(location)) stop("bad input for argument 'location'")
- if(!is.Numeric(shape)) stop("bad input for argument 'shape'")
+ if (!is.Numeric(p, posit=TRUE) || any(p >= 1)) stop("0 < p < 1 is required")
+ if (!is.Numeric(location)) stop("bad input for argument 'location'")
+ if (!is.Numeric(shape)) stop("bad input for argument 'shape'")
use.n = max(length(p), length(location), length(scale), length(shape))
ans = numeric(use.n)
@@ -114,11 +114,11 @@ qgev = function(p, location=0, scale=1, shape=0) {
scale = rep(scale, len=use.n); p = rep(p, len=use.n)
scase = abs(shape) < sqrt(.Machine$double.eps)
nscase = sum(scase)
- if(use.n - nscase) {
+ if (use.n - nscase) {
ans[!scase] = location[!scase] + scale[!scase] *
((-log(p[!scase]))^(-shape[!scase]) -1) / shape[!scase]
}
- if(nscase)
+ if (nscase)
ans[scase] = qgumbel(p[scase], location[scase], scale[scase])
ans[scale <= 0] = NaN
ans
@@ -133,8 +133,8 @@ qgev = function(p, location=0, scale=1, shape=0) {
lshape="logoff",
elocation = list(),
escale = list(),
- eshape = if(lshape=="logoff") list(offset=0.5) else
- if(lshape=="elogit") list(min=-0.5, max=0.5) else list(),
+ eshape = if (lshape=="logoff") list(offset=0.5) else
+ if (lshape=="elogit") list(min=-0.5, max=0.5) else list(),
percentiles=c(95,99),
iscale=NULL, ishape=NULL,
method.init=1, gshape=c(-0.45, 0.45),
@@ -143,34 +143,34 @@ qgev = function(p, location=0, scale=1, shape=0) {
{
- if(!is.logical(giveWarning) || length(giveWarning) != 1)
+ if (!is.logical(giveWarning) || length(giveWarning) != 1)
stop("bad input for argument 'giveWarning'")
mean = FALSE
- if(length(iscale) && !is.Numeric(iscale, posit=TRUE))
+ if (length(iscale) && !is.Numeric(iscale, posit=TRUE))
stop("bad input for argument 'iscale'")
- if(mode(lscale) != "character" && mode(lscale) != "name")
+ if (mode(lscale) != "character" && mode(lscale) != "name")
lscale = as.character(substitute(lscale))
- if(mode(llocation) != "character" && mode(llocation) != "name")
+ if (mode(llocation) != "character" && mode(llocation) != "name")
llocation = as.character(substitute(llocation))
- if(mode(lshape) != "character" && mode(lshape) != "name")
+ if (mode(lshape) != "character" && mode(lshape) != "name")
lshape = as.character(substitute(lshape))
- if(!mean && length(percentiles) &&
+ if (!mean && length(percentiles) &&
(!is.Numeric(percentiles, posit=TRUE) || max(percentiles) >= 100))
stop("bad input for argument 'percentiles'")
- if(!is.Numeric(method.init, allow=1, posit=TRUE, integer=TRUE) ||
+ if (!is.Numeric(method.init, allow=1, posit=TRUE, integer=TRUE) ||
method.init > 2.5)
stop("argument 'method.init' must be 1 or 2")
- if(length(ishape) && !is.Numeric(ishape))
+ if (length(ishape) && !is.Numeric(ishape))
stop("bad input for argument 'ishape'")
- if(!is.Numeric(tolshape0, allow=1, posit=TRUE) || tolshape0 > 0.1)
+ if (!is.Numeric(tolshape0, allow=1, posit=TRUE) || tolshape0 > 0.1)
stop("bad input for argument 'tolshape0'")
- if(!is.Numeric(gshape, allow=2) || gshape[1] >= gshape[2])
+ if (!is.Numeric(gshape, allow=2) || gshape[1] >= gshape[2])
stop("bad input for argument 'gshape'")
- if(length(zero) && !is.Numeric(zero, integer=TRUE, posit=TRUE))
+ if (length(zero) && !is.Numeric(zero, integer=TRUE, posit=TRUE))
stop("bad input for argument 'zero'")
- if(!is.list(elocation)) elocation = list()
- if(!is.list(escale)) escale = list()
- if(!is.list(eshape)) eshape = list()
+ 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",
@@ -187,36 +187,36 @@ qgev = function(p, location=0, scale=1, shape=0) {
namesof("scale", .lscale, earg= .escale, short=TRUE),
namesof("shape", .lshape, earg= .eshape, short=TRUE))
y = as.matrix(y)
- if(ncol(y) > 1)
+ 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))
+ if (any(r.vec == 0))
stop("A row contains all missing values")
extra$percentiles = .percentiles
- if(!length(etastart)) {
- init.sig= if(length( .iscale)) rep( .iscale, len=nrow(y)) else NULL
- init.xi = if(length( .ishape)) rep( .ishape, len=nrow(y)) else NULL
+ if (!length(etastart)) {
+ init.sig= if (length( .iscale)) rep( .iscale, len=nrow(y)) else NULL
+ init.xi = if (length( .ishape)) rep( .ishape, len=nrow(y)) else NULL
eshape = .eshape
- if( .lshape=="elogit" && length(init.xi) &&
+ if ( .lshape=="elogit" && length(init.xi) &&
(any(init.xi <= eshape$min | init.xi >= eshape$max)))
stop("bad input for argument 'eshape'")
- if( .method.init == 1) {
+ if ( .method.init == 1) {
nvector = 4:10 # Arbitrary; could be made an argument
ynvector = quantile(y[,1], 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
+ temp234 = if (length(init.xi)) init.xi[1] else
seq(gshape[1], gshape[2], len=12)
for(xi.try in temp234) {
- xvec = if(abs(xi.try) < .tolshape0) log(nvector) else
+ xvec = if (abs(xi.try) < .tolshape0) log(nvector) else
(nvector^xi.try - 1) / xi.try
fit0 = lsfit(x=xvec, y=ynvector, intercept=TRUE)
- sigmaTry = if(est.sigma)
+ sigmaTry = if (est.sigma)
rep(fit0$coef["X"], len=nrow(y)) else init.sig
muTry = rep(fit0$coef["Intercept"], len=nrow(y))
llTry = egev(giveWarning=
@@ -225,26 +225,26 @@ qgev = function(p, location=0, scale=1, shape=0) {
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)
+ if (llTry >= objecFunction) {
+ if (est.sigma)
init.sig = sigmaTry
init.mu = rep(muTry, len=nrow(y))
objecFunction = llTry
bestxi = xi.try
}
}
- if(!length(init.xi))
+ if (!length(init.xi))
init.xi = rep(bestxi, len=nrow(y))
} else {
init.xi = rep(0.05, len=nrow(y))
- if(!length(init.sig))
+ if (!length(init.sig))
init.sig = rep(sqrt(6 * var(y[,1]))/pi, len=nrow(y))
EulerM = -digamma(1)
init.mu = rep(median(y[,1]) - EulerM*init.sig, len=nrow(y))
}
bad = ((1 + init.xi*(y-init.mu)/init.sig) <= 0)
- if(fred <- sum(bad)) {
+ if (fred <- sum(bad)) {
warning(paste(fred, "observations violating boundary",
"constraints while initializing. Taking corrective action."))
init.xi[bad] = ifelse(y[bad] > init.mu[bad], 0.1, -0.1)
@@ -268,7 +268,7 @@ qgev = function(p, location=0, scale=1, shape=0) {
cent = extra$percentiles
lp = length(cent)
fv = matrix(as.numeric(NA), nrow(eta), lp)
- if(lp) {
+ if (lp) {
for(ii in 1:lp) {
yp = -log(cent[ii]/100)
fv[!iszero,ii] = loc[!iszero] - sigma[!iszero] *
@@ -294,9 +294,9 @@ qgev = function(p, location=0, scale=1, shape=0) {
misc$earg= list(location= .elocation, scale= .escale, shape= .eshape)
misc$expected = TRUE
misc$tolshape0 = .tolshape0
- if(ncol(y)==1)
+ if (ncol(y)==1)
y = as.vector(y)
- if(any(xi < -0.5))
+ if (any(xi < -0.5))
warning("some values of the shape parameter are less than -0.5")
}), list( .llocation=llocation, .lscale=lscale, .lshape=lshape,
.elocation = elocation, .escale = escale, .eshape= eshape,
@@ -313,14 +313,14 @@ qgev = function(p, location=0, scale=1, shape=0) {
ii = 1:nrow(eta)
A1 = A[cbind(ii, r.vec)]
mytolerance = 0 # .Machine$double.eps
- if(any(bad <- (A1 <= mytolerance), na.rm=TRUE)) {
+ if (any(bad <- (A1 <= mytolerance), na.rm=TRUE)) {
cat("There are",sum(bad),"range violations in @loglikelihood\n")
flush.console()
}
igev = !iszero & !bad
igum = iszero & !bad
pow = 1 + 1/xi[igev]
- if(residuals) stop("loglikelihood residuals not implemented yet") else {
+ if (residuals) stop("loglikelihood residuals not implemented yet") else {
old.answer =
sum(bad) * (-1.0e10) +
@@ -362,7 +362,7 @@ qgev = function(p, location=0, scale=1, shape=0) {
(log(A1) / xi^2 -
dA.dxi[cbind(ii,r.vec)] / (xi*A1)) * A1^(-1/xi)
- if(any(iszero)) {
+ if (any(iszero)) {
zorro = c(zedd[cbind(1:n,r.vec)])
zorro = zorro[iszero]
ezedd = exp(-zorro)
@@ -400,8 +400,8 @@ qgev = function(p, location=0, scale=1, shape=0) {
temp23 - tmp2 - r.vec*k0) / (sigma * k3)
wz[,iam(3,3,M)] = (2*tmp1*(-temp13) + tmp2 + r.vec*k0*temp33)/(k3*kay)
- if(any(iszero)) {
- if(ncol(y) > 1)
+ if (any(iszero)) {
+ if (ncol(y) > 1)
stop("cannot handle xi==0 with a multivariate response")
EulerM = -digamma(1)
@@ -413,7 +413,7 @@ qgev = function(p, location=0, scale=1, shape=0) {
wz[iszero,iam(2,3,M)] = (-dgammadx(2,3)/6 + dgammadx(1,1) +
2*dgammadx(1,2) + 2*dgammadx(1,3)/3) / sigma
- if(FALSE ) {
+ if (FALSE ) {
wz[,iam(1,2,M)] = 2 * r.vec / sigma^2
wz[,iam(2,2,M)] = -4 * r.vec * digamma(r.vec+1) + 2 * r.vec +
(4 * dgammadx(r.vec+1, der=1) -
@@ -434,16 +434,16 @@ qgev = function(p, location=0, scale=1, shape=0) {
dgammadx = function(x, deriv.arg=1) {
- if(deriv.arg==0) {
+ if (deriv.arg==0) {
gamma(x)
- } else if(deriv.arg == 1) {
+ } else if (deriv.arg == 1) {
digamma(x) * gamma(x)
- } else if(deriv.arg == 2) {
+ } else if (deriv.arg == 2) {
gamma(x) * (trigamma(x) + digamma(x)^2)
- } else if(deriv.arg == 3) {
+ } else if (deriv.arg == 3) {
gamma(x) * (psigamma(x, der=2) + 2 * digamma(x) * trigamma(x)) +
dgammadx(x, der=1) * (trigamma(x) + digamma(x)^2)
- } else if(deriv.arg == 4) {
+ } else if (deriv.arg == 4) {
dgammadx(x, der=2) * (trigamma(x) + digamma(x)^2) +
2 * dgammadx(x, der=1) * (psigamma(x, der=2) + 2*digamma(x) * trigamma(x)) +
gamma(x) * (psigamma(x, der=3) + 2*trigamma(x)^2 +
@@ -459,41 +459,41 @@ dgammadx = function(x, deriv.arg=1) {
lshape="logoff",
elocation = list(),
escale = list(),
- eshape = if(lshape=="logoff") list(offset=0.5) else
- if(lshape=="elogit") list(min=-0.5, max=0.5) else list(),
+ eshape = if (lshape=="logoff") list(offset=0.5) else
+ if (lshape=="elogit") list(min=-0.5, max=0.5) else list(),
percentiles=c(95,99),
iscale=NULL, ishape=NULL,
method.init=1, gshape=c(-0.45, 0.45),
tolshape0=0.001, giveWarning=TRUE,
zero=3)
{
- if(!is.logical(giveWarning) || length(giveWarning) != 1)
+ if (!is.logical(giveWarning) || length(giveWarning) != 1)
stop("bad input for argument 'giveWarning'")
- if(length(iscale) && !is.Numeric(iscale, posit=TRUE))
+ if (length(iscale) && !is.Numeric(iscale, posit=TRUE))
stop("bad input for argument 'iscale'")
- if(mode(lscale) != "character" && mode(lscale) != "name")
+ if (mode(lscale) != "character" && mode(lscale) != "name")
lscale <- as.character(substitute(lscale))
- if(mode(llocation) != "character" && mode(llocation) != "name")
+ if (mode(llocation) != "character" && mode(llocation) != "name")
llocation <- as.character(substitute(llocation))
- if(mode(lshape) != "character" && mode(lshape) != "name")
+ if (mode(lshape) != "character" && mode(lshape) != "name")
lshape <- as.character(substitute(lshape))
- if(!is.Numeric(gshape, allow=2) || gshape[1] >= gshape[2])
+ if (!is.Numeric(gshape, allow=2) || gshape[1] >= gshape[2])
stop("bad input for argument 'gshape'")
- if(length(percentiles) &&
+ if (length(percentiles) &&
(!is.Numeric(percentiles, posit=TRUE) || max(percentiles) >= 100))
stop("bad input for argument 'percentiles'")
- if(!is.Numeric(method.init, allow=1, posit=TRUE, integer=TRUE) ||
+ if (!is.Numeric(method.init, allow=1, posit=TRUE, integer=TRUE) ||
method.init > 2.5)
stop("argument 'method.init' must be 1 or 2")
- if(length(ishape) && !is.Numeric(ishape))
+ if (length(ishape) && !is.Numeric(ishape))
stop("bad input for argument 'ishape'")
- if(!is.Numeric(tolshape0, allow=1, posit=TRUE) || tolshape0 > 0.1)
+ if (!is.Numeric(tolshape0, allow=1, posit=TRUE) || tolshape0 > 0.1)
stop("bad input for argument 'tolshape0'")
- if(length(zero) && !is.Numeric(zero, integer=TRUE, posit=TRUE))
+ if (length(zero) && !is.Numeric(zero, integer=TRUE, posit=TRUE))
stop("bad input for argument 'zero'")
- if(!is.list(elocation)) elocation = list()
- if(!is.list(escale)) escale = list()
- if(!is.list(eshape)) eshape = list()
+ 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",
@@ -509,28 +509,28 @@ dgammadx = function(x, deriv.arg=1) {
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)
+ 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, len=length(y)) else NULL
- init.xi = if(length( .ishape)) rep( .ishape, len=length(y)) else NULL
+ if (!length(etastart)) {
+ init.sig= if (length( .iscale)) rep( .iscale, len=length(y)) else NULL
+ init.xi = if (length( .ishape)) rep( .ishape, len=length(y)) else NULL
eshape = .eshape
- if( .lshape == "elogit" && length(init.xi) &&
+ if ( .lshape == "elogit" && length(init.xi) &&
(any(init.xi <= eshape$min | init.xi >= eshape$max)))
stop("bad input for argument 'eshape'")
- if( .method.init == 1) {
+ if ( .method.init == 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
+ temp234 = if (length(init.xi)) init.xi[1] else
seq(gshape[1], gshape[2], len=12)
for(xi.try in temp234) {
- xvec = if(abs(xi.try) < .tolshape0) log(nvector) else
+ 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) {
+ if (est.sigma) {
sigmaTry = rep(fit0$coef["X"], len=length(y))
} else {
sigmaTry = init.sig
@@ -542,27 +542,27 @@ dgammadx = function(x, deriv.arg=1) {
eta=cbind(theta2eta(muTry, .llocation, earg= .elocation),
theta2eta(sigmaTry, .lscale, earg= .escale),
theta2eta(xi.try, .lshape, earg= .eshape)))
- if(llTry >= objecFunction) {
- if(est.sigma)
+ if (llTry >= objecFunction) {
+ if (est.sigma)
init.sig = sigmaTry
init.mu = rep(muTry, len=length(y))
objecFunction = llTry
bestxi = xi.try
}
}
- if(!length(init.xi))
+ if (!length(init.xi))
init.xi = rep(bestxi, len=length(y))
} else {
init.xi = rep(if(length(init.xi)) init.xi else 0.05,
len=length(y))
- if(!length(init.sig))
+ if (!length(init.sig))
init.sig = rep(sqrt(6*var(y))/pi, len=length(y))
EulerM = -digamma(1)
init.mu = rep(median(y) - EulerM * init.sig, len=length(y))
}
bad <- (1 + init.xi*(y-init.mu)/init.sig <= 0)
- if(fred <- sum(bad, na.rm=TRUE)) {
+ 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)
@@ -588,7 +588,7 @@ dgammadx = function(x, deriv.arg=1) {
cent = extra$percentiles
lp <- length(cent)
fv <- matrix(as.numeric(NA), nrow(eta), lp)
- if(lp) {
+ if (lp) {
for(ii in 1:lp) {
yp = -log(cent[ii]/100)
fv[!iszero,ii] = loc[!iszero] - sigma[!iszero] *
@@ -615,7 +615,7 @@ dgammadx = function(x, deriv.arg=1) {
misc$earg= list(location= .elocation, scale= .escale, shape= .eshape)
misc$tolshape0 = .tolshape0
misc$expected = TRUE
- if(any(xi < -0.5))
+ if (any(xi < -0.5))
warning("some values of the shape parameter are less than -0.5")
}), list( .llocation=llocation, .lscale=lscale, .lshape=lshape,
.elocation = elocation, .escale = escale, .eshape= eshape,
@@ -626,7 +626,7 @@ dgammadx = function(x, deriv.arg=1) {
sigma <- eta2theta(eta[,2], .lscale, earg= .escale )
xi <- eta2theta(eta[,3], .lshape, earg= .eshape )
- if(residuals) stop("loglikelihood residuals not implemented yet") else {
+ if (residuals) stop("loglikelihood residuals not implemented yet") else {
sum(w * dgev(x=y, location=mmu, scale=sigma, shape=xi,
tolshape0 = .tolshape0,
log=TRUE, oobounds.log = -1.0e04,
@@ -647,14 +647,14 @@ dgammadx = function(x, deriv.arg=1) {
dA.dmu = -xi / sigma
dA.dsigma = -xi * zedd / sigma
pow = 1 + 1/xi
- if(any(bad <- A<=0, na.rm=TRUE)) stop(sum(bad, na.rm=TRUE),
+ if (any(bad <- A<=0, na.rm=TRUE)) stop(sum(bad, na.rm=TRUE),
" observations violating boundary constraints in '@deriv'")
AA = 1/(xi*A^pow)- pow/A
dl.dmu = dA.dmu * AA
dl.dsi = dA.dsigma * AA - 1/sigma
dl.dxi = log(A)/xi^2 - pow * dA.dxi / A -
(log(A)/xi^2 - dA.dxi /(xi*A)) * A^(-1/xi)
- if(any(iszero)) {
+ if (any(iszero)) {
ezedd = exp(-zedd[iszero])
dl.dmu[iszero] = (1-ezedd) / sigma[iszero]
dl.dsi[iszero] = (zedd[iszero] * (1-ezedd) - 1) / sigma[iszero]
@@ -669,7 +669,7 @@ dgammadx = function(x, deriv.arg=1) {
.tolshape0=tolshape0 ))),
weight=eval(substitute(expression({
bad <- A <= 0
- if(any(bad, na.rm = TRUE)) stop(sum(bad, na.rm=TRUE),
+ if (any(bad, na.rm = TRUE)) stop(sum(bad, na.rm=TRUE),
" observations violating boundary constraints in '@weight'")
kay = -xi # for the formulae
kay[abs(kay-0.5) < .tolshape0] = 0.501
@@ -686,7 +686,7 @@ dgammadx = function(x, deriv.arg=1) {
wz[,iam(1,3,M)] = -(qq + pp/kay) / (sigma * kay)
wz[,iam(2,3,M)] = (1-EulerM - (1-temp100)/kay - qq -
pp/kay) / (sigma * kay^2)
- if(any(iszero)) {
+ if (any(iszero)) {
wz[iszero,iam(2,2,M)] = (pi^2/6 + (1-EulerM)^2) / sigma^2
wz[iszero,iam(3,3,M)] = 2.4236
wz[iszero,iam(1,2,M)] = (digamma(2) + 2*(EulerM-1)) / sigma^2
@@ -710,8 +710,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, integ=TRUE, allow=1, posit=TRUE))
+ use.n = if ((length.n <- length(n)) > 1) length.n else
+ if (!is.Numeric(n, integ=TRUE, allow=1, posit=TRUE))
stop("bad input for argument 'n'") else n
answer = location - scale * log(-log(runif(use.n)))
@@ -720,13 +720,13 @@ rgumbel = function(n, location=0, scale=1) {
}
dgumbel = function(x, location=0, scale=1, log = FALSE) {
- if(!is.logical(log.arg <- log))
+ if (!is.logical(log.arg <- log))
stop("bad input for argument 'log'")
rm(log)
zedd = (x - location) / scale
logdensity = -zedd - exp(-zedd) - log(scale)
- if(log.arg) logdensity else exp(logdensity)
+ if (log.arg) logdensity else exp(logdensity)
}
qgumbel = function(p, location=0, scale=1) {
@@ -754,21 +754,21 @@ pgumbel = function(q, location=0, scale=1) {
R=NA, percentiles=c(95,99),
mpv=FALSE, zero=NULL)
{
- if(mode(llocation) != "character" && mode(llocation) != "name")
+ if (mode(llocation) != "character" && mode(llocation) != "name")
llocation = as.character(substitute(llocation))
- if(mode(lscale) != "character" && mode(lscale) != "name")
+ if (mode(lscale) != "character" && mode(lscale) != "name")
lscale = as.character(substitute(lscale))
- if(!is.logical(mpv) || length(mpv) != 1)
+ if (!is.logical(mpv) || length(mpv) != 1)
stop("bad input for argument 'mpv'")
- if(length(percentiles) &&
+ if (length(percentiles) &&
(!is.Numeric(percentiles, posit=TRUE) || max(percentiles) >= 100))
stop("bad input for argument 'percentiles'")
- if(length(zero) && !is.Numeric(zero, integer=TRUE, posit=TRUE))
+ if (length(zero) && !is.Numeric(zero, integer=TRUE, posit=TRUE))
stop("bad input for argument 'zero'")
- if(length(iscale) && !is.Numeric(iscale, posit=TRUE))
+ if (length(iscale) && !is.Numeric(iscale, posit=TRUE))
stop("bad input for argument 'iscale'")
- if(!is.list(elocation)) elocation = list()
- if(!is.list(escale)) escale = list()
+ if (!is.list(elocation)) elocation = list()
+ if (!is.list(escale)) escale = list()
new("vglmff",
blurb=c("Gumbel Distribution for Extreme Value Regression\n",
@@ -783,20 +783,20 @@ pgumbel = function(q, location=0, scale=1) {
c(namesof("location", .llocation, earg= .elocation, short=TRUE),
namesof("scale", .lscale, earg= .escale , short=TRUE))
y = as.matrix(y)
- if(ncol(y) > 1)
+ 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))
+ if (any(r.vec == 0))
stop("There is at least one row of the response containing all NAs")
- if(ncol(y) > 1) {
+ if (ncol(y) > 1) {
yiri = y[cbind(1:nrow(y), r.vec)]
- sc.init = if(is.Numeric( .iscale, posit=TRUE))
+ sc.init = if (is.Numeric( .iscale, posit=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, posit=TRUE))
+ sc.init = if (is.Numeric( .iscale, posit=TRUE))
.iscale else 1.1 * (0.01+sqrt(var(y)*6)) / pi
sc.init = rep(sc.init, len=n)
EulerM = -digamma(1)
@@ -808,7 +808,7 @@ pgumbel = function(q, location=0, scale=1) {
extra$mpv = .mpv
extra$percentiles = .percentiles
- if(!length(etastart))
+ if (!length(etastart))
etastart = cbind(theta2eta(loc.init, .llocation, earg= .elocation),
theta2eta(sc.init, .lscale, earg= .escale ))
}), list( .llocation=llocation, .lscale=lscale, .iscale=iscale,
@@ -819,19 +819,19 @@ pgumbel = function(q, location=0, scale=1) {
sigma = eta2theta(eta[,2], .lscale, earg= .escale ) # sigma
Percentiles = extra$percentiles
lp = length(Percentiles) # may be 0
- if(lp > 0) {
+ if (lp > 0) {
mpv = extra$mpv
mu = matrix(as.numeric(NA), nrow(eta), lp + mpv) # lp could be 0
Rvec = extra$R
for(ii in 1:lp) {
- ci = if(is.Numeric(Rvec)) Rvec * (1 - Percentiles[ii] / 100) else
+ ci = if (is.Numeric(Rvec)) Rvec * (1 - Percentiles[ii] / 100) else
-log(Percentiles[ii] / 100)
mu[,ii] = loc - sigma * log(ci)
}
- if(mpv)
+ if (mpv)
mu[,ncol(mu)] = loc - sigma * log(log(2))
dmn2 = paste(as.character(Percentiles), "%", sep="")
- if(mpv)
+ if (mpv)
dmn2 = c(dmn2, "MPV")
dimnames(mu) = list(dimnames(eta)[[1]], dmn2)
} else {
@@ -864,7 +864,7 @@ pgumbel = function(q, location=0, scale=1) {
index = (jay <= r.vec)
ans[index] = ans[index] - (y[index,jay]-loc[index]) / sigma[index]
}
- if(residuals) stop("loglikelihood residuals not implemented yet") else {
+ if (residuals) stop("loglikelihood residuals not implemented yet") else {
sum(w * ans)
@@ -908,21 +908,21 @@ pgumbel = function(q, location=0, scale=1) {
rgpd = function(n, location=0, scale=1, shape=0) {
- use.n = if((length.n <- length(n)) > 1) length.n else
- if(!is.Numeric(n, integ=TRUE, allow=1, posit=TRUE))
+ use.n = if ((length.n <- length(n)) > 1) length.n else
+ if (!is.Numeric(n, integ=TRUE, allow=1, posit=TRUE))
stop("bad input for argument 'n'") else n
- if(!is.Numeric(location)) stop("bad input for argument 'location'")
- if(!is.Numeric(shape)) stop("bad input for argument 'shape'")
+ 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, len=use.n); location = rep(location, len=use.n);
scale = rep(scale, len=use.n)
scase = abs(shape) < sqrt(.Machine$double.eps)
nscase = sum(scase)
- if(use.n - nscase)
+ if (use.n - nscase)
ans[!scase] = location[!scase] + scale[!scase] *
((runif(use.n-nscase))^(-shape[!scase])-1) / shape[!scase]
- if(nscase)
+ if (nscase)
ans[scase] = location[scase] - scale[scase] * log(runif(nscase))
ans[scale <= 0] = NaN
ans
@@ -933,13 +933,13 @@ rgpd = function(n, location=0, scale=1, shape=0) {
dgpd = function(x, location=0, scale=1, shape=0, log=FALSE,
tolshape0 = sqrt(.Machine$double.eps),
oobounds.log = -Inf, giveWarning=FALSE) {
- if(!is.logical(log.arg <- log))
+ if (!is.logical(log.arg <- log))
stop("bad input for argument 'log'")
rm(log)
- if(oobounds.log > 0)
+ if (oobounds.log > 0)
stop("bad input for argument 'oobounds.log'")
- if(!is.Numeric(tolshape0, allow=1, posit=TRUE))
+ if (!is.Numeric(tolshape0, allow=1, posit=TRUE))
stop("bad input for argument 'tolshape0'")
L = max(length(x), length(location), length(scale), length(shape))
shape = rep(shape, len=L); location = rep(location, len=L);
@@ -949,43 +949,43 @@ dgpd = function(x, location=0, scale=1, shape=0, log=FALSE,
logdensity = rep(log(0), len=L)
scase = abs(shape) < tolshape0
nscase = sum(scase)
- if(L - nscase) {
+ if (L - nscase) {
zedd = (x-location) / scale
xok = (!scase) & (zedd > 0) & (1 + shape*zedd > 0)
logdensity[xok] = -(1 + 1/shape[xok])*log1p(shape[xok]*zedd[xok]) -
log(scale[xok])
outofbounds = (!scase) & ((zedd <= 0) | (1 + shape*zedd <= 0))
- if(any(outofbounds)) {
+ if (any(outofbounds)) {
logdensity[outofbounds] = oobounds.log
no.oob = sum(outofbounds)
- if(giveWarning)
+ if (giveWarning)
warning(no.oob, " observation",
ifelse(no.oob > 1, "s are", " is"), " out of bounds")
}
}
- if(nscase) {
+ if (nscase) {
xok = scase & (x > location)
logdensity[xok] = -(x[xok]-location[xok])/scale[xok] - log(scale[xok])
outofbounds = scase & (x <= location)
- if(any(outofbounds)) {
+ if (any(outofbounds)) {
logdensity[outofbounds] = oobounds.log
no.oob = sum(outofbounds)
- if(giveWarning)
+ if (giveWarning)
warning(no.oob, " observation",
ifelse(no.oob > 1, "s are", " is"), " out of bounds")
}
}
logdensity[scale <= 0] = NaN
- if(log.arg) logdensity else exp(logdensity)
+ if (log.arg) logdensity else exp(logdensity)
}
pgpd = function(q, location=0, scale=1, shape=0) {
- if(!is.Numeric(q)) stop("bad input for argument 'q'")
- if(!is.Numeric(location)) stop("bad input for argument 'location'")
- if(!is.Numeric(shape)) stop("bad input for argument 'shape'")
+ if (!is.Numeric(q)) stop("bad input for argument 'q'")
+ if (!is.Numeric(location)) stop("bad input for argument 'location'")
+ if (!is.Numeric(shape)) stop("bad input for argument 'shape'")
use.n = max(length(q), length(location), length(scale), length(shape))
ans = numeric(use.n)
@@ -994,11 +994,11 @@ pgpd = function(q, location=0, scale=1, shape=0) {
q = rep(q-location, len=use.n) # Note the centering, careful with dgumbel()!
scase = abs(shape) < sqrt(.Machine$double.eps)
nscase = sum(scase)
- if(use.n - nscase) {
+ if (use.n - nscase) {
q[q<0] = 0
ans = 1 - pmax(0, (1+shape*q/scale))^(-1/shape)
}
- if(nscase) {
+ if (nscase) {
pos = q>=0
ind9 = pos & scase
ans[ind9] = -expm1(-q[ind9]/scale[ind9])
@@ -1017,11 +1017,11 @@ qgpd = function(p, location=0, scale=1, shape=0) {
scale = rep(scale, len=use.n); p = rep(p, len=use.n)
scase = abs(shape) < sqrt(.Machine$double.eps)
nscase = sum(scase)
- if(use.n - nscase) {
+ if (use.n - nscase) {
ans[!scase] = location[!scase] + scale[!scase] *
((1-p[!scase])^(-shape[!scase]) - 1) / shape[!scase]
}
- if(nscase) {
+ if (nscase) {
ans[scase] = location[scase] - scale[scase] * log1p(-p[scase])
}
@@ -1044,34 +1044,34 @@ qgpd = function(p, location=0, scale=1, shape=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,
+ 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,
method.init=1,
zero=2) {
- if(!is.logical(giveWarning) || length(giveWarning) != 1)
+ if (!is.logical(giveWarning) || length(giveWarning) != 1)
stop("bad input for argument 'giveWarning'")
- if(!is.Numeric(threshold))
+ if (!is.Numeric(threshold))
stop("bad input for argument 'threshold'")
- if(!is.Numeric(method.init, allow=1, posit=TRUE, integer=TRUE) ||
+ if (!is.Numeric(method.init, allow=1, posit=TRUE, integer=TRUE) ||
method.init > 2.5)
stop("argument 'method.init' must be 1 or 2")
- if(mode(lscale) != "character" && mode(lscale) != "name")
+ if (mode(lscale) != "character" && mode(lscale) != "name")
lscale = as.character(substitute(lscale))
- if(mode(lshape) != "character" && mode(lshape) != "name")
+ if (mode(lshape) != "character" && mode(lshape) != "name")
lshape = as.character(substitute(lshape))
- if(length(percentiles) &&
+ if (length(percentiles) &&
(!is.Numeric(percentiles, posit=TRUE) || max(percentiles) >= 100))
stop("bad input for argument 'percentiles'")
- if(!is.Numeric(tolshape0, allow=1, posit=TRUE) || tolshape0 > 0.1)
+ if (!is.Numeric(tolshape0, allow=1, posit=TRUE) || tolshape0 > 0.1)
stop("bad input for argument 'tolshape0'")
- if(length(zero) && !is.Numeric(zero, integer=TRUE, posit=TRUE))
+ if (length(zero) && !is.Numeric(zero, integer=TRUE, posit=TRUE))
stop("bad input for argument 'zero'")
- if(!is.list(escale)) escale = list()
- if(!is.list(eshape)) eshape = list()
+ if (!is.list(escale)) escale = list()
+ if (!is.list(eshape)) eshape = list()
new("vglmff",
blurb=c("Generalized Pareto Distribution\n",
@@ -1082,10 +1082,10 @@ qgpd = function(p, location=0, scale=1, shape=0) {
constraints = cm.zero.vgam(constraints, x, .zero, M)
}), list( .zero=zero ))),
initialize=eval(substitute(expression({
- if(ncol(as.matrix(y)) != 1)
+ if (ncol(as.matrix(y)) != 1)
stop("response must be a vector or one-column matrix")
- Threshold = if(is.Numeric( .threshold)) .threshold else 0
- if(is.Numeric( .threshold)) {
+ Threshold = if (is.Numeric( .threshold)) .threshold else 0
+ if (is.Numeric( .threshold)) {
orig.y = y
}
ystar = y - Threshold # Operate on ystar
@@ -1093,21 +1093,21 @@ qgpd = function(p, location=0, scale=1, shape=0) {
predictors.names=
c(namesof("scale", .lscale, earg= .escale, short=TRUE),
namesof("shape", .lshape, earg= .eshape, short=TRUE ))
- if(!length(etastart)) {
+ if (!length(etastart)) {
meany = mean(ystar)
vary = var(ystar)
- init.xi = if(length( .ishape)) .ishape else {
- if( .method.init == 1) -0.5*(meany^2/vary - 1) else
+ init.xi = if (length( .ishape)) .ishape else {
+ if ( .method.init == 1) -0.5*(meany^2/vary - 1) else
0.5 * (1 - median(ystar)^2 / vary)
}
- init.sig = if(length( .iscale)) .iscale else {
- if(.method.init==1) 0.5*meany*(meany^2/vary + 1) else
+ init.sig = if (length( .iscale)) .iscale else {
+ if (.method.init==1) 0.5*meany*(meany^2/vary + 1) else
abs(1-init.xi) * median(ystar)
}
init.sig[init.sig <= 0] = 0.01 # sigma > 0
init.xi[init.xi <= -0.5] = -0.40 # Fisher scoring works if xi > -0.5
init.xi[init.xi >= 1.0] = 0.90 # Mean/var exists if xi < 1 / 0.5
- if( .lshape == "loge") init.xi[init.xi <= 0.0] = 0.05
+ if ( .lshape == "loge") init.xi[init.xi <= 0.0] = 0.05
init.sig = rep(init.sig, leng=length(y))
init.xi = rep(init.xi, leng=length(y))
@@ -1123,8 +1123,8 @@ qgpd = function(p, location=0, scale=1, shape=0) {
xi = eta2theta(eta[,2], .lshape, earg= .eshape )
cent = .percentiles
lp = length(cent) # NULL means lp==0 and the mean is returned
- Threshold = if(is.Numeric( .threshold)) .threshold else 0
- if(lp) {
+ Threshold = if (is.Numeric( .threshold)) .threshold else 0
+ if (lp) {
fv = matrix(as.numeric(NA), nrow(eta), lp)
iszero = (abs(xi) < .tolshape0)
for(ii in 1:lp) {
@@ -1148,10 +1148,10 @@ qgpd = function(p, location=0, scale=1, shape=0) {
misc$true.mu = FALSE # @fitted is not a true mu
misc$earg= list(scale= .escale , shape= .eshape )
misc$percentiles = .percentiles
- misc$threshold = if(is.Numeric( .threshold)) .threshold else 0
+ misc$threshold = if (is.Numeric( .threshold)) .threshold else 0
misc$expected = TRUE
misc$tolshape0 = .tolshape0
- if(any(xi < -0.5))
+ if (any(xi < -0.5))
warning("some values of the shape parameter are less than -0.5")
}), list( .lscale=lscale, .lshape=lshape, .threshold=threshold,
.escale=escale, .eshape=eshape,
@@ -1161,7 +1161,7 @@ qgpd = function(p, location=0, scale=1, shape=0) {
sigma = eta2theta(eta[,1], .lscale, earg= .escale )
xi = eta2theta(eta[,2], .lshape, earg= .eshape )
Threshold = extra$threshold
- if(residuals) stop("loglikelihood residuals not implemented yet") else {
+ if (residuals) stop("loglikelihood residuals not implemented yet") else {
sum(w * dgpd(x=y, location=Threshold, scale=sigma, shape=xi,
tolshape0 = .tolshape0, giveWarning= .giveWarning,
log=TRUE, oobounds.log = -1.0e04))
@@ -1178,12 +1178,12 @@ qgpd = function(p, location=0, scale=1, shape=0) {
A = 1 + xi*ystar/sigma
mytolerance = .Machine$double.eps
bad <- (A <= mytolerance)
- if(any(bad) && any(w[bad] != 0)) {
+ if (any(bad) && any(w[bad] != 0)) {
cat(sum(w[bad],na.rm=TRUE), # "; ignoring them"
"observations violating boundary constraints\n")
flush.console()
}
- if(any(iszero <- (abs(xi) < .tolshape0))) {
+ if (any(iszero <- (abs(xi) < .tolshape0))) {
}
igpd = !iszero & !bad
iexp = iszero & !bad
@@ -1220,7 +1220,7 @@ qgpd = function(p, location=0, scale=1, shape=0) {
meplot.default = function(y, main="Mean Excess Plot",
xlab="Threshold", ylab="Mean Excess", lty=c(2,1:2),
conf=0.95, col=c("blue","black","blue"), type="l", ...) {
- if(!is.Numeric(y)) stop("bad input for argument 'y'")
+ if (!is.Numeric(y)) stop("bad input for argument 'y'")
n = length(y)
sy = sort(y)
dsy = rev(sy) # decreasing sequence
@@ -1236,7 +1236,7 @@ meplot.default = function(y, main="Mean Excess Plot",
}
meplot.vlm = function(object, ...) {
- if(!length(y <- object at y)) stop("y slot is empty")
+ if (!length(y <- object at y)) stop("y slot is empty")
ans = meplot(as.numeric(y), ...)
invisible(ans)
}
@@ -1256,7 +1256,7 @@ setMethod("meplot", "vlm",
guplot.default = function(y, main="Gumbel Plot",
xlab="Reduced data", ylab="Observed data", type="p", ...) {
- if(!is.Numeric(y)) stop("bad input for argument 'y'")
+ if (!is.Numeric(y)) stop("bad input for argument 'y'")
n = length(y)
sy = sort(y)
x = -log(-log(((1:n) - 0.5) / n))
@@ -1265,7 +1265,7 @@ guplot.default = function(y, main="Gumbel Plot",
}
guplot.vlm = function(object, ...) {
- if(!length(y <- object at y)) stop("y slot is empty")
+ if (!length(y <- object at y)) stop("y slot is empty")
ans = guplot(as.numeric(y), ...)
invisible(ans)
}
@@ -1294,21 +1294,21 @@ setMethod("guplot", "vlm",
R=NA, percentiles=c(95,99),
mpv=FALSE, zero=NULL)
{
- if(mode(llocation) != "character" && mode(llocation) != "name")
+ if (mode(llocation) != "character" && mode(llocation) != "name")
llocation = as.character(substitute(llocation))
- if(mode(lscale) != "character" && mode(lscale) != "name")
+ if (mode(lscale) != "character" && mode(lscale) != "name")
lscale = as.character(substitute(lscale))
- if(!is.logical(mpv) || length(mpv) != 1)
+ if (!is.logical(mpv) || length(mpv) != 1)
stop("bad input for argument 'mpv'")
- if(length(percentiles) &&
+ if (length(percentiles) &&
(!is.Numeric(percentiles, posit=TRUE) || max(percentiles) >= 100))
stop("bad input for argument 'percentiles'")
- if(length(zero) && !is.Numeric(zero, integer=TRUE, posit=TRUE))
+ if (length(zero) && !is.Numeric(zero, integer=TRUE, posit=TRUE))
stop("bad input for argument 'zero'")
- if(length(iscale) && !is.Numeric(iscale, posit=TRUE))
+ if (length(iscale) && !is.Numeric(iscale, posit=TRUE))
stop("bad input for argument 'iscale'")
- if(!is.list(elocation)) elocation = list()
- if(!is.list(escale)) escale = list()
+ if (!is.list(elocation)) elocation = list()
+ if (!is.list(escale)) escale = list()
new("vglmff",
blurb=c("Gumbel distribution (univariate response)\n\n",
@@ -1322,9 +1322,9 @@ setMethod("guplot", "vlm",
}), list( .zero=zero ))),
initialize=eval(substitute(expression({
y = cbind(y)
- if(ncol(y) > 1)
+ if (ncol(y) > 1)
stop("Use gumbel() to handle multivariate responses")
- if(min(y) <= 0)
+ if (min(y) <= 0)
stop("all response values must be positive")
predictors.names =
c(namesof("location", .llocation, earg= .elocation, tag= FALSE),
@@ -1334,8 +1334,8 @@ setMethod("guplot", "vlm",
extra$mpv = .mpv
extra$percentiles = .percentiles
- if(!length(etastart)) {
- sc.init = if(is.Numeric( .iscale, posit=TRUE))
+ if (!length(etastart)) {
+ sc.init = if (is.Numeric( .iscale, posit=TRUE))
.iscale else 1.5 * (0.01+sqrt(var(y)*6)) / pi
sc.init = rep(sc.init, len=n)
EulerM = -digamma(1)
@@ -1353,19 +1353,19 @@ setMethod("guplot", "vlm",
Percentiles = extra$percentiles
mpv = extra$mpv
lp = length(Percentiles) # may be 0
- if(!lp) return(loc + sigma * EulerM)
+ if (!lp) return(loc + sigma * EulerM)
mu = matrix(as.numeric(NA), nrow(eta), lp + mpv)
Rvec = extra$R
- if(1 <= lp)
+ if (1 <= lp)
for(ii in 1:lp) {
- ci = if(is.Numeric(Rvec)) Rvec * (1 - Percentiles[ii] / 100) else
+ ci = if (is.Numeric(Rvec)) Rvec * (1 - Percentiles[ii] / 100) else
-log( Percentiles[ii] / 100)
mu[,ii] = loc - sigma * log(ci)
}
- if(mpv)
+ if (mpv)
mu[,ncol(mu)] = loc - sigma * log(log(2))
- dmn2 = if(lp>=1) paste(as.character(Percentiles), "%", sep="") else NULL
- if(mpv)
+ 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
@@ -1385,7 +1385,7 @@ setMethod("guplot", "vlm",
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 {
+ 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,
@@ -1425,19 +1425,19 @@ setMethod("guplot", "vlm",
escale = list(), iscale=NULL,
mean=TRUE, percentiles=NULL, zero=2)
{
- if(mode(llocation) != "character" && mode(llocation) != "name")
+ if (mode(llocation) != "character" && mode(llocation) != "name")
llocation = as.character(substitute(llocation))
- if(mode(lscale) != "character" && mode(lscale) != "name")
+ if (mode(lscale) != "character" && mode(lscale) != "name")
lscale = as.character(substitute(lscale))
- if(!is.logical(mean) || length(mean) != 1)
+ if (!is.logical(mean) || length(mean) != 1)
stop("mean must be a single logical value")
- if(!mean && (!is.Numeric(percentiles, posit=TRUE) ||
+ if (!mean && (!is.Numeric(percentiles, posit=TRUE) ||
any(percentiles>=100)))
stop("valid percentiles values must be given when mean=FALSE")
- if(length(zero) && !is.Numeric(zero, integer=TRUE, posit=TRUE))
+ if (length(zero) && !is.Numeric(zero, integer=TRUE, posit=TRUE))
stop("bad input for argument 'zero'")
- if(!is.list(elocation)) elocation = list()
- if(!is.list(escale)) escale = list()
+ if (!is.list(elocation)) elocation = list()
+ if (!is.list(escale)) escale = list()
new("vglmff",
blurb=c("Censored Gumbel distribution\n\n",
@@ -1452,21 +1452,21 @@ setMethod("guplot", "vlm",
}), list( .zero=zero ))),
initialize=eval(substitute(expression({
y = cbind(y)
- if(ncol(y) > 1)
+ if (ncol(y) > 1)
stop("Use gumbel.block() to handle multivariate responses")
- if(any(y) <= 0)
+ if (any(y) <= 0)
stop("all response values must be positive")
- if(!length(extra$leftcensored)) extra$leftcensored = rep(FALSE, len=n)
- if(!length(extra$rightcensored)) extra$rightcensored = rep(FALSE, len=n)
- if(any(extra$rightcensored & extra$leftcensored))
+ if (!length(extra$leftcensored)) extra$leftcensored = rep(FALSE, len=n)
+ if (!length(extra$rightcensored)) extra$rightcensored = rep(FALSE, len=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))
- if(!length(etastart)) {
- sc.init = if(is.Numeric( .iscale, posit=TRUE))
+ if (!length(etastart)) {
+ sc.init = if (is.Numeric( .iscale, posit=TRUE))
.iscale else 1.1 * sqrt(var(y) * 6 ) / pi
sc.init = rep(sc.init, len=n)
EulerM = -digamma(1)
@@ -1482,7 +1482,7 @@ setMethod("guplot", "vlm",
loc = eta2theta(eta[,1], .llocation)
sc = eta2theta(eta[,2], .lscale)
EulerM = -digamma(1)
- if(.mean) loc + sc * EulerM else {
+ if (.mean) loc + sc * EulerM else {
lp = length(.percentiles) # 0 if NULL
mu = matrix(as.numeric(NA), nrow(eta), lp)
for(ii in 1:lp) {
@@ -1519,7 +1519,7 @@ setMethod("guplot", "vlm",
ell1 = -log(sc[cen0]) - zedd[cen0] - exp(-zedd[cen0])
ell2 = log(Fy[cenL])
ell3 = log1p(-Fy[cenU])
- if(residuals) stop("loglikelihood residuals not implemented yet") else
+ if (residuals) stop("loglikelihood residuals not implemented yet") else
sum(w[cen0] * ell1) + sum(w[cenL] * ell2) + sum(w[cenU] * ell3)
}, list( .lscale=lscale,
.llocation = llocation,
@@ -1543,11 +1543,11 @@ setMethod("guplot", "vlm",
Fy = exp(-ezedd)
dFy.dloc = -ezedd * Fy / sc
dFy.dsc = zedd * dFy.dloc # -zedd * exp(-zedd) * Fy / sc
- if(any(cenL)) {
+ if (any(cenL)) {
dl.dloc[cenL] = -ezedd[cenL] / sc[cenL]
dl.dsc[cenL] = -zedd[cenL] * ezedd[cenL] / sc[cenL]
}
- if(any(cenU)) {
+ if (any(cenU)) {
dl.dloc[cenU] = -dFy.dloc[cenU] / (1-Fy[cenU])
dl.dsc[cenU] = -dFy.dsc[cenU] / (1-Fy[cenU])
}
@@ -1589,7 +1589,7 @@ setMethod("guplot", "vlm",
dfrechet = function(x, location=0, scale=1, shape, log=FALSE) {
- if(!is.logical(log.arg <- log))
+ if (!is.logical(log.arg <- log))
stop("bad input for argument 'log'")
rm(log)
@@ -1602,12 +1602,12 @@ dfrechet = function(x, location=0, scale=1, shape, log=FALSE) {
(shape[xok]+1) * log(rzedd[xok]) - log(scale[xok])
logdensity[shape <= 0] = NaN
logdensity[scale <= 0] = NaN
- if(log.arg) logdensity else exp(logdensity)
+ if (log.arg) logdensity else exp(logdensity)
}
pfrechet = function(q, location=0, scale=1, shape) {
- if(!is.Numeric(scale, posit=TRUE)) stop("scale must be positive")
- if(!is.Numeric(shape, posit=TRUE)) stop("shape must be positive")
+ if (!is.Numeric(scale, posit=TRUE)) stop("scale must be positive")
+ if (!is.Numeric(shape, posit=TRUE)) stop("shape must be positive")
rzedd = scale / (q - location)
ans = exp(-(rzedd^shape))
ans[q <= location] = 0
@@ -1615,17 +1615,17 @@ pfrechet = function(q, location=0, scale=1, shape) {
}
qfrechet = function(p, location=0, scale=1, shape) {
- if(!is.Numeric(p, posit=TRUE) || any(p >= 1)) stop("0 < p < 1 is required")
- if(!is.Numeric(scale, posit=TRUE)) stop("scale must be positive")
- if(!is.Numeric(shape, posit=TRUE)) stop("shape must be positive")
+ if (!is.Numeric(p, posit=TRUE) || any(p >= 1)) stop("0 < p < 1 is required")
+ if (!is.Numeric(scale, posit=TRUE)) stop("scale must be positive")
+ if (!is.Numeric(shape, posit=TRUE)) stop("shape must be positive")
location + scale * (-log(p))^(-1/shape)
}
rfrechet = function(n, location=0, scale=1, shape) {
- if(!is.Numeric(n, posit=TRUE, allow=1, integ=TRUE))
+ if (!is.Numeric(n, posit=TRUE, allow=1, integ=TRUE))
stop("bad input for argument 'n'")
- if(!is.Numeric(scale, posit=TRUE)) stop("scale must be positive")
- if(!is.Numeric(shape, posit=TRUE)) stop("shape must be positive")
+ if (!is.Numeric(scale, posit=TRUE)) stop("scale must be positive")
+ if (!is.Numeric(shape, posit=TRUE)) stop("shape must be positive")
location + scale * (-log(runif(n)))^(-1/shape)
}
@@ -1642,14 +1642,14 @@ frechet2.control <- function(save.weight=TRUE, ...)
iscale=NULL, ishape=3,
zero=NULL)
{
- if(!is.Numeric(location))
+ if (!is.Numeric(location))
stop("bad input for argument 'location'")
- if(mode(lscale) != "character" && mode(lscale) != "name")
+ if (mode(lscale) != "character" && mode(lscale) != "name")
lscale <- as.character(substitute(lscale))
- if(mode(lshape) != "character" && mode(lshape) != "name")
+ if (mode(lshape) != "character" && mode(lshape) != "name")
lshape <- as.character(substitute(lshape))
- if(!is.list(escale)) escale = list()
- if(!is.list(eshape)) eshape = list()
+ if (!is.list(escale)) escale = list()
+ if (!is.list(eshape)) eshape = list()
new("vglmff",
blurb=c("2-parameter Frechet Distribution\n",
@@ -1664,16 +1664,16 @@ frechet2.control <- function(save.weight=TRUE, ...)
c(namesof("scale", .lscale, earg=.escale, short=TRUE),
namesof("shape", .lshape, earg=.eshape, short=TRUE))
extra$location = rep( .location, len=n) # stored here
- if(!length(etastart)) {
+ if (!length(etastart)) {
# Initial values for limiting case as xi --> 0, r_i==1
locinit = extra$location
- if(any(y <= locinit))
- stop("initial values for location are out of range")
- shape.init = if(length( .ishape)) rep( .ishape, len=n) else {
+ if (any(y <= locinit))
+ stop("initial values for 'location' are out of range")
+ shape.init = if (length( .ishape)) rep( .ishape, len=n) else {
rep(3.0, len=n) # variance exists if shape>2
}
- Scale.init = if(length( .iscale)) rep( .iscale, len=n) else {
- if(all(shape.init > 1))
+ Scale.init = if (length( .iscale)) rep( .iscale, len=n) else {
+ if (all(shape.init > 1))
abs( (y-locinit+0.001) / (gamma(1-1/shape.init)) ) else
rep( 1.0, len=n)
}
@@ -1705,7 +1705,7 @@ frechet2.control <- function(save.weight=TRUE, ...)
Scale = eta2theta(eta[,1], .lscale, earg= .escale )
shape = eta2theta(eta[,2], .lshape, earg= .eshape )
rzedd = Scale / (y-loc)
- if(residuals) stop("loglikelihood residuals not implemented yet") else
+ if (residuals) stop("loglikelihood residuals not implemented yet") else
sum(w * dfrechet(x=y, location=loc, scale=Scale, shape=shape,
log=TRUE))
}, list( .lscale=lscale, .lshape=lshape,
@@ -1719,7 +1719,7 @@ frechet2.control <- function(save.weight=TRUE, ...)
dl.dloc = (shape+1)/(y-loc) - (shape / (y-loc)) * (rzedd)^shape
dl.dScale = shape * (1-rzedd^shape) / Scale
dl.dshape = 1/shape + log(rzedd) * (1 - rzedd^shape)
- if(iter == 1) {
+ if (iter == 1) {
etanew = eta
} else {
derivold = derivnew
@@ -1733,7 +1733,7 @@ frechet2.control <- function(save.weight=TRUE, ...)
}), list( .lscale=lscale, .lshape=lshape,
.escale=escale, .eshape=eshape ))),
weight=eval(substitute(expression({
- if(iter == 1) {
+ if (iter == 1) {
wznew = cbind(matrix(w, n, M), matrix(0, n, dimm(M)-M))
} else {
wzold = wznew
@@ -1763,17 +1763,17 @@ frechet3.control <- function(save.weight=TRUE, ...)
ilocation=NULL, iscale=NULL, ishape=3, zero=NULL,
effpos = .Machine$double.eps^0.75)
{
- if(mode(ldifference) != "character" && mode(ldifference) != "name")
+ if (mode(ldifference) != "character" && mode(ldifference) != "name")
ldifference <- as.character(substitute(ldifference))
- if(mode(lscale) != "character" && mode(lscale) != "name")
+ if (mode(lscale) != "character" && mode(lscale) != "name")
lscale <- as.character(substitute(lscale))
- if(mode(lshape) != "character" && mode(lshape) != "name")
+ if (mode(lshape) != "character" && mode(lshape) != "name")
lshape <- as.character(substitute(lshape))
- if(!is.Numeric(ishape, allo=1, posi=TRUE)) stop("bad input for argument 'ishape'")
- if(!is.Numeric(effpos, allo=1)|| effpos<0) stop("bad input for argument 'effpos'")
- if(!is.list(edifference)) edifference = list()
- if(!is.list(escale)) escale = list()
- if(!is.list(eshape)) eshape = list()
+ if (!is.Numeric(ishape, allo=1, posi=TRUE)) stop("bad input for argument 'ishape'")
+ if (!is.Numeric(effpos, allo=1)|| effpos<0) stop("bad input for argument 'effpos'")
+ if (!is.list(edifference)) edifference = list()
+ if (!is.list(escale)) escale = list()
+ if (!is.list(eshape)) eshape = list()
new("vglmff",
blurb=c("3-parameter Frechet Distribution\n",
@@ -1789,21 +1789,21 @@ frechet3.control <- function(save.weight=TRUE, ...)
c(namesof("difference", .ldifference, earg= .edifference, short=TRUE),
namesof("scale", .lscale, earg= .escale, short=TRUE),
namesof("shape", .lshape, earg= .eshape, short=TRUE))
- anchorpt = if(is.Numeric( .anchor, allow=1)) .anchor else min(y)
- if(min(y) < anchorpt) stop("anchor point is too large")
+ anchorpt = if (is.Numeric( .anchor, allow=1)) .anchor else min(y)
+ if (min(y) < anchorpt) stop("anchor point is too large")
extra$LHSanchor = anchorpt
- if(!length(etastart)) {
- locinit = if(length( .ilocation)) rep( .ilocation, len=n) else
+ if (!length(etastart)) {
+ locinit = if (length( .ilocation)) rep( .ilocation, len=n) else
rep(anchorpt - 0.01*diff(range(y)), len=n)
- if(any(y <= locinit))
- stop("initial values for location are out of range")
- if(any(anchorpt <= locinit))
+ if (any(y <= locinit))
+ stop("initial values for 'location' are out of range")
+ if (any(anchorpt <= locinit))
stop("require anchor point > initial location parameter value")
- shape.init = if(length( .ishape)) rep( .ishape, len=n) else {
+ shape.init = if (length( .ishape)) rep( .ishape, len=n) else {
rep(3.0, len=n) # variance exists if shape>2
}
- Scale.init = if(length( .iscale)) rep( .iscale, len=n) else {
- if(all(shape.init > 1))
+ Scale.init = if (length( .iscale)) rep( .iscale, len=n) else {
+ if (all(shape.init > 1))
abs( (y-locinit+0.001) / (gamma(1-1/shape.init)) ) else
rep( 1.0, len=n)
}
@@ -1838,7 +1838,7 @@ frechet3.control <- function(save.weight=TRUE, ...)
eta2theta(eta[,1], .ldifference, earg= .edifference)
Scale = eta2theta(eta[,2], .lscale, earg= .escale )
shape = eta2theta(eta[,3], .lshape, earg= .eshape )
- if(residuals) stop("loglikelihood residuals not implemented yet") else {
+ if (residuals) stop("loglikelihood residuals not implemented yet") else {
sum(w * dfrechet(x=y, location=loc, scale=Scale, shape=shape,
log=TRUE))
}
@@ -1856,7 +1856,7 @@ frechet3.control <- function(save.weight=TRUE, ...)
dl.ddiff = -dl.dloc
dl.dScale = shape * (1-rzedd^shape) / Scale
dl.dshape = 1/shape + log(rzedd) * (1 - rzedd^shape)
- if(iter == 1) {
+ if (iter == 1) {
etanew = eta
} else {
derivold = derivnew
@@ -1872,7 +1872,7 @@ frechet3.control <- function(save.weight=TRUE, ...)
}), list( .ldifference=ldifference, .lscale=lscale, .lshape=lshape,
.edifference=edifference, .escale=escale, .eshape=eshape ))),
weight=eval(substitute(expression({
- if(iter == 1) {
+ if (iter == 1) {
wznew = cbind(matrix(w, n, M), matrix(0, n, dimm(M)-M))
} else {
wzold = wznew
@@ -1894,11 +1894,11 @@ recnormal1.control <- function(save.weight=TRUE, ...)
imean=NULL, isd=NULL, method.init=1, zero=NULL)
{
- if(mode(lmean) != "character" && mode(lmean) != "name")
+ if (mode(lmean) != "character" && mode(lmean) != "name")
lmean = as.character(substitute(lmean))
- if(mode(lsd) != "character" && mode(lsd) != "name")
+ if (mode(lsd) != "character" && mode(lsd) != "name")
lsd = as.character(substitute(lsd))
- if(!is.Numeric(method.init, allow=1, integ=TRUE, positi=TRUE) ||
+ if (!is.Numeric(method.init, allow=1, integ=TRUE, positi=TRUE) ||
method.init > 3.5)
stop("argument 'method.init' must be 1 or 2 or 3")
@@ -1915,18 +1915,18 @@ recnormal1.control <- function(save.weight=TRUE, ...)
initialize=eval(substitute(expression({
predictors.names = c(namesof("mean", .lmean, tag= FALSE),
namesof("sd", .lsd, tag= FALSE))
- if(ncol(y <- cbind(y)) != 1)
+ if (ncol(y <- cbind(y)) != 1)
stop("response must be a vector or a one-column matrix")
- if(any(diff(y) <= 0))
+ if (any(diff(y) <= 0))
stop("response must have increasingly larger and larger values")
- if(any(w != 1))
+ if (any(w != 1))
warning("weights should have unit values only")
- if(!length(etastart)) {
- mean.init = if(length( .imean)) rep( .imean, len=n) else {
- if(.lmean == "loge") pmax(1/1024, min(y)) else min(y)}
- sd.init = if(length( .isd)) rep( .isd, len=n) else {
- if(.method.init == 1) 1*(sd(y)) else
- if(.method.init == 2) 5*(sd(y)) else
+ if (!length(etastart)) {
+ mean.init = if (length( .imean)) rep( .imean, len=n) else {
+ if (.lmean == "loge") pmax(1/1024, min(y)) else min(y)}
+ sd.init = if (length( .isd)) rep( .isd, len=n) else {
+ if (.method.init == 1) 1*(sd(y)) else
+ if (.method.init == 2) 5*(sd(y)) else
.5*(sd(y))
}
etastart = cbind(theta2eta(rep(mean.init, len=n), .lmean),
@@ -1944,7 +1944,7 @@ recnormal1.control <- function(save.weight=TRUE, ...)
loglikelihood=eval(substitute(
function(mu,y,w,residuals= FALSE,eta, extra=NULL) {
sd = eta2theta(eta[,2], .lsd)
- if(residuals) stop("loglikelihood residuals not implemented yet") else {
+ if (residuals) stop("loglikelihood residuals not implemented yet") else {
zedd = (y - mu) / sd
NN = nrow(eta)
sum(w * (-log(sd) - 0.5 * zedd^2)) -
@@ -1964,7 +1964,7 @@ recnormal1.control <- function(save.weight=TRUE, ...)
dl.dsd[NN] = (-1 + zedd[NN]^2) / sd[NN]
dmu.deta = dtheta.deta(mymu, .lmean)
dsd.deta = dtheta.deta(sd, .lsd)
- if(iter == 1) {
+ if (iter == 1) {
etanew = eta
} else {
derivold = derivnew
@@ -1975,7 +1975,7 @@ recnormal1.control <- function(save.weight=TRUE, ...)
derivnew
}), list( .lmean=lmean, .lsd=lsd ))),
weight=expression({
- if(iter == 1) {
+ if (iter == 1) {
wznew = cbind(matrix(w, n, M), matrix(0, n, dimm(M)-M))
} else {
wzold = wznew
@@ -1997,9 +1997,9 @@ recexp1.control <- function(save.weight=TRUE, ...)
recexp1 = function(lrate="loge", irate=NULL, method.init=1)
{
- if(mode(lrate) != "character" && mode(lrate) != "name")
+ if (mode(lrate) != "character" && mode(lrate) != "name")
lrate = as.character(substitute(lrate))
- if(!is.Numeric(method.init, allow=1, integ=TRUE, positi=TRUE) ||
+ if (!is.Numeric(method.init, allow=1, integ=TRUE, positi=TRUE) ||
method.init > 3.5)
stop("argument 'method.init' must be 1 or 2 or 3")
@@ -2011,18 +2011,18 @@ recexp1.control <- function(save.weight=TRUE, ...)
"Variance: 1/rate^2"),
initialize=eval(substitute(expression({
predictors.names = c(namesof("rate", .lrate, tag= FALSE))
- if(ncol(y <- cbind(y)) != 1)
+ if (ncol(y <- cbind(y)) != 1)
stop("response must be a vector or a one-column matrix")
- if(any(diff(y) <= 0))
+ if (any(diff(y) <= 0))
stop("response must have increasingly larger and larger values")
- if(any(w != 1))
+ if (any(w != 1))
warning("weights should have unit values only")
- if(!length(etastart)) {
- rate.init = if(length( .irate)) rep( .irate, len=n) else {
+ if (!length(etastart)) {
+ rate.init = if (length( .irate)) rep( .irate, len=n) else {
init.rate =
- if(.method.init == 1) length(y) / y[length(y),1] else
- if(.method.init == 2) 1/mean(y) else 1/median(y)
- if(.lrate == "loge") pmax(1/1024, init.rate) else init.rate}
+ if (.method.init == 1) length(y) / y[length(y),1] else
+ if (.method.init == 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))
}
}), list( .lrate=lrate, .irate=irate, .method.init=method.init ))),
@@ -2036,7 +2036,7 @@ recexp1.control <- function(save.weight=TRUE, ...)
loglikelihood=eval(substitute(
function(mu,y,w,residuals= FALSE,eta, extra=NULL) {
rate = eta2theta(eta, .lrate)
- if(residuals) stop("loglikelihood residuals not implemented yet") else {
+ if (residuals) stop("loglikelihood residuals not implemented yet") else {
NN = length(eta)
y = cbind(y)
sum(w * log(rate)) - w[NN] * rate[NN] * y[NN,1]
@@ -2068,18 +2068,18 @@ recexp1.control <- function(save.weight=TRUE, ...)
poissonp = function(ostatistic, dimension=2, link="loge", earg=list(),
idensity=NULL, method.init=1) {
- if(!is.Numeric(ostatistic, posit=TRUE, allow=1, integ=TRUE))
+ if (!is.Numeric(ostatistic, posit=TRUE, allow=1, integ=TRUE))
stop("argument 'ostatistic' must be a single positive integer")
- if(!is.Numeric(dimension, posit=TRUE, allow=1, integ=TRUE) ||
+ if (!is.Numeric(dimension, posit=TRUE, allow=1, integ=TRUE) ||
dimension > 3)
stop("argument 'dimension' must be 2 or 3")
- if(mode(link) != "character" && mode(link) != "name")
+ if (mode(link) != "character" && mode(link) != "name")
link = as.character(substitute(link))
- if(!is.list(earg)) earg = list()
- if(!is.Numeric(method.init, allow=1, posit=TRUE, integer=TRUE) ||
+ if (!is.list(earg)) earg = list()
+ if (!is.Numeric(method.init, allow=1, posit=TRUE, integer=TRUE) ||
method.init > 2.5)
stop("argument 'method.init' must be 1 or 2")
- if(length(idensity) && !is.Numeric(idensity, posit=TRUE))
+ if (length(idensity) && !is.Numeric(idensity, posit=TRUE))
stop("bad input for argument 'idensity'")
new("vglmff",
@@ -2088,27 +2088,27 @@ recexp1.control <- function(save.weight=TRUE, ...)
"Poisson-points-on-a-volume distances distribution\n",
"Link: ",
namesof("density", link, earg=earg), "\n\n",
- if(dimension==2)
+ if (dimension==2)
"Mean: gamma(s+0.5) / (gamma(s) * sqrt(density * pi))" else
"Mean: gamma(s+1/3) / (gamma(s) * (4*density*pi/3)^(1/3))"),
initialize=eval(substitute(expression({
- if(ncol(cbind(y)) != 1)
+ if (ncol(cbind(y)) != 1)
stop("response must be a vector or a one-column matrix")
- if(any(y <= 0))
+ if (any(y <= 0))
stop("response must contain positive values only")
predictors.names = namesof("density", .link, earg=.earg, tag=FALSE)
- if(!length(etastart)) {
- use.this = if( .method.init == 1) median(y) + 1/8 else
+ if (!length(etastart)) {
+ use.this = if ( .method.init == 1) median(y) + 1/8 else
weighted.mean(y,w)
- if( .dimension == 2) {
+ if ( .dimension == 2) {
myratio = exp(lgamma( .ostatistic +0.5) - lgamma( .ostatistic))
- density.init = if(is.Numeric( .idensity))
+ 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))
- density.init = if(is.Numeric( .idensity))
+ density.init = if (is.Numeric( .idensity))
rep( .idensity, len=n) else
rep(3 * myratio^3 / (4 * pi * use.this^3), len=n)
etastart = theta2eta(density.init, .link, earg= .earg)
@@ -2119,7 +2119,7 @@ recexp1.control <- function(save.weight=TRUE, ...)
.idensity=idensity ))),
inverse=eval(substitute(function(eta, extra=NULL) {
density = eta2theta(eta, .link, earg= .earg)
- if( .dimension == 2) {
+ if ( .dimension == 2) {
myratio = exp(lgamma( .ostatistic +0.5) - lgamma( .ostatistic ))
myratio / sqrt(density * pi)
} else {
@@ -2139,8 +2139,8 @@ recexp1.control <- function(save.weight=TRUE, ...)
loglikelihood=eval(substitute(
function(mu,y,w,residuals= FALSE,eta, extra=NULL) {
density = eta2theta(eta, .link, earg= .earg)
- if(residuals) stop("loglikelihood residuals not implemented yet") else
- if( .dimension == 2)
+ if (residuals) stop("loglikelihood residuals not implemented yet") else
+ if ( .dimension == 2)
sum(w * (log(2) + .ostatistic * log(pi * density) -
lgamma( .ostatistic) + (2* .ostatistic-1) * log(y) -
density * pi * y^2)) else
@@ -2152,7 +2152,7 @@ recexp1.control <- function(save.weight=TRUE, ...)
vfamily=c("poissonp"),
deriv=eval(substitute(expression({
density = eta2theta(eta, .link, earg= .earg)
- if( .dimension == 2) {
+ if ( .dimension == 2) {
dl.ddensity = .ostatistic / density - pi * y^2
} else {
dl.ddensity = .ostatistic / density - (4/3) * pi * y^3
diff --git a/R/family.fishing.q b/R/family.fishing.R
similarity index 88%
rename from R/family.fishing.q
rename to R/family.fishing.R
index c636046..4fd0be2 100644
--- a/R/family.fishing.q
+++ b/R/family.fishing.R
@@ -1,8 +1,7 @@
-# These functions are Copyright (C) 1998-2009 T. W. Yee All rights reserved.
-
# "family.fishing.q"
# Last modified: 01/12/08, 02/12/08
-# Copyright Thomas W. Yee (2009)
+
+# These functions are Copyright (C) 2009-2010 T. W. Yee All rights reserved.
# ====================================================================
@@ -13,12 +12,12 @@ DeLury = function(catch, effort,
ricker=FALSE) {
# 20081202; this function has been checked not ok
type = match.arg(type, c("DeLury","Leslie"))[1]
- if(!is.logical(ricker)) stop("bad input for 'ricker'")
- if((LLL <- Lcatch <- length(catch)) != (Leffort <- length(effort)))
+ if (!is.logical(ricker)) stop("bad input for 'ricker'")
+ if ((LLL <- Lcatch <- length(catch)) != (Leffort <- length(effort)))
stop("length(catch) != length(effort)")
CPUE = catch / effort
- if(type == "DeLury") {
+ if (type == "DeLury") {
Et = cumsum(effort) - ifelse(ricker, 0.5, 1) * effort
logCPUE = log(CPUE)
lmfit = lm(logCPUE ~ Et, x=TRUE)
@@ -38,7 +37,7 @@ DeLury = function(catch, effort,
N0 = N0,
CPUE = CPUE,
lmfit=lmfit)
- if(type == "DeLury") {
+ if (type == "DeLury") {
rlist$E = Et
} else {
rlist$K = Kt
diff --git a/R/family.functions.q b/R/family.functions.R
similarity index 81%
rename from R/family.functions.q
rename to R/family.functions.R
index 0323346..9927f88 100644
--- a/R/family.functions.q
+++ b/R/family.functions.R
@@ -1,5 +1,5 @@
# These functions are
-# Copyright (C) 1998-2009 T.W. Yee, University of Auckland. All rights reserved.
+# Copyright (C) 1998-2010 T.W. Yee, University of Auckland. All rights reserved.
@@ -25,8 +25,8 @@ remove.arg <- function(string)
nc <- nchar(string)
bits <- substring(string, 1:nc, 1:nc)
b1 <- (1:nc)[bits=="("]
- b1 <- if(length(b1)) b1[1]-1 else nc
- if(b1==0)
+ b1 <- if (length(b1)) b1[1]-1 else nc
+ if (b1==0)
return("")
string <- paste(bits[1:b1], collapse="")
string
@@ -36,13 +36,13 @@ remove.arg <- function(string)
add.arg <- function(string, arg.string)
{
- if(arg.string=="")
+ if (arg.string=="")
return(string)
nc <- nchar(string)
lastc <- substring(string, nc, nc)
- if(lastc == ")")
+ if (lastc == ")")
{
- if(substring(string, nc-1, nc-1) == "(")
+ if (substring(string, nc-1, nc-1) == "(")
{
paste(substring(string, 1, nc-2), "(", arg.string, ")", sep="")
} else
@@ -59,9 +59,9 @@ get.arg <- function(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="")
+ 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="")
}
@@ -75,7 +75,7 @@ ei = function(i, n)
eij = function(i, n) {
temp = matrix(0, n, 1)
- if(length(i))
+ if (length(i))
temp[i,] = 1
temp
}
@@ -93,7 +93,7 @@ tapplymat1 <- function(mat, function.arg=c("cumsum", "diff", "cumprod"))
{
- if(!missing(function.arg))
+ if (!missing(function.arg))
function.arg <- as.character(substitute(function.arg))
function.arg <- match.arg(function.arg, c("cumsum", "diff", "cumprod"))[1]
@@ -103,7 +103,7 @@ tapplymat1 <- function(mat, function.arg=c("cumsum", "diff", "cumprod"))
cumprod=3,
stop("function.arg not matched"))
- if(!is.matrix(mat))
+ if (!is.matrix(mat))
mat <- as.matrix(mat)
nr <- nrow(mat)
nc <- ncol(mat)
@@ -128,17 +128,17 @@ matrix.power <- function(wz, M, power, fast=TRUE)
n <- nrow(wz)
index <- iam(NA, NA, M, both=TRUE, diag=TRUE)
- dimm.value <- if(is.matrix(wz)) ncol(wz) else 1
- if(dimm.value > M*(M+1)/2)
+ dimm.value <- if (is.matrix(wz)) ncol(wz) else 1
+ if (dimm.value > M*(M+1)/2)
stop("too many columns")
- if(M == 1 || dimm.value==M) {
+ if (M == 1 || dimm.value==M) {
WW <- wz^power # May contain NAs
return(t(WW))
}
- if(fast) {
+ if (fast) {
k <- veigen(t(wz), M=M) # matrix.arg)
evals <- k$values # M x n
evects <- k$vectors # M x M x n
@@ -157,7 +157,7 @@ matrix.power <- function(wz, M, power, fast=TRUE)
index <- index == 0
- if(!all(index)) {
+ if (!all(index)) {
warning(paste("Some weight matrices have negative",
"eigenvalues. They\nwill be assigned NAs"))
temp[,!index] <- 1
@@ -174,7 +174,7 @@ rss.vgam <- function(z, wz, M)
{
- if(M==1)
+ if (M==1)
return(sum(c(wz) * c(z^2)))
wz.z <- mux22(t(wz), z, M, as.mat=TRUE) # else mux2(wz, z)
ans <- sum(wz.z * z)
@@ -183,20 +183,20 @@ rss.vgam <- function(z, wz, M)
wweighted.mean <- function(y, w = NULL, matrix.arg=TRUE)
{
- if(!matrix.arg)
+ if (!matrix.arg)
stop("currently, matrix.arg must be TRUE")
y <- as.matrix(y)
M <- ncol(y)
n <- nrow(y)
- if(M==1) {
- if(missing(w)) mean(y) else sum(w * y)/sum(w)
+ if (M==1) {
+ if (missing(w)) mean(y) else sum(w * y)/sum(w)
} else {
- if(missing(w)) y %*% rep(1, n) else {
+ if (missing(w)) y %*% rep(1, n) else {
numer <- mux22(t(w), y, M, as.matrix=TRUE) # matrix.arg=matrix.arg,
numer <- t(numer) %*% rep(1, n)
denom <- t(w) %*% rep(1, n)
denom <- matrix(denom, 1, length(denom))
- if(matrix.arg)
+ if (matrix.arg)
denom <- m2adefault(denom, M=M)[,,1]
c(solve(denom, numer))
}
@@ -228,7 +228,7 @@ veigen <- function(x, M)
as.integer(dimm.value),
error.code = integer(1))
- if(z$error.code)
+ if (z$error.code)
stop("eigen algorithm (rs) returned error code ", z$error.code)
ord <- M:1
dim(z$values) <- c(M,n)
@@ -244,19 +244,19 @@ veigen <- function(x, M)
ima <- function(j,k,M)
{
- if(length(M)>1 || M<=0 || j<=0 || k<=0 || j>M || k>M)
+ if (length(M)>1 || M<=0 || j<=0 || k<=0 || j>M || k>M)
stop("input wrong")
m <- diag(M)
m[col(m)<=row(m)] <- 1:(M*(M+1)/2)
- if(j>=k) m[j,k] else m[k,j]
+ if (j>=k) m[j,k] else m[k,j]
}
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)))
+ 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.genetic.q b/R/family.genetic.R
similarity index 86%
rename from R/family.genetic.q
rename to R/family.genetic.R
index 1328647..246b28e 100644
--- a/R/family.genetic.q
+++ b/R/family.genetic.R
@@ -1,5 +1,5 @@
# These functions are
-# Copyright (C) 1998-2009 T.W. Yee, University of Auckland. All rights reserved.
+# Copyright (C) 1998-2010 T.W. Yee, University of Auckland. All rights reserved.
@@ -14,9 +14,9 @@
G1G2G3 = function(link="logit", earg = list(), ip1=NULL, ip2=NULL, iF=NULL)
{
- if(mode(link) != "character" && mode(link) != "name")
+ if (mode(link) != "character" && mode(link) != "name")
link = as.character(substitute(link))
- if(!is.list(earg)) earg = list()
+ if (!is.list(earg)) earg = list()
new("vglmff",
blurb=c("G1-G2-G3 phenotype\n\n",
@@ -30,9 +30,9 @@
eval(process.categorical.data.vgam)
ok.col.ny = c("G1G1","G1G2","G1G3","G2G2","G2G3","G3G3")
- if(length(col.ny <- colnames(y)) == length(ok.col.ny) &&
+ if (length(col.ny <- colnames(y)) == length(ok.col.ny) &&
setequal(ok.col.ny, col.ny)) {
- if(!all(ok.col.ny == col.ny))
+ if (!all(ok.col.ny == col.ny))
stop("the columns of the response matrix should have names ",
"(output of colnames()) ordered as ",
"c('G1G1','G1G2','G1G3','G2G2','G2G3','G3G3')")
@@ -41,16 +41,16 @@
predictors.names = c(namesof("p1", .link, earg= .earg, tag=FALSE),
namesof("p2", .link, earg= .earg, tag=FALSE),
namesof("f", .link, earg= .earg, tag=FALSE))
- if(is.null(etastart)) {
- p1 = if(is.numeric(.ip1)) rep(.ip1, n) else
+ if (is.null(etastart)) {
+ p1 = if (is.numeric(.ip1)) rep(.ip1, n) else
sqrt(mustart[,1])
- f = if(is.numeric(.iF)) rep(.iF, n) else
+ f = if (is.numeric(.iF)) rep(.iF, n) else
rep(0.01, n) # close to zero
- p2 = if(is.numeric(.ip2)) rep(.ip2, n) else
+ p2 = if (is.numeric(.ip2)) rep(.ip2, n) else
mustart[,2] / (sqrt(mustart[,1]) * 2)
- if(any(p1 <= 0) || any(p1 >= 1))
+ if (any(p1 <= 0) || any(p1 >= 1))
stop("bad initial value for 'p1'")
- if(any(p2 <= 0) || any(p2 >= 1))
+ if (any(p2 <= 0) || any(p2 >= 1))
stop("bad initial value for 'p2'")
etastart = cbind(theta2eta(p1, .link, earg= .earg),
theta2eta(p2, .link, earg= .earg),
@@ -74,7 +74,7 @@
misc$earg = list(p1= .earg, p2= .earg, f= .earg )
}), list( .link=link, .earg=earg ))),
loglikelihood= function(mu, y, w, residuals = FALSE, eta, extra=NULL)
- if(residuals) stop("loglikelihood residuals not implemented yet") else {
+ if (residuals) stop("loglikelihood residuals not implemented yet") else {
sum(dmultinomial(x=w*y, size=w, prob=mu, log=TRUE, docheck=FALSE))
},
vfamily=c("G1G2G3", "vgenetic"),
@@ -116,9 +116,9 @@
AAaa.nohw = function(link="logit", earg = list(), ipA=NULL, iF=NULL)
{
- if(mode(link) != "character" && mode(link) != "name")
+ if (mode(link) != "character" && mode(link) != "name")
link = as.character(substitute(link))
- if(!is.list(earg)) earg = list()
+ if (!is.list(earg)) earg = list()
new("vglmff",
blurb=c("AA-Aa-aa phenotype (without Hardy-Weinberg assumption)\n\n",
@@ -131,21 +131,21 @@
eval(process.categorical.data.vgam)
ok.col.ny = c("AA","Aa","aa")
- if(length(col.ny <- colnames(y)) == length(ok.col.ny) &&
+ if (length(col.ny <- colnames(y)) == length(ok.col.ny) &&
setequal(ok.col.ny, col.ny)) {
- if(!all(ok.col.ny == col.ny))
+ if (!all(ok.col.ny == col.ny))
stop("the columns of the response matrix should have names ",
"(output of colnames()) ordered as c('AA','Aa','aa')")
}
predictors.names = c(namesof("pA", .link, earg= .earg, tag=FALSE),
namesof("f", "identity", tag=FALSE))
- if(is.null(etastart)) {
- pA = if(is.numeric(.ipA)) rep(.ipA, n) else
+ if (is.null(etastart)) {
+ pA = if (is.numeric(.ipA)) rep(.ipA, n) else
c(sqrt(mustart[,1] - mustart[,2]/2))
- f = if(is.numeric(.iF)) rep(.iF, n) else
+ f = if (is.numeric(.iF)) rep(.iF, n) else
rep(0.01, n) # 1- mustart[,2]/(2*pA*(1-pA))
- if(any(pA <= 0) || any(pA >= 1))
+ if (any(pA <= 0) || any(pA >= 1))
stop("bad initial value for 'pA'")
etastart = cbind(theta2eta(pA, .link, earg= .earg),
theta2eta(f, "identity"))
@@ -169,7 +169,7 @@
theta2eta(f, "identity"))
}, list( .link=link, .earg=earg ))),
loglikelihood= function(mu, y, w, residuals = FALSE, eta, extra=NULL)
- if(residuals) stop("loglikelihood residuals not implemented yet") else {
+ if (residuals) stop("loglikelihood residuals not implemented yet") else {
sum(dmultinomial(x=w*y, size=w, prob=mu, log=TRUE, docheck=FALSE))
},
vfamily=c("AAaa.nohw", "vgenetic"),
@@ -204,9 +204,9 @@
AB.Ab.aB.ab2 = function(link="logit", earg = list(), init.p=NULL)
{
- if(mode(link) != "character" && mode(link) != "name")
+ if (mode(link) != "character" && mode(link) != "name")
link = as.character(substitute(link))
- if(!is.list(earg)) earg = list()
+ if (!is.list(earg)) earg = list()
new("vglmff",
blurb=c("AB-Ab-aB-ab2 phenotype\n\n",
@@ -219,15 +219,15 @@
predictors.names = namesof("p", .link, earg= .earg, tag=FALSE)
ok.col.ny = c("AB","Ab","aB","ab")
- if(length(col.ny <- colnames(y)) == length(ok.col.ny) &&
+ if (length(col.ny <- colnames(y)) == length(ok.col.ny) &&
setequal(ok.col.ny, col.ny)) {
- if(!all(ok.col.ny == col.ny))
+ if (!all(ok.col.ny == col.ny))
stop("the columns of the response matrix should have names ",
"(output of colnames()) ordered as c('AB','Ab','aB','ab')")
}
- if(is.null(etastart)) {
- p.init = if(is.numeric(.init.p)) rep(.init.p, n) else
+ if (is.null(etastart)) {
+ p.init = if (is.numeric(.init.p)) rep(.init.p, n) else
c(1 - 2 * sqrt(mustart[,4]))
etastart = theta2eta(p.init, .link, earg= .earg)
}
@@ -248,7 +248,7 @@
theta2eta(p, .link, earg= .earg)
}, list( .link=link, .earg=earg ) )),
loglikelihood= function(mu, y, w, residuals = FALSE, eta, extra=NULL)
- if(residuals) stop("loglikelihood residuals not implemented yet") else {
+ if (residuals) stop("loglikelihood residuals not implemented yet") else {
sum(dmultinomial(x=w*y, size=w, prob=mu, log=TRUE, docheck=FALSE))
},
vfamily=c("AB.Ab.aB.ab2", "vgenetic"),
@@ -269,9 +269,9 @@
A1A2A3 = function(link="logit", earg = list(), ip1=NULL, ip2=NULL)
{
- if(mode(link) != "character" && mode(link) != "name")
+ if (mode(link) != "character" && mode(link) != "name")
link = as.character(substitute(link))
- if(!is.list(earg)) earg = list()
+ if (!is.list(earg)) earg = list()
new("vglmff",
blurb=c("A1A2A3 Allele System (A1A1, A1A2, A2A2, A1A3, A2A3, A3A3)\n\n",
@@ -284,9 +284,9 @@
eval(process.categorical.data.vgam)
ok.col.ny = c("A1A1","A1A2","A2A2","A1A3","A2A3","A3A3")
- if(length(col.ny <- colnames(y)) == length(ok.col.ny) &&
+ if (length(col.ny <- colnames(y)) == length(ok.col.ny) &&
setequal(ok.col.ny, col.ny)) {
- if(!all(ok.col.ny == col.ny))
+ if (!all(ok.col.ny == col.ny))
stop("the columns of the response matrix should have names ",
"(output of colnames()) ordered as ",
"c('A1A1','A1A2','A2A2','A1A3','A2A3','A3A3')")
@@ -294,10 +294,10 @@
predictors.names = c(namesof("pA", .link, earg= .earg, tag=FALSE),
namesof("pB", .link, earg= .earg, tag=FALSE))
- if(is.null(etastart)) {
- p1 = if(is.numeric(.ip1)) rep(.ip1, n) else
+ if (is.null(etastart)) {
+ p1 = if (is.numeric(.ip1)) rep(.ip1, n) else
c(sqrt(mustart[,1]))
- p2 = if(is.numeric(.ip2)) rep(.ip2, n) else
+ p2 = if (is.numeric(.ip2)) rep(.ip2, n) else
c(sqrt(mustart[,3]))
etastart = cbind(theta2eta(p1, .link, earg= .earg),
theta2eta(p2, .link, earg= .earg))
@@ -322,7 +322,7 @@
theta2eta(p2, .link, earg= .earg))
}, list( .link=link, .earg=earg ))),
loglikelihood= function(mu, y, w, residuals = FALSE, eta, extra=NULL)
- if(residuals) stop("loglikelihood residuals not implemented yet") else {
+ if (residuals) stop("loglikelihood residuals not implemented yet") else {
sum(dmultinomial(x=w*y, size=w, prob=mu, log=TRUE, docheck=FALSE))
},
vfamily=c("A1A2A3", "vgenetic"),
@@ -353,9 +353,9 @@
MNSs = function(link="logit", earg = list(), imS=NULL, ims=NULL, inS=NULL)
{
- if(mode(link) != "character" && mode(link) != "name")
+ if (mode(link) != "character" && mode(link) != "name")
link = as.character(substitute(link))
- if(!is.list(earg)) earg = list()
+ if (!is.list(earg)) earg = list()
new("vglmff",
blurb=c("MNSs Blood Group System (MS-Ms-MNS-MNs-NS-Ns phenotype)\n\n",
@@ -369,9 +369,9 @@
eval(process.categorical.data.vgam)
ok.col.ny = c("MS","Ms","MNS","MNs","NS","Ns")
- if(length(col.ny <- colnames(y)) == length(ok.col.ny) &&
+ if (length(col.ny <- colnames(y)) == length(ok.col.ny) &&
setequal(ok.col.ny, col.ny)) {
- if(!all(ok.col.ny == col.ny))
+ if (!all(ok.col.ny == col.ny))
stop("the columns of the response matrix should have names ",
"(output of colnames()) ordered as ",
"c('MS','Ms','MNS','MNs','NS','Ns')")
@@ -381,13 +381,13 @@
c(namesof("mS", .link, earg= .earg, tag=FALSE),
namesof("ms", .link, earg= .earg, tag=FALSE),
namesof("nS", .link, earg= .earg, tag=FALSE))
- if(is.null(etastart)) {
- ms = if(is.numeric(.ims)) rep(.ims, n) else
+ if (is.null(etastart)) {
+ ms = if (is.numeric(.ims)) rep(.ims, n) else
c(sqrt(mustart[,2]))
ns = c(sqrt(mustart[,6]))
- nS = if(is.numeric(.inS)) rep(.inS, n) else
+ nS = if (is.numeric(.inS)) rep(.inS, n) else
c(-ns + sqrt(ns^2 + mustart[,5])) # Solve a quadratic eqn
- mS = if(is.numeric(.imS)) rep(.imS, n) else
+ mS = if (is.numeric(.imS)) rep(.imS, n) else
1-ns-ms-nS
etastart = cbind(theta2eta(mS, .link, earg= .earg),
theta2eta(ms, .link, earg= .earg),
@@ -416,7 +416,7 @@
theta2eta(nS, .link, earg= .earg))
}, list( .link=link, .earg=earg ))),
loglikelihood= function(mu, y, w, residuals = FALSE, eta, extra=NULL)
- if(residuals) stop("loglikelihood residuals not implemented yet") else {
+ if (residuals) stop("loglikelihood residuals not implemented yet") else {
sum(dmultinomial(x=w*y, size=w, prob=mu, log=TRUE, docheck=FALSE))
},
vfamily=c("MNSs", "vgenetic"),
@@ -455,9 +455,9 @@
ABO = function(link="logit", earg = list(), ipA=NULL, ipO=NULL)
{
- if(mode(link) != "character" && mode(link) != "name")
+ if (mode(link) != "character" && mode(link) != "name")
link = as.character(substitute(link))
- if(!is.list(earg)) earg = list()
+ if (!is.list(earg)) earg = list()
new("vglmff",
blurb=c("ABO Blood Group System (A-B-AB-O phenotype)\n\n",
@@ -470,9 +470,9 @@
eval(process.categorical.data.vgam)
ok.col.ny = c("A","B","AB","O")
- if(length(col.ny <- colnames(y)) == length(ok.col.ny) &&
+ if (length(col.ny <- colnames(y)) == length(ok.col.ny) &&
setequal(ok.col.ny, col.ny)) {
- if(!all(ok.col.ny == col.ny))
+ if (!all(ok.col.ny == col.ny))
stop("the columns of the response matrix should have names ",
"(output of colnames()) ordered as c('A','B','AB','O')")
}
@@ -480,9 +480,9 @@
predictors.names <-
c(namesof("pA", .link, earg= .earg, tag=FALSE),
namesof("pB", .link, earg= .earg, tag=FALSE))
- if(is.null(etastart)) {
- pO = if(is.Numeric( .ipO)) rep( .ipO, n) else c(sqrt(mustart[,4]))
- pA = if(is.Numeric( .ipA)) rep( .ipA, n) else
+ if (is.null(etastart)) {
+ pO = if (is.Numeric( .ipO)) rep( .ipO, n) else c(sqrt(mustart[,4]))
+ pA = if (is.Numeric( .ipA)) rep( .ipA, n) else
c(1-sqrt(mustart[,2]+mustart[,4]))
pB = 1-pA-pO
etastart = cbind(theta2eta(pA, .link, earg= .earg),
@@ -511,7 +511,7 @@
theta2eta(pB, .link, earg= .earg))
}, list( .link=link, .earg=earg ))),
loglikelihood= function(mu, y, w, residuals = FALSE, eta, extra=NULL)
- if(residuals) stop("loglikelihood residuals not implemented yet") else {
+ if (residuals) stop("loglikelihood residuals not implemented yet") else {
sum(dmultinomial(x=w*y, size=w, prob=mu, log=TRUE, docheck=FALSE))
},
vfamily=c("ABO", "vgenetic"),
@@ -548,9 +548,9 @@
AB.Ab.aB.ab = function(link="logit", earg = list(), init.p=NULL)
{
- if(mode(link) != "character" && mode(link) != "name")
+ if (mode(link) != "character" && mode(link) != "name")
link = as.character(substitute(link))
- if(!is.list(earg)) earg = list()
+ if (!is.list(earg)) earg = list()
new("vglmff",
blurb=c("AB-Ab-aB-ab phenotype\n\n",
@@ -561,16 +561,16 @@
eval(process.categorical.data.vgam)
ok.col.ny = c("AB","Ab","aB","ab")
- if(length(col.ny <- colnames(y)) == length(ok.col.ny) &&
+ if (length(col.ny <- colnames(y)) == length(ok.col.ny) &&
setequal(ok.col.ny, col.ny)) {
- if(!all(ok.col.ny == col.ny))
+ if (!all(ok.col.ny == col.ny))
stop("the columns of the response matrix should have names ",
"(output of colnames()) ordered as c('AB','Ab','aB','ab')")
}
predictors.names = namesof("p", .link, earg= .earg, tag=FALSE)
- if(is.null(etastart)) {
- p = if(is.numeric(.init.p)) rep(.init.p,n) else
+ if (is.null(etastart)) {
+ p = if (is.numeric(.init.p)) rep(.init.p,n) else
c(sqrt(4*mustart[,4]))
etastart = cbind(theta2eta(p, .link, earg= .earg))
}
@@ -589,7 +589,7 @@
theta2eta(p, .link, earg= .earg)
}, list( .link=link, .earg=earg ))),
loglikelihood= function(mu, y, w, residuals = FALSE, eta, extra=NULL)
- if(residuals) stop("loglikelihood residuals not implemented yet") else {
+ if (residuals) stop("loglikelihood residuals not implemented yet") else {
sum(dmultinomial(x=w*y, size=w, prob=mu, log=TRUE, docheck=FALSE))
},
vfamily=c("AB.Ab.aB.ab", "vgenetic"),
@@ -615,9 +615,9 @@
AA.Aa.aa = function(link="logit", earg = list(), init.pA=NULL)
{
- if(mode(link) != "character" && mode(link) != "name")
+ if (mode(link) != "character" && mode(link) != "name")
link = as.character(substitute(link))
- if(!is.list(earg)) earg = list()
+ if (!is.list(earg)) earg = list()
new("vglmff",
blurb=c("AA-Aa-aa phenotype\n\n",
@@ -628,16 +628,16 @@
eval(process.categorical.data.vgam)
ok.col.ny = c("AA","Aa","aa")
- if(length(col.ny <- colnames(y)) == length(ok.col.ny) &&
+ if (length(col.ny <- colnames(y)) == length(ok.col.ny) &&
setequal(ok.col.ny, col.ny)) {
- if(!all(ok.col.ny == col.ny))
+ if (!all(ok.col.ny == col.ny))
stop("the columns of the response matrix should have names ",
"(output of colnames()) ordered as c('AA','Aa','aa')")
}
predictors.names = namesof("pA", .link, earg= .earg, tag=FALSE)
- if(is.null(etastart)) {
- pA = if(is.numeric(.init.pA)) rep(.init.pA, n) else
+ if (is.null(etastart)) {
+ pA = if (is.numeric(.init.pA)) rep(.init.pA, n) else
c(sqrt(mustart[,1]))
etastart = cbind(theta2eta(pA, .link, earg= .earg))
}
@@ -656,7 +656,7 @@
theta2eta(pA, .link, earg= .earg)
}, list( .link=link, .earg=earg ))),
loglikelihood= function(mu, y, w, residuals = FALSE, eta, extra=NULL)
- if(residuals) stop("loglikelihood residuals not implemented yet") else {
+ if (residuals) stop("loglikelihood residuals not implemented yet") else {
sum(dmultinomial(x=w*y, size=w, prob=mu, log=TRUE, docheck=FALSE))
},
vfamily=c("AA.Aa.aa", "vgenetic"),
diff --git a/R/family.glmgam.q b/R/family.glmgam.R
similarity index 82%
rename from R/family.glmgam.q
rename to R/family.glmgam.R
index 48c9171..ad7e775 100644
--- a/R/family.glmgam.q
+++ b/R/family.glmgam.R
@@ -1,5 +1,5 @@
# These functions are
-# Copyright (C) 1998-2009 T.W. Yee, University of Auckland. All rights reserved.
+# Copyright (C) 1998-2010 T.W. Yee, University of Auckland. All rights reserved.
@@ -17,9 +17,9 @@
estimated.dispersion <- dispersion==0
- if(mode(link )!= "character" && mode(link )!= "name")
+ if (mode(link )!= "character" && mode(link )!= "name")
link <- as.character(substitute(link))
- if(!is.list(earg)) earg = list()
+ if (!is.list(earg)) earg = list()
new("vglmff",
blurb=if(mv) c("Multivariate Binomial model\n\n",
@@ -38,22 +38,22 @@
eta=eta, extra=extra)
},
initialize=eval(substitute(expression({
- if(is.R()) {
+ if (is.R()) {
assign("CQO.FastAlgorithm", ( .link=="logit" || .link=="cloglog"),
envir=VGAMenv)
- assign("modelno", if( .link=="logit") 1 else
- if( .link=="cloglog") 4 else NULL, envir=VGAMenv)
+ assign("modelno", if ( .link=="logit") 1 else
+ if ( .link=="cloglog") 4 else NULL, envir=VGAMenv)
} else {
CQO.FastAlgorithm <<- ( .link == "logit" || .link=="cloglog")
- modelno <<- if( .link=="logit") 1 else if( .link=="cloglog") 4 else NULL
+ modelno <<- if ( .link=="logit") 1 else if ( .link=="cloglog") 4 else NULL
}
- if(.mv) {
+ if (.mv) {
y = as.matrix(y)
M = ncol(y)
- if(!all(y == 0 | y == 1))
+ if (!all(y == 0 | y == 1))
stop("response must contain 0's and 1's only")
- dn2 = if(is.matrix(y)) dimnames(y)[[2]] else NULL
- dn2 = if(length(dn2)) {
+ dn2 = if (is.matrix(y)) dimnames(y)[[2]] else NULL
+ dn2 = if (length(dn2)) {
paste("E[", dn2, "]", sep="")
} else {
paste("mu", 1:M, sep="")
@@ -64,20 +64,20 @@
mustart = (0.5 + w * y) / (1 + w)
} else {
NCOL = function (x)
- if(is.array(x) && length(dim(x)) > 1 ||
+ if (is.array(x) && length(dim(x)) > 1 ||
is.data.frame(x)) ncol(x) else as.integer(1)
- if(NCOL(y) == 1) {
- if(is.factor(y)) y = y != levels(y)[1]
+ if (NCOL(y) == 1) {
+ if (is.factor(y)) y = y != levels(y)[1]
nn = rep(1, n)
- if(!all(y >= 0 & y <= 1))
+ if (!all(y >= 0 & y <= 1))
stop("response values must be in [0, 1]")
mustart = (0.5 + w * y) / (1 + w)
no.successes = w * y
- if(any(abs(no.successes - round(no.successes)) > 0.001))
+ if (any(abs(no.successes - round(no.successes)) > 0.001))
stop("Number of successes must be integer-valued")
- } else if(NCOL(y) == 2) {
- if(any(abs(y - round(y)) > 0.001))
+ } 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)
@@ -93,10 +93,10 @@
mu
}, list( .link=link, .earg = earg ))),
last=eval(substitute(expression({
- if(is.R()) {
- if(exists("CQO.FastAlgorithm", envir = VGAMenv))
+ if (is.R()) {
+ if (exists("CQO.FastAlgorithm", envir = VGAMenv))
rm("CQO.FastAlgorithm", envir = VGAMenv)
- if(exists("modelno", envir = VGAMenv))
+ if (exists("modelno", envir = VGAMenv))
rm("modelno", envir = VGAMenv)
} else {
while(exists("CQO.FastAlgorithm"))
@@ -105,16 +105,16 @@
remove("modelno")
}
dpar <- .dispersion
- if(!dpar) {
+ if (!dpar) {
temp87 = (y-mu)^2 * wz /
(dtheta.deta(mu, link= .link, earg = .earg )^2) # w cancel
- if(.mv && ! .onedpar) {
+ if (.mv && ! .onedpar) {
dpar = rep(as.numeric(NA), len=M)
temp87 = cbind(temp87)
- nrow.mu = if(is.matrix(mu)) nrow(mu) else length(mu)
+ nrow.mu = if (is.matrix(mu)) nrow(mu) else length(mu)
for(ii in 1:M)
dpar[ii] = sum(temp87[,ii]) / (nrow.mu - ncol(x))
- if(is.matrix(y) && length(dimnames(y)[[2]])==length(dpar))
+ if (is.matrix(y) && length(dimnames(y)[[2]])==length(dpar))
names(dpar) = dimnames(y)[[2]]
} else
dpar = sum(temp87) / (length(mu) - ncol(x))
@@ -124,7 +124,7 @@
misc$default.dispersion <- 1
misc$estimated.dispersion <- .estimated.dispersion
misc$link = rep( .link, length=M)
- names(misc$link) = if(M>1) dn2 else "mu"
+ names(misc$link) = if (M>1) dn2 else "mu"
misc$earg = vector("list", M)
names(misc$earg) = names(misc$link)
@@ -137,15 +137,15 @@
theta2eta(mu, .link, earg = .earg )
, list( .link=link, .earg = earg ))),
loglikelihood= function(mu, y, w, residuals = FALSE, eta, extra=NULL) {
- if(residuals) w*(y/mu - (1-y)/(1-mu)) else {
+ if (residuals) w*(y/mu - (1-y)/(1-mu)) else {
sum(dbinom(x=w*y, size=w, prob=mu, log=TRUE))
}
},
vfamily=c("binomialff", "vcategorical"),
deriv=eval(substitute(expression({
- if( .link == "logit") {
+ if ( .link == "logit") {
w * (y - mu)
- } else if( .link == "cloglog") {
+ } else if ( .link == "cloglog") {
mu.use = mu
smallno = 100 * .Machine$double.eps
mu.use[mu.use < smallno] = smallno
@@ -157,9 +157,9 @@
weight=eval(substitute(expression({
tmp100 = mu*(1-mu)
- tmp200 = if( .link == "logit") {
+ tmp200 = if ( .link == "logit") {
cbind(w * tmp100)
- } else if( .link == "cloglog") {
+ } else if ( .link == "cloglog") {
cbind(w * (1-mu.use) * (log1p(-mu.use))^2 / mu.use )
} else {
cbind(w * dtheta.deta(mu, link= .link, earg = .earg)^2 / tmp100)
@@ -167,7 +167,7 @@
for(ii in 1:M) {
index200 = !is.finite(tmp200[,ii]) |
(abs(tmp200[,ii]) < .Machine$double.eps)
- if(any(index200)) {
+ if (any(index200)) {
tmp200[index200,ii] = .Machine$double.eps # Diagonal 0's are bad
}
}
@@ -180,9 +180,9 @@
gammaff = function(link="nreciprocal", earg=list(), dispersion=0)
{
estimated.dispersion <- dispersion==0
- if(mode(link )!= "character" && mode(link )!= "name")
+ if (mode(link )!= "character" && mode(link )!= "name")
link <- as.character(substitute(link))
- if(!is.list(earg)) earg = list()
+ if (!is.list(earg)) earg = list()
new("vglmff",
blurb=c("Gamma distribution\n\n",
@@ -190,22 +190,22 @@
"Variance: mu^2 / k"),
deviance= function(mu, y, w, residuals = FALSE, eta, extra=NULL) {
devi <- -2 * w * (log(ifelse(y == 0, 1, y/mu)) - (y - mu)/mu)
- if(residuals) {
+ if (residuals) {
sign(y - mu) * sqrt(abs(devi) * w)
} else sum(w * devi)
},
initialize=eval(substitute(expression({
mustart <- y + 0.167 * (y == 0)
- M = if(is.matrix(y)) ncol(y) else 1
- dn2 = if(is.matrix(y)) dimnames(y)[[2]] else NULL
- dn2 = if(length(dn2)) {
+ M = if (is.matrix(y)) ncol(y) else 1
+ dn2 = if (is.matrix(y)) dimnames(y)[[2]] else NULL
+ dn2 = if (length(dn2)) {
paste("E[", dn2, "]", sep="")
} else {
paste("mu", 1:M, sep="")
}
predictors.names = namesof(if(M>1) dn2 else "mu", .link,
earg=.earg, short=TRUE)
- if(!length(etastart))
+ if (!length(etastart))
etastart <- theta2eta(mustart, link= .link, earg=.earg)
}), list( .link=link, .earg=earg ))),
inverse=eval(substitute(function(eta, extra=NULL) {
@@ -213,8 +213,8 @@
}, list( .link=link, .earg=earg ))),
last=eval(substitute(expression({
dpar <- .dispersion
- if(!dpar) {
- if(M == 1) {
+ if (!dpar) {
+ if (M == 1) {
temp = w * dmu.deta^2
dpar = sum(w * (y-mu)^2 * wz / temp) / (length(mu) - ncol(x))
} else {
@@ -230,7 +230,7 @@
misc$default.dispersion <- 0
misc$estimated.dispersion <- .estimated.dispersion
misc$link = rep( .link, length=M)
- names(misc$link) = if(M>1) paste("mu", 1:M, sep="") else "mu"
+ names(misc$link) = if (M>1) paste("mu", 1:M, sep="") else "mu"
misc$earg = vector("list", M)
names(misc$earg) = names(misc$link)
@@ -263,9 +263,9 @@
warning("@deviance() not finished")
warning("needs checking, but I'm sure it works")
- if(mode(link )!= "character" && mode(link )!= "name")
+ if (mode(link )!= "character" && mode(link )!= "name")
link <- as.character(substitute(link))
- if(!is.list(earg)) earg = list()
+ if (!is.list(earg)) earg = list()
new("vglmff",
blurb=c("Inverse Gaussian distribution\n\n",
@@ -276,13 +276,13 @@
devy <- y^(2-pow) / (1-pow) - y^(2-pow) / (2-pow)
devmu <- y * mu^(1-pow) / (1-pow) - mu^(2-pow) / (2-pow)
devi <- 2 * (devy - devmu)
- if(residuals) {
+ if (residuals) {
sign(y - mu) * sqrt(abs(devi) * w)
} else sum(w * devi)
},
initialize=eval(substitute(expression({
mu <- y + 0.167 * (y == 0)
- if(!length(etastart))
+ if (!length(etastart))
etastart <- theta2eta(mu, link= .link)
}), list( .link=link ))),
inverse=eval(substitute(function(eta, extra=NULL) {
@@ -290,7 +290,7 @@
}, list( .link=link ))),
last=eval(substitute(expression({
dpar <- .dispersion
- if(!dpar) {
+ if (!dpar) {
temp <- w * dmu.deta^2
dpar <- sum( w * (y-mu)^2 * wz / temp ) / (length(mu) - ncol(x))
}
@@ -298,7 +298,7 @@
misc$default.dispersion <- 0
misc$estimated.dispersion <- .estimated.dispersion
misc$link = rep( .link, length=M)
- names(misc$link) = if(M>1) paste("mu", 1:M, sep="") else "mu"
+ names(misc$link) = if (M>1) paste("mu", 1:M, sep="") else "mu"
}), list( .dispersion=dispersion,
.estimated.dispersion=estimated.dispersion,
.link=link ))),
@@ -321,7 +321,7 @@
dinv.gaussian = function(x, mu, lambda, log=FALSE) {
- if(!is.logical(log.arg <- log))
+ if (!is.logical(log.arg <- log))
stop("bad input for argument 'log'")
rm(log)
@@ -333,13 +333,13 @@ dinv.gaussian = function(x, mu, lambda, log=FALSE) {
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 (log.arg) logdensity else exp(logdensity)
}
pinv.gaussian = function(q, mu, lambda) {
- if(any(mu <=0)) stop("mu must be positive")
- if(any(lambda <=0)) stop("lambda must be positive")
+ if (any(mu <=0)) stop("mu must be positive")
+ if (any(lambda <=0)) stop("lambda must be positive")
ans = q
mu = rep(mu, len=length(q))
lambda = rep(lambda, len=length(q))
@@ -353,8 +353,8 @@ 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, integ=TRUE, allow=1, posit=TRUE))
+ use.n = if ((length.n <- length(n)) > 1) length.n else
+ if (!is.Numeric(n, integ=TRUE, allow=1, posit=TRUE))
stop("bad input for argument 'n'") else n
mu = rep(mu, len=use.n); lambda = rep(lambda, len=use.n)
u = runif(use.n)
@@ -374,12 +374,12 @@ rinv.gaussian = function(n, mu, lambda) {
ilambda=1,
zero=NULL)
{
- if(mode(lmu) != "character" && mode(lmu) != "name")
+ if (mode(lmu) != "character" && mode(lmu) != "name")
lmu <- as.character(substitute(lmu))
- if(mode(llambda) != "character" && mode(llambda) != "name")
+ if (mode(llambda) != "character" && mode(llambda) != "name")
llambda <- as.character(substitute(llambda))
- if(!is.list(emu)) emu = list()
- if(!is.list(elambda)) elambda = list()
+ if (!is.list(emu)) emu = list()
+ if (!is.list(elambda)) elambda = list()
new("vglmff",
blurb=c("Inverse Gaussian distribution\n\n",
@@ -392,13 +392,13 @@ rinv.gaussian = function(n, mu, lambda) {
constraints <- cm.zero.vgam(constraints, x, .zero, M)
}), list( .zero=zero ))),
initialize=eval(substitute(expression({
- if(ncol(cbind(y)) != 1)
+ if (ncol(cbind(y)) != 1)
stop("response must be a vector or a one-column matrix")
- if(any(y <= 0)) stop("Require the response to have positive values")
+ if (any(y <= 0)) stop("Require the response to have positive values")
predictors.names =
c(namesof("mu", .lmu, earg= .emu, short= TRUE),
namesof("lambda", .llambda, earg= .elambda, short= TRUE))
- if(!length(etastart)) {
+ if (!length(etastart)) {
initmu = y + 1/8
initlambda = rep(if(length( .ilambda)) .ilambda else 1, len=n)
etastart = cbind(
@@ -418,7 +418,7 @@ rinv.gaussian = function(n, mu, lambda) {
loglikelihood=eval(substitute(
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 {
+ if (residuals) stop("loglikelihood residuals not implemented yet") else {
sum(w * dinv.gaussian(x=y, mu=mu, lambda=lambda, log=TRUE))
}
}, list( .llambda=llambda, .emu=emu, .elambda=elambda ))),
@@ -447,13 +447,13 @@ rinv.gaussian = function(n, mu, lambda) {
{
estimated.dispersion <- dispersion==0
- if(mode(link )!= "character" && mode(link )!= "name")
+ if (mode(link )!= "character" && mode(link )!= "name")
link <- as.character(substitute(link))
- if(!is.list(earg)) earg = list()
- if(!is.Numeric(method.init, allow=1, integ=TRUE, posit=TRUE) ||
+ if (!is.list(earg)) earg = list()
+ if (!is.Numeric(method.init, allow=1, integ=TRUE, posit=TRUE) ||
method.init > 3)
stop("'method.init' must be 1 or 2 or 3")
- if(length(imu) && !is.Numeric(imu, posit=TRUE))
+ if (length(imu) && !is.Numeric(imu, posit=TRUE))
stop("bad input for argument 'imu'")
new("vglmff",
@@ -468,18 +468,18 @@ rinv.gaussian = function(n, mu, lambda) {
nz = y > 0
devi = -(y - mu)
devi[nz] = devi[nz] + y[nz] * log(y[nz]/mu[nz])
- if(residuals) sign(y - mu) * sqrt(2 * abs(devi) * w) else
+ if (residuals) sign(y - mu) * sqrt(2 * abs(devi) * w) else
2 * sum(w * devi)
},
initialize=eval(substitute(expression({
y = as.matrix(y)
M = ncoly = ncol(y)
- if(is.R()) assign("CQO.FastAlgorithm",
+ if (is.R()) assign("CQO.FastAlgorithm",
( .link == "loge"), envir = VGAMenv) else
CQO.FastAlgorithm <<- ( .link == "loge")
- dn2 = if(is.matrix(y)) dimnames(y)[[2]] else NULL
- dn2 = if(length(dn2)) {
+ dn2 = if (is.matrix(y)) dimnames(y)[[2]] else NULL
+ dn2 = if (length(dn2)) {
paste("E[", dn2, "]", sep="")
} else {
paste("mu", 1:M, sep="")
@@ -487,16 +487,16 @@ rinv.gaussian = function(n, mu, lambda) {
predictors.names = namesof(if(M>1) dn2 else "mu", .link,
earg= .earg, short=TRUE)
- if(!length(etastart)) {
+ if (!length(etastart)) {
mu.init = pmax(y, 1/8)
for(iii in 1:ncol(y)) {
- if( .method.init == 2) {
+ if ( .method.init == 2) {
mu.init[,iii] = weighted.mean(y[,iii], w) + 1/8
- } else if( .method.init == 3) {
+ } else if ( .method.init == 3) {
mu.init[,iii] = median(y[,iii]) + 1/8
}
}
- if(length(.imu))
+ if (length(.imu))
mu.init = matrix( .imu, n, ncoly, byrow=TRUE)
etastart <- theta2eta(mu.init, link= .link, earg= .earg)
}
@@ -507,24 +507,24 @@ rinv.gaussian = function(n, mu, lambda) {
mu
}, list( .link=link, .earg=earg ))),
last=eval(substitute(expression({
- if(is.R()) {
- if(exists("CQO.FastAlgorithm", envir = VGAMenv))
+ if (is.R()) {
+ if (exists("CQO.FastAlgorithm", envir = VGAMenv))
rm("CQO.FastAlgorithm", envir = VGAMenv)
} else {
while(exists("CQO.FastAlgorithm"))
remove("CQO.FastAlgorithm")
}
dpar <- .dispersion
- if(!dpar) {
+ if (!dpar) {
temp87 = (y-mu)^2 *
wz / (dtheta.deta(mu, link= .link, earg= .earg)^2) # w cancel
- if(M > 1 && ! .onedpar) {
+ 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)
+ nrow.mu = if (is.matrix(mu)) nrow(mu) else length(mu)
for(ii in 1:M)
dpar[ii] = sum(temp87[,ii]) / (nrow.mu - ncol(x))
- if(is.matrix(y) && length(dimnames(y)[[2]])==length(dpar))
+ if (is.matrix(y) && length(dimnames(y)[[2]])==length(dpar))
names(dpar) = dimnames(y)[[2]]
} else
dpar = sum(temp87) / (length(mu) - ncol(x))
@@ -534,7 +534,7 @@ rinv.gaussian = function(n, mu, lambda) {
misc$estimated.dispersion <- .estimated.dispersion
misc$expected = TRUE
misc$link = rep( .link, length=M)
- names(misc$link) = if(M>1) dn2 else "mu"
+ names(misc$link) = if (M>1) dn2 else "mu"
misc$method.init = .method.init
misc$earg = vector("list", M)
@@ -547,13 +547,13 @@ 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) {
- if(residuals) w*(y/mu - 1) else {
+ if (residuals) w*(y/mu - 1) else {
sum(w * dpois(x=y, lambda=mu, log=TRUE))
}
},
vfamily="poissonff",
deriv=eval(substitute(expression({
- if( .link == "loge" && (any(mu < .Machine$double.eps))) {
+ if ( .link == "loge" && (any(mu < .Machine$double.eps))) {
w * (y - mu)
} else {
lambda <- mu
@@ -563,7 +563,7 @@ rinv.gaussian = function(n, mu, lambda) {
}
}), list( .link=link, .earg=earg ))),
weight=eval(substitute(expression({
- if( .link == "loge" && (any(mu < .Machine$double.eps))) {
+ if ( .link == "loge" && (any(mu < .Machine$double.eps))) {
tmp600 = mu
tmp600[tmp600 < .Machine$double.eps] = .Machine$double.eps
w * tmp600
@@ -611,12 +611,12 @@ poissonqn.control <- function(save.weight=TRUE, ...)
wwts=c("expected","observed","qn"))
{
estimated.dispersion <- dispersion==0
- if(mode(link )!= "character" && mode(link )!= "name")
+ if (mode(link )!= "character" && mode(link )!= "name")
link <- as.character(substitute(link))
- if(mode(wwts) != "character" && mode(wwts) != "name")
+ if (mode(wwts) != "character" && mode(wwts) != "name")
wwts <- as.character(substitute(wwts))
wwts <- match.arg(wwts, c("expected","observed","qn"))[1]
- if(!is.list(earg)) earg = list()
+ if (!is.list(earg)) earg = list()
new("vglmff",
blurb=c("Poisson distribution\n\n",
@@ -630,13 +630,13 @@ poissonqn.control <- function(save.weight=TRUE, ...)
nz = y > 0
devi = -(y - mu)
devi[nz] = devi[nz] + y[nz] * log(y[nz]/mu[nz])
- if(residuals) sign(y - mu) * sqrt(2 * abs(devi) * w) else
+ if (residuals) sign(y - mu) * sqrt(2 * abs(devi) * w) else
2 * sum(w * devi)
},
initialize=eval(substitute(expression({
- M = if(is.matrix(y)) ncol(y) else 1
- dn2 = if(is.matrix(y)) dimnames(y)[[2]] else NULL
- dn2 = if(length(dn2)) {
+ M = if (is.matrix(y)) ncol(y) else 1
+ dn2 = if (is.matrix(y)) dimnames(y)[[2]] else NULL
+ dn2 = if (length(dn2)) {
paste("E[", dn2, "]", sep="")
} else {
paste("mu", 1:M, sep="")
@@ -644,7 +644,7 @@ poissonqn.control <- function(save.weight=TRUE, ...)
predictors.names = namesof(if(M>1) dn2 else "mu", .link,
earg= .earg, short=TRUE)
mu = pmax(y, 0.167) # y + 0.167 * (y == 0)
- if(!length(etastart))
+ if (!length(etastart))
etastart <- theta2eta(mu, link= .link, earg= .earg)
}), list( .link=link, .estimated.dispersion=estimated.dispersion,
.earg=earg ))),
@@ -654,15 +654,15 @@ poissonqn.control <- function(save.weight=TRUE, ...)
.earg=earg ))),
last=eval(substitute(expression({
dpar <- .dispersion
- if(!dpar) {
+ if (!dpar) {
temp87= (y-mu)^2 * wz/(dtheta.deta(mu, link= .link, earg= .earg)^2)
- if(M > 1 && ! .onedpar) {
+ 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)
+ 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))
+ if (is.matrix(y) && length(dimnames(y)[[2]])==length(dpar))
names(dpar) = dimnames(y)[[2]]
} else
dpar = sum(temp87) / (length(mu) - ncol(x))
@@ -673,7 +673,7 @@ poissonqn.control <- function(save.weight=TRUE, ...)
misc$estimated.dispersion <- .estimated.dispersion
misc$expected = FALSE
misc$link = rep( .link, length=M)
- names(misc$link) = if(M>1) dn2 else "mu"
+ names(misc$link) = if (M>1) dn2 else "mu"
misc$earg = vector("list", M)
names(misc$earg) = names(misc$link)
@@ -687,13 +687,13 @@ poissonqn.control <- function(save.weight=TRUE, ...)
}, list( .link=link,
.earg=earg ))),
loglikelihood= function(mu, y, w, residuals = FALSE, eta, extra=NULL) {
- if(residuals) w*(y/mu - 1) else {
+ if (residuals) w*(y/mu - 1) else {
sum(w * dpois(x=y, lambda=mu, log=TRUE))
}
},
vfamily="poissonqn",
deriv=eval(substitute(expression({
- if(iter == 1) {
+ if (iter == 1) {
etanew = eta
} else {
derivold = derivnew
@@ -702,7 +702,7 @@ poissonqn.control <- function(save.weight=TRUE, ...)
}
derivnew =
- if( .link == "loge" && (any(mu < .Machine$double.eps))) {
+ if ( .link == "loge" && (any(mu < .Machine$double.eps))) {
w * (y - mu)
} else {
lambda <- mu
@@ -714,8 +714,8 @@ poissonqn.control <- function(save.weight=TRUE, ...)
}), list( .link=link,
.earg=earg ))),
weight=eval(substitute(expression({
- if( .wwts == "qn") {
- if(iter == 1) {
+ if ( .wwts == "qn") {
+ if (iter == 1) {
wznew = cbind(matrix(w, n, M), matrix(0, n, dimm(M)-M))
} else {
wzold = wznew
@@ -723,8 +723,8 @@ poissonqn.control <- function(save.weight=TRUE, ...)
deta=etanew-etaold, M=M,
trace=trace) # weights incorporated in args
}
- } else if( .wwts == "expected") {
- wznew = if( .link == "loge") {
+ } else if ( .wwts == "expected") {
+ wznew = if ( .link == "loge") {
tmp600 = mu
tmp600[tmp600 < .Machine$double.eps] = .Machine$double.eps
w * tmp600
@@ -733,7 +733,7 @@ poissonqn.control <- function(save.weight=TRUE, ...)
w * dlambda.deta^2 * d2l.dlambda2
}
} else {
- wznew = if( .link == "loge") {
+ wznew = if ( .link == "loge") {
tmp600 = y
tmp600[y < .Machine$double.eps] = sqrt(.Machine$double.eps)
w * tmp600
@@ -754,14 +754,14 @@ poissonqn.control <- function(save.weight=TRUE, ...)
idispersion=0.8,
zero=NULL)
{
- if(mode(lmean)!= "character" && mode(lmean)!= "name")
+ if (mode(lmean)!= "character" && mode(lmean)!= "name")
lmean = as.character(substitute(lmean))
- if(mode(ldispersion)!= "character" && mode(ldispersion)!= "name")
+ if (mode(ldispersion)!= "character" && mode(ldispersion)!= "name")
ldispersion = as.character(substitute(ldispersion))
- if(!is.Numeric(idispersion, posit=TRUE))
+ if (!is.Numeric(idispersion, posit=TRUE))
stop("bad input for 'idispersion'")
- if(!is.list(emean)) emean = list()
- if(!is.list(edispersion)) edispersion = list()
+ if (!is.list(emean)) emean = list()
+ if (!is.list(edispersion)) edispersion = list()
new("vglmff",
blurb=c("Double Exponential Poisson distribution\n\n",
@@ -774,11 +774,11 @@ poissonqn.control <- function(save.weight=TRUE, ...)
constraints = cm.zero.vgam(constraints, x, .zero, M)
}), list( .zero=zero ))),
initialize=eval(substitute(expression({
- if(ncol(cbind(y)) != 1)
+ if (ncol(cbind(y)) != 1)
stop("response must be a vector or a one-column matrix")
- M = if(is.matrix(y)) ncol(y) else 1
- dn2 = if(is.matrix(y)) dimnames(y)[[2]] else NULL
- dn2 = if(length(dn2)) {
+ M = if (is.matrix(y)) ncol(y) else 1
+ dn2 = if (is.matrix(y)) dimnames(y)[[2]] else NULL
+ dn2 = if (length(dn2)) {
paste("E[", dn2, "]", sep="")
} else {
"mu"
@@ -788,7 +788,7 @@ poissonqn.control <- function(save.weight=TRUE, ...)
namesof("dispersion", link= .ldispersion,
earg= .edispersion, short=TRUE))
init.mu = pmax(y, 1/8)
- if(!length(etastart))
+ if (!length(etastart))
etastart = cbind(theta2eta(init.mu, link= .lmean,earg= .emean),
theta2eta(rep( .idispersion, len=n),
link= .ldispersion, earg= .edispersion))
@@ -809,7 +809,7 @@ poissonqn.control <- function(save.weight=TRUE, ...)
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 {
+ if (residuals) stop("loglikelihood residuals not implemented yet") else {
sum(w*(0.5*log(Disper) + Disper*(y-lambda) + Disper*y*log(lambda)))
}
}, list( .lmean=lmean, .emean=emean,
@@ -844,14 +844,14 @@ poissonqn.control <- function(save.weight=TRUE, ...)
idispersion=0.25,
zero=2)
{
- if(mode(lmean)!= "character" && mode(lmean)!= "name")
+ if (mode(lmean)!= "character" && mode(lmean)!= "name")
lmean = as.character(substitute(lmean))
- if(mode(ldispersion)!= "character" && mode(ldispersion)!= "name")
+ if (mode(ldispersion)!= "character" && mode(ldispersion)!= "name")
ldispersion = as.character(substitute(ldispersion))
- if(!is.Numeric(idispersion, posit=TRUE))
+ if (!is.Numeric(idispersion, posit=TRUE))
stop("bad input for 'idispersion'")
- if(!is.list(emean)) emean = list()
- if(!is.list(edispersion)) edispersion = list()
+ if (!is.list(emean)) emean = list()
+ if (!is.list(edispersion)) edispersion = list()
new("vglmff",
blurb=c("Double Exponential Binomial distribution\n\n",
@@ -863,24 +863,24 @@ poissonqn.control <- function(save.weight=TRUE, ...)
constraints = cm.zero.vgam(constraints, x, .zero, M)
}), list( .zero=zero ))),
initialize=eval(substitute(expression({
- if(ncol(cbind(w)) != 1)
+ if (ncol(cbind(w)) != 1)
stop("'weights' must be a vector or a one-column matrix")
NCOL = function (x)
- if(is.array(x) && length(dim(x)) > 1 ||
+ if (is.array(x) && length(dim(x)) > 1 ||
is.data.frame(x)) ncol(x) else as.integer(1)
- if(NCOL(y) == 1) {
- if(is.factor(y)) y = y != levels(y)[1]
+ if (NCOL(y) == 1) {
+ if (is.factor(y)) y = y != levels(y)[1]
nn = rep(1, n)
- if(!all(y >= 0 & y <= 1))
+ if (!all(y >= 0 & y <= 1))
stop("response values must be in [0, 1]")
init.mu = (0.5 + w * y) / (1 + w)
no.successes = w * y
- if(any(abs(no.successes - round(no.successes)) > 0.001))
+ if (any(abs(no.successes - round(no.successes)) > 0.001))
stop("Number of successes must be integer-valued")
- } else if(NCOL(y) == 2) {
- if(any(abs(y - round(y)) > 0.001))
+ } 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)
@@ -890,8 +890,8 @@ poissonqn.control <- function(save.weight=TRUE, ...)
stop("Response not of the right form")
- dn2 = if(is.matrix(y)) dimnames(y)[[2]] else NULL
- dn2 = if(length(dn2)) {
+ dn2 = if (is.matrix(y)) dimnames(y)[[2]] else NULL
+ dn2 = if (length(dn2)) {
paste("E[", dn2, "]", sep="")
} else {
"mu"
@@ -900,7 +900,7 @@ poissonqn.control <- function(save.weight=TRUE, ...)
c(namesof(dn2, link= .lmean, earg= .emean, short=TRUE),
namesof("dispersion", link= .ldispersion,
earg= .edispersion, short=TRUE))
- if(!length(etastart))
+ if (!length(etastart))
etastart = cbind(theta2eta(init.mu, link= .lmean,earg= .emean),
theta2eta(rep( .idispersion, len=n),
link= .ldispersion, earg= .edispersion))
@@ -921,7 +921,7 @@ poissonqn.control <- function(save.weight=TRUE, ...)
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)
- if(residuals) stop("loglikelihood residuals not implemented yet") else {
+ if (residuals) stop("loglikelihood residuals not implemented yet") else {
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)
sum(0.5*log(Disper) + w*(y*Disper*log(prob) +
@@ -963,18 +963,18 @@ poissonqn.control <- function(save.weight=TRUE, ...)
mbinomial = function(mvar=NULL, link="logit", earg=list(),
parallel = TRUE, smallno = .Machine$double.eps^(3/4))
{
- if(mode(link )!= "character" && mode(link )!= "name")
+ if (mode(link )!= "character" && mode(link )!= "name")
link <- as.character(substitute(link))
- if(!is.list(earg)) earg = list()
- if(!is.Numeric(smallno, positive=TRUE, allow=1) || smallno > 1e-4)
+ if (!is.list(earg)) earg = list()
+ if (!is.Numeric(smallno, positive=TRUE, allow=1) || smallno > 1e-4)
stop("bad input for 'smallno'")
- if(is.logical(parallel) && !parallel)
+ if (is.logical(parallel) && !parallel)
stop("'parallel' must be TRUE")
temp = terms(mvar)
mvar = attr(temp,"term.labels")
- if(length(mvar) != 1) stop("cannot obtain the matching variable")
- if(!is.character(mvar) || length(mvar) != 1) {
+ if (length(mvar) != 1) stop("cannot obtain the matching variable")
+ if (!is.character(mvar) || length(mvar) != 1) {
stop("bad input for 'mvar'")
}
@@ -996,20 +996,20 @@ poissonqn.control <- function(save.weight=TRUE, ...)
mvar = .mvar
NCOL = function (x)
- if(is.array(x) && length(dim(x)) > 1 ||
+ if (is.array(x) && length(dim(x)) > 1 ||
is.data.frame(x)) ncol(x) else as.integer(1)
- if(NCOL(y) == 1) {
- if(is.factor(y)) y = y != levels(y)[1]
+ if (NCOL(y) == 1) {
+ if (is.factor(y)) y = y != levels(y)[1]
nn = rep(1, n)
- if(!all(y >= 0 & y <= 1))
+ if (!all(y >= 0 & y <= 1))
stop("response values must be in [0, 1]")
mustart = (0.5 + w * y) / (1 + w)
no.successes = w * y
- if(any(abs(no.successes - round(no.successes)) > 0.001))
+ if (any(abs(no.successes - round(no.successes)) > 0.001))
stop("Number of successes must be integer-valued")
- } else if(NCOL(y) == 2) {
- if(any(abs(y - round(y)) > 0.001))
+ } 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)
@@ -1019,7 +1019,7 @@ poissonqn.control <- function(save.weight=TRUE, ...)
stop("Response not of the right form")
temp1 = attr(x, "assign")
- if(colnames(x)[1] != "(Intercept)") stop("x must have an intercept")
+ if (colnames(x)[1] != "(Intercept)") stop("x must have an intercept")
M = CCC = length(temp1[[mvar]]) + (colnames(x)[1] == "(Intercept)")
temp9 = x[,temp1[[mvar]],drop=FALSE]
temp9 = temp9 * matrix(2:CCC, n, CCC-1, byrow=TRUE)
@@ -1040,7 +1040,7 @@ poissonqn.control <- function(save.weight=TRUE, ...)
}, list( .link=link, .earg = earg ))),
last=eval(substitute(expression({
misc$link = rep( .link, length=M)
- names(misc$link) = if(M>1) paste("mu(matched set ",
+ names(misc$link) = if (M>1) paste("mu(matched set ",
1:M, ")", sep="") else "mu"
misc$earg = vector("list", M)
names(misc$earg) = names(misc$link)
@@ -1053,16 +1053,16 @@ poissonqn.control <- function(save.weight=TRUE, ...)
matrix(temp, extra$n, extra$M)
}, list( .link=link, .earg = earg ))),
loglikelihood= function(mu, y, w, residuals = FALSE, eta, extra=NULL) {
- if(residuals) w*(y/mu - (1-y)/(1-mu)) else {
+ if (residuals) w*(y/mu - (1-y)/(1-mu)) else {
sum(w*(y*log(mu) + (1-y)*log1p(-mu)))
}
},
vfamily=c("mbinomial", "vcategorical"),
deriv=eval(substitute(expression({
answer =
- if( .link == "logit") {
+ if ( .link == "logit") {
w * (y - mu)
- } else if( .link == "cloglog") {
+ } else if ( .link == "cloglog") {
mu.use = mu
smallno = 100 * .Machine$double.eps
mu.use[mu.use < smallno] = smallno
@@ -1076,9 +1076,9 @@ poissonqn.control <- function(save.weight=TRUE, ...)
}), list( .link=link, .earg = earg ))),
weight=eval(substitute(expression({
tmp100 = mu*(1-mu)
- answer = if( .link == "logit") {
+ answer = if ( .link == "logit") {
cbind(w * tmp100)
- } else if( .link == "cloglog") {
+ } else if ( .link == "cloglog") {
cbind(w * (1-mu.use) * (log1p(-mu.use))^2 / mu.use )
} else {
cbind(w * dtheta.deta(mu, link= .link, earg = .earg)^2 / tmp100)
@@ -1104,17 +1104,17 @@ mypool = function(x, index) {
}
-if(FALSE)
+ if (FALSE)
mbino = function()
{
link = "logit"
earg = list()
parallel = TRUE
- if(mode(link )!= "character" && mode(link )!= "name")
+ if (mode(link )!= "character" && mode(link )!= "name")
link <- as.character(substitute(link))
- if(!is.list(earg)) earg = list()
- if(is.logical(parallel) && !parallel)
+ if (!is.list(earg)) earg = list()
+ if (is.logical(parallel) && !parallel)
stop("'parallel' must be TRUE")
@@ -1126,24 +1126,24 @@ if(FALSE)
intercept.apply=FALSE)
}), list( .parallel=parallel ))),
initialize=eval(substitute(expression({
- if(colnames(x)[1] == "(Intercept)")
+ if (colnames(x)[1] == "(Intercept)")
stop("the model matrix must not have an intercept")
NCOL = function (x)
- if(is.array(x) && length(dim(x)) > 1 ||
+ if (is.array(x) && length(dim(x)) > 1 ||
is.data.frame(x)) ncol(x) else as.integer(1)
- if(NCOL(y) == 1) {
- if(is.factor(y)) y = y != levels(y)[1]
+ if (NCOL(y) == 1) {
+ if (is.factor(y)) y = y != levels(y)[1]
nn = rep(1, n)
- if(!all(y >= 0 & y <= 1))
+ if (!all(y >= 0 & y <= 1))
stop("response values must be in [0, 1]")
mustart = (0.5 + w * y) / (1 + w)
no.successes = w * y
- if(any(abs(no.successes - round(no.successes)) > 0.001))
+ if (any(abs(no.successes - round(no.successes)) > 0.001))
stop("Number of successes must be integer-valued")
- } else if(NCOL(y) == 2) {
- if(any(abs(y - round(y)) > 0.001))
+ } 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)
@@ -1152,17 +1152,17 @@ if(FALSE)
} else
stop("Response not of the right form")
- if(!length(etastart))
+ if (!length(etastart))
etastart <- theta2eta(mustart, link= "logit", earg= list())
temp1 = attr(x, "assign")
mvar = extra$mvar
- if(length(mvar) != n) stop("input extra$mvar doesn't look right")
+ if (length(mvar) != n) stop("input extra$mvar doesn't look right")
- if(any(y != 0 & y != 1))
+ if (any(y != 0 & y != 1))
stop("response vector must have 0 or 1 values only")
xrle = rle(mvar)
- if(length(unique(mvar)) != length(xrel$length))
+ if (length(unique(mvar)) != length(xrel$length))
stop("extra$mvar must take on contiguous values")
temp9 = factor(mvar)
@@ -1184,21 +1184,21 @@ if(FALSE)
misc$expected = TRUE
}), list( .link=link, .earg = earg ))),
loglikelihood= function(mu, y, w, residuals = FALSE, eta, extra=NULL) {
- if(residuals) w*(y/mu - (1-y)/(1-mu)) else {
+ if (residuals) w*(y/mu - (1-y)/(1-mu)) else {
sum(w*(y*log(mu) + (1-y)*log1p(-mu)))
}
},
vfamily=c("mbin", "vcategorical"),
deriv=eval(substitute(expression({
answer =
- if( .link == "logit") {
+ if ( .link == "logit") {
w * (y - mu)
} else stop("can only handle the logit link")
answer
}), list( .link=link, .earg = earg ))),
weight=eval(substitute(expression({
tmp100 = mu*(1-mu)
- answer = if( .link == "logit") {
+ answer = if ( .link == "logit") {
cbind(w * tmp100)
} else stop("can only handle the logit link")
diff --git a/R/family.loglin.q b/R/family.loglin.R
similarity index 95%
rename from R/family.loglin.q
rename to R/family.loglin.R
index f6c14ac..9e328a8 100644
--- a/R/family.loglin.q
+++ b/R/family.loglin.R
@@ -1,5 +1,5 @@
# These functions are
-# Copyright (C) 1998-2009 T.W. Yee, University of Auckland. All rights reserved.
+# Copyright (C) 1998-2010 T.W. Yee, University of Auckland. All rights reserved.
@@ -21,16 +21,16 @@ loglinb2 <- function(exchangeable=FALSE, zero=NULL)
y <- as.matrix(y)
predictors.names <- c("u1", "u2", "u12")
- if(ncol(y) != 2)
+ if (ncol(y) != 2)
stop("ncol(y) must be = 2")
- if(is.null(mustart)) {
+ if (is.null(mustart)) {
mustart <- matrix(as.numeric(NA), nrow(y), 4)
mustart[,1] <- weighted.mean((1-y[,1])*(1-y[,2]), w)
mustart[,2] <- weighted.mean((1-y[,1])*y[,2], w)
mustart[,3] <- weighted.mean(y[,1]*(1-y[,2]), w)
mustart[,4] <- weighted.mean(y[,1]*y[,2], w)
- if(any(mustart==0))
+ if (any(mustart==0))
stop("some combinations of the response not realized")
}
}),
@@ -61,7 +61,7 @@ loglinb2 <- function(exchangeable=FALSE, zero=NULL)
u12 <- eta[,3]
denom <- 1 + exp(u1) + exp(u2) + exp(u1 + u2 + u12)
u0 <- -log(denom)
- if(residuals) stop("loglikelihood residuals not implemented yet") else
+ if (residuals) stop("loglikelihood residuals not implemented yet") else
sum(w*(u0 + u1*y[,1] + u2*y[,2] + u12*y[,1]*y[,2]))
},
vfamily=c("loglinb2"),
@@ -113,7 +113,7 @@ loglinb3 <- function(exchangeable=FALSE, zero=NULL)
initialize=expression({
y <- as.matrix(y)
predictors.names <- c("u1", "u2", "u3", "u12", "u13", "u23")
- if(ncol(y) != 3)
+ if (ncol(y) != 3)
stop("ncol(y) must be = 3")
extra$my.expression <- expression({
u1 <- eta[,1]
@@ -135,7 +135,7 @@ loglinb3 <- function(exchangeable=FALSE, zero=NULL)
A13 <- exp(u1 + u3 + u13) + allterms
A23 <- exp(u2 + u3 + u23) + allterms
})
- if(!length(mustart)) {
+ if (!length(mustart)) {
mustart <- matrix(as.numeric(NA), nrow(y), 2^3)
mustart[,1] <- weighted.mean((1-y[,1])*(1-y[,2])*(1-y[,3]), w)
mustart[,2] <- weighted.mean((1-y[,1])*(1-y[,2])*y[,3], w)
@@ -145,7 +145,7 @@ loglinb3 <- function(exchangeable=FALSE, zero=NULL)
mustart[,6] <- weighted.mean(y[,1]*(1-y[,2])*y[,3], w)
mustart[,7] <- weighted.mean(y[,1]*y[,2]*(1-y[,3]), w)
mustart[,8] <- weighted.mean(y[,1]*y[,2]*y[,3], w)
- if(any(mustart==0))
+ if (any(mustart==0))
stop("some combinations of the response not realized")
}
}),
@@ -179,7 +179,7 @@ loglinb3 <- function(exchangeable=FALSE, zero=NULL)
loglikelihood=function(mu,y,w,residuals=FALSE,eta,extra=NULL) {
eval(extra$my.expression)
u0 <- -log(denom)
- if(residuals) stop("loglikelihood residuals not implemented yet") else
+ if (residuals) stop("loglikelihood residuals not implemented yet") else
sum(w*(u0 + u1*y[,1] + u2*y[,2] + u3*y[,3] +u12*y[,1]*y[,2] +
u13*y[,1]*y[,3] + u23*y[,2]*y[,3]))
},
diff --git a/R/family.mixture.q b/R/family.mixture.R
similarity index 88%
rename from R/family.mixture.q
rename to R/family.mixture.R
index 6ba9270..0ee8604 100644
--- a/R/family.mixture.q
+++ b/R/family.mixture.R
@@ -1,5 +1,5 @@
# These functions are
-# Copyright (C) 1998-2009 T.W. Yee, University of Auckland. All rights reserved.
+# Copyright (C) 1998-2010 T.W. Yee, University of Auckland. All rights reserved.
@@ -24,32 +24,32 @@ mix2normal1 = function(lphi="logit",
nsimEIM=100,
zero=1)
{
- if(mode(lphi) != "character" && mode(lphi) != "name")
+ if (mode(lphi) != "character" && mode(lphi) != "name")
lphi = as.character(substitute(lphi))
- if(mode(lmu) != "character" && mode(lmu) != "name")
+ if (mode(lmu) != "character" && mode(lmu) != "name")
lmu = as.character(substitute(lmu))
- if(mode(lsd) != "character" && mode(lsd) != "name")
+ if (mode(lsd) != "character" && mode(lsd) != "name")
lsd = as.character(substitute(lsd))
- if(!is.Numeric(qmu, allow=2, positive=TRUE) || any(qmu >= 1))
+ if (!is.Numeric(qmu, allow=2, positive=TRUE) || any(qmu >= 1))
stop("bad input for argument 'qmu'")
- if(length(iphi) && (!is.Numeric(iphi, allow=1, positive=TRUE) || iphi>= 1))
+ if (length(iphi) && (!is.Numeric(iphi, allow=1, positive=TRUE) || iphi>= 1))
stop("bad input for argument 'iphi'")
- if(length(imu1) && !is.Numeric(imu1))
+ if (length(imu1) && !is.Numeric(imu1))
stop("bad input for argument 'imu1'")
- if(length(imu2) && !is.Numeric(imu2))
+ if (length(imu2) && !is.Numeric(imu2))
stop("bad input for argument 'imu2'")
- if(length(isd1) && !is.Numeric(isd1, positive=TRUE))
+ if (length(isd1) && !is.Numeric(isd1, positive=TRUE))
stop("bad input for argument 'isd1'")
- if(length(isd2) && !is.Numeric(isd2, positive=TRUE))
+ if (length(isd2) && !is.Numeric(isd2, positive=TRUE))
stop("bad input for argument 'isd2'")
- if(!is.list(ephi)) ephi = list()
- if(!is.list(emu1)) emu1 = list()
- if(!is.list(emu2)) emu2 = list()
- if(!is.list(esd1)) esd1 = list()
- if(!is.list(esd2)) esd2 = list()
- if(!is.logical(equalsd) || length(equalsd) != 1)
+ if (!is.list(ephi)) ephi = list()
+ if (!is.list(emu1)) emu1 = list()
+ if (!is.list(emu2)) emu2 = list()
+ if (!is.list(esd1)) esd1 = list()
+ if (!is.list(esd2)) esd2 = list()
+ if (!is.logical(equalsd) || length(equalsd) != 1)
stop("bad input for argument 'equalsd'")
- if(!is.Numeric(nsimEIM, allow=1, integ=TRUE) || nsimEIM <= 10)
+ if (!is.Numeric(nsimEIM, allow=1, integ=TRUE) || nsimEIM <= 10)
stop("'nsimEIM' should be an integer greater than 10")
new("vglmff",
@@ -68,7 +68,7 @@ mix2normal1 = function(lphi="logit",
constraints = cm.zero.vgam(constraints, x, .zero, M)
}), list(.zero=zero, .equalsd=equalsd))),
initialize=eval(substitute(expression({
- if(ncol(y <- cbind(y)) != 1)
+ if (ncol(y <- cbind(y)) != 1)
stop("the response must be a vector or one-column matrix")
predictors.names = c(
namesof("phi", .lphi, tag=FALSE),
@@ -76,21 +76,21 @@ mix2normal1 = function(lphi="logit",
namesof("sd1", .lsd, earg= .esd1, tag=FALSE),
namesof("mu2", .lmu, earg= .emu2, tag=FALSE),
namesof("sd2", .lsd, earg= .esd2, tag=FALSE))
- if(!length(etastart)) {
+ if (!length(etastart)) {
qy = quantile(y, prob= .qmu)
init.phi = rep(if(length(.iphi)) .iphi else 0.5, length=n)
init.mu1 = rep(if(length(.imu1)) .imu1 else qy[1], length=n)
init.mu2 = rep(if(length(.imu2)) .imu2 else qy[2], length=n)
- ind.1 = if(init.mu1[1] < init.mu2[1]) 1:round(n* init.phi[1]) else
+ ind.1 = if (init.mu1[1] < init.mu2[1]) 1:round(n* init.phi[1]) else
round(n* init.phi[1]):n
- ind.2 = if(init.mu1[1] < init.mu2[1]) round(n* init.phi[1]):n else
+ ind.2 = if (init.mu1[1] < init.mu2[1]) round(n* init.phi[1]):n else
1:round(n* init.phi[1])
sorty = sort(y)
init.sd1 = rep(if(length(.isd1)) .isd1 else sd(sorty[ind.1]), len=n)
init.sd2 = rep(if(length(.isd2)) .isd2 else sd(sorty[ind.2]), len=n)
- if( .equalsd ) {
+ if ( .equalsd ) {
init.sd1 = init.sd2 = (init.sd1 + init.sd2)/2
- if(!all.equal( .esd1, .esd2 ))
+ if (!all.equal( .esd1, .esd2 ))
stop("'esd1' and 'esd2' must be equal if equalsd=TRUE")
}
etastart = cbind(theta2eta(init.phi, .lphi, earg= .ephi),
@@ -130,7 +130,7 @@ mix2normal1 = function(lphi="logit",
sd2 = eta2theta(eta[,5], link= .lsd, earg= .esd2)
f1 = dnorm(y, mean=mu1, sd=sd1)
f2 = dnorm(y, mean=mu2, sd=sd2)
- if(residuals) stop("loglikelihood residuals not implemented yet") else
+ if (residuals) stop("loglikelihood residuals not implemented yet") else
sum(w * log(phi*f1 + (1-phi)*f2))
}, list(.lphi=lphi, .lmu=lmu,
.ephi=ephi, .emu1=emu1, .emu2=emu2, .esd1=esd1, .esd2=esd2,
@@ -190,7 +190,7 @@ mix2normal1 = function(lphi="logit",
run.mean = ((ii-1) * run.mean + temp3) / ii
}
- wz = if(intercept.only)
+ wz = if (intercept.only)
matrix(colMeans(run.mean), n, dimm(M), byrow=TRUE) else run.mean
dtheta.detas = cbind(dphi.deta,dmu1.deta,dsd1.deta,dmu2.deta,dsd2.deta)
@@ -214,22 +214,22 @@ mix2poisson = function(lphi="logit", llambda="loge",
iphi=0.5, il1=NULL, il2=NULL,
qmu=c(0.2, 0.8), nsimEIM=100, zero=1)
{
- if(mode(lphi) != "character" && mode(lphi) != "name")
+ if (mode(lphi) != "character" && mode(lphi) != "name")
lphi = as.character(substitute(lphi))
- if(mode(llambda) != "character" && mode(llambda) != "name")
+ if (mode(llambda) != "character" && mode(llambda) != "name")
llambda = as.character(substitute(llambda))
- if(!is.Numeric(qmu, allow=2, positive=TRUE) || any(qmu >= 1))
+ if (!is.Numeric(qmu, allow=2, positive=TRUE) || any(qmu >= 1))
stop("bad input for argument 'qmu'")
- if(length(iphi) && (!is.Numeric(iphi, allow=1, positive=TRUE) || iphi>= 1))
+ if (length(iphi) && (!is.Numeric(iphi, allow=1, positive=TRUE) || iphi>= 1))
stop("bad input for argument 'iphi'")
- if(length(il1) && !is.Numeric(il1))
+ if (length(il1) && !is.Numeric(il1))
stop("bad input for argument 'il1'")
- if(length(il2) && !is.Numeric(il2))
+ if (length(il2) && !is.Numeric(il2))
stop("bad input for argument 'il2'")
- if(!is.list(ephi)) ephi = list()
- if(!is.list(el1)) el1 = list()
- if(!is.list(el2)) el2 = list()
- if(!is.Numeric(nsimEIM, allow=1, integ=TRUE) || nsimEIM <= 10)
+ if (!is.list(ephi)) ephi = list()
+ if (!is.list(el1)) el1 = list()
+ if (!is.list(el2)) el2 = list()
+ if (!is.Numeric(nsimEIM, allow=1, integ=TRUE) || nsimEIM <= 10)
stop("'nsimEIM' should be an integer greater than 10")
new("vglmff",
@@ -243,17 +243,17 @@ mix2poisson = function(lphi="logit", llambda="loge",
constraints = cm.zero.vgam(constraints, x, .zero, M)
}), list(.zero=zero ))),
initialize=eval(substitute(expression({
- if(ncol(y <- cbind(y)) != 1)
+ if (ncol(y <- cbind(y)) != 1)
stop("the response must be a vector or one-column matrix")
predictors.names = c(namesof("phi", .lphi, earg= .ephi, tag=FALSE),
namesof("lambda1", .llambda, earg= .el1, tag=FALSE),
namesof("lambda2", .llambda, earg= .el2, tag=FALSE))
- if(!length(etastart)) {
+ if (!length(etastart)) {
qy = quantile(y, prob= .qmu)
init.phi = rep(if(length(.iphi)) .iphi else 0.5, length=n)
init.lambda1 = rep(if(length(.il1)) .il1 else qy[1], length=n)
init.lambda2 = rep(if(length(.il2)) .il2 else qy[2], length=n)
- if(!length(etastart))
+ if (!length(etastart))
etastart = cbind(theta2eta(init.phi, .lphi, earg= .ephi),
theta2eta(init.lambda1, .llambda, earg= .el1),
theta2eta(init.lambda2, .llambda, earg= .el2))
@@ -282,7 +282,7 @@ mix2poisson = function(lphi="logit", llambda="loge",
lambda2 = eta2theta(eta[,3], link= .llambda, earg= .el2)
f1 = dpois(y, lam=lambda1)
f2 = dpois(y, lam=lambda2)
- if(residuals) stop("loglikelihood residuals not implemented yet") else
+ if (residuals) stop("loglikelihood residuals not implemented yet") else
sum(w * log(phi*f1 + (1-phi)*f2))
}, list(.lphi=lphi, .llambda=llambda,
.ephi=ephi, .el1=el1, .el2=el2 ))),
@@ -343,7 +343,7 @@ mix2poisson = function(lphi="logit", llambda="loge",
temp3[,iam(2,3,M=3)] = d2l.dlambda1lambda2
run.mean = ((ii-1) * run.mean + temp3) / ii
}
- wz = if(intercept.only)
+ wz = if (intercept.only)
matrix(colMeans(run.mean), n, dimm(M), byrow=TRUE) else run.mean
dtheta.detas = cbind(dphi.deta, dlambda1.deta, dlambda2.deta)
@@ -368,22 +368,22 @@ mix2exp = function(lphi="logit", llambda="loge",
iphi=0.5, il1=NULL, il2=NULL,
qmu=c(0.8, 0.2), nsimEIM=100, zero=1)
{
- if(mode(lphi) != "character" && mode(lphi) != "name")
+ if (mode(lphi) != "character" && mode(lphi) != "name")
lphi = as.character(substitute(lphi))
- if(mode(llambda) != "character" && mode(llambda) != "name")
+ if (mode(llambda) != "character" && mode(llambda) != "name")
llambda = as.character(substitute(llambda))
- if(!is.Numeric(qmu, allow=2, positive=TRUE) || any(qmu >= 1))
+ if (!is.Numeric(qmu, allow=2, positive=TRUE) || any(qmu >= 1))
stop("bad input for argument 'qmu'")
- if(length(iphi) && (!is.Numeric(iphi, allow=1, positive=TRUE) || iphi>= 1))
+ if (length(iphi) && (!is.Numeric(iphi, allow=1, positive=TRUE) || iphi>= 1))
stop("bad input for argument 'iphi'")
- if(length(il1) && !is.Numeric(il1))
+ if (length(il1) && !is.Numeric(il1))
stop("bad input for argument 'il1'")
- if(length(il2) && !is.Numeric(il2))
+ if (length(il2) && !is.Numeric(il2))
stop("bad input for argument 'il2'")
- if(!is.list(ephi)) ephi = list()
- if(!is.list(el1)) el1 = list()
- if(!is.list(el2)) el2 = list()
- if(!is.Numeric(nsimEIM, allow=1, integ=TRUE) || nsimEIM <= 10)
+ if (!is.list(ephi)) ephi = list()
+ if (!is.list(el1)) el1 = list()
+ if (!is.list(el2)) el2 = list()
+ if (!is.Numeric(nsimEIM, allow=1, integ=TRUE) || nsimEIM <= 10)
stop("'nsimEIM' should be an integer greater than 10")
new("vglmff",
@@ -397,17 +397,17 @@ mix2exp = function(lphi="logit", llambda="loge",
constraints = cm.zero.vgam(constraints, x, .zero, M)
}), list(.zero=zero ))),
initialize=eval(substitute(expression({
- if(ncol(y <- cbind(y)) != 1)
+ if (ncol(y <- cbind(y)) != 1)
stop("the response must be a vector or one-column matrix")
predictors.names = c(namesof("phi", .lphi, earg= .ephi, tag=FALSE),
namesof("lambda1", .llambda, earg= .el1,tag=FALSE),
namesof("lambda2", .llambda, earg= .el2,tag=FALSE))
- if(!length(etastart)) {
+ if (!length(etastart)) {
qy = quantile(y, prob= .qmu)
init.phi = rep(if(length(.iphi)) .iphi else 0.5, length=n)
init.lambda1 = rep(if(length(.il1)) .il1 else 1/qy[1], length=n)
init.lambda2 = rep(if(length(.il2)) .il2 else 1/qy[2], length=n)
- if(!length(etastart))
+ if (!length(etastart))
etastart = cbind(theta2eta(init.phi, .lphi, earg= .ephi),
theta2eta(init.lambda1, .llambda, earg= .el1),
theta2eta(init.lambda2, .llambda, earg= .el2))
@@ -436,7 +436,7 @@ mix2exp = function(lphi="logit", llambda="loge",
lambda2 = eta2theta(eta[,3], link= .llambda, earg= .el2)
f1 = dexp(y, rate=lambda1)
f2 = dexp(y, rate=lambda2)
- if(residuals) stop("loglikelihood residuals not implemented yet") else
+ if (residuals) stop("loglikelihood residuals not implemented yet") else
sum(w * log(phi*f1 + (1-phi)*f2))
}, list(.lphi=lphi, .llambda=llambda,
.ephi=ephi, .el1=el1, .el2=el2 ))),
@@ -494,7 +494,7 @@ mix2exp = function(lphi="logit", llambda="loge",
temp3[,iam(2,3,M=3)] = d2l.dlambda1lambda2
run.mean = ((ii-1) * run.mean + temp3) / ii
}
- wz = if(intercept.only)
+ wz = if (intercept.only)
matrix(colMeans(run.mean), n, dimm(M), byrow=TRUE) else run.mean
dtheta.detas = cbind(dphi.deta, dlambda1.deta, dlambda2.deta)
diff --git a/R/family.nonlinear.q b/R/family.nonlinear.R
similarity index 86%
rename from R/family.nonlinear.q
rename to R/family.nonlinear.R
index 24b5e5e..0d1d4c5 100644
--- a/R/family.nonlinear.q
+++ b/R/family.nonlinear.R
@@ -1,5 +1,5 @@
# These functions are
-# Copyright (C) 1998-2009 T.W. Yee, University of Auckland. All rights reserved.
+# Copyright (C) 1998-2010 T.W. Yee, University of Auckland. All rights reserved.
@@ -29,12 +29,12 @@ micmen <- function(rpar=0.001, divisor=10,
estimated.dispersion <- dispersion==0
- if(mode(link1) != "character" && mode(link1) != "name")
+ if (mode(link1) != "character" && mode(link1) != "name")
link1 <- as.character(substitute(link1))
- if(mode(link2) != "character" && mode(link2) != "name")
+ if (mode(link2) != "character" && mode(link2) != "name")
link2 <- as.character(substitute(link2))
- if(!is.list(earg1)) earg1 = list()
- if(!is.list(earg2)) earg2 = list()
+ if (!is.list(earg1)) earg1 = list()
+ if (!is.list(earg2)) earg2 = list()
new("vglmff",
blurb=c("Michaelis-Menton regression model\n",
@@ -48,19 +48,19 @@ micmen <- function(rpar=0.001, divisor=10,
constraints <- cm.zero.vgam(constraints, x, .zero, M=2)
}), list(.zero=zero))),
deviance=function(mu, y, w, residuals=FALSE, eta, extra=NULL) {
- M <- if(is.matrix(y)) ncol(y) else 1
- if(residuals) {
- if(M>1) NULL else (y-mu) * sqrt(w)
+ M <- if (is.matrix(y)) ncol(y) else 1
+ if (residuals) {
+ if (M>1) NULL else (y-mu) * sqrt(w)
} else
rss.vgam(y-mu, w, M=M)
},
initialize=eval(substitute(expression({
- if(ncol(cbind(y)) != 1)
+ if (ncol(cbind(y)) != 1)
stop("response must be a vector or a one-column matrix")
- if(!length(Xm2))
+ if (!length(Xm2))
stop("regressor not found")
- if(ncol(as.matrix(Xm2)) != 1)
+ if (ncol(as.matrix(Xm2)) != 1)
stop("regressor not found or is not a vector. Use the ",
"'form2' argument without an intercept")
Xm2 = as.vector(Xm2) # Make sure
@@ -70,15 +70,15 @@ micmen <- function(rpar=0.001, divisor=10,
c(namesof("theta1", .link1, earg= .earg1, tag=FALSE),
namesof("theta2", .link2, earg= .earg2, tag=FALSE))
- if(length(mustart) || length(coefstart))
+ if (length(mustart) || length(coefstart))
stop("cannot handle mustart or coefstart")
- if(!length(etastart)) {
+ if (!length(etastart)) {
index <- (1:n)[Xm2>quantile(Xm2, prob=.85)]
init1 <- median(y[index])
init2 <- median(init1*Xm2/y - Xm2)
- if(length(.init1)) init1 = .init1
- if(length(.init2)) init2 = .init2
+ if (length(.init1)) init1 = .init1
+ if (length(.init2)) init2 = .init2
etastart = cbind(
rep(theta2eta(init1, .link1, earg= .earg1), len=n),
@@ -105,7 +105,7 @@ micmen <- function(rpar=0.001, divisor=10,
extra$Xm2 = NULL # Regressor is in control$regressor
dpar <- .dispersion
- if(!dpar) {
+ if (!dpar) {
dpar <- sum(w * (y-mu)^2) / (n - ncol_X_vlm)
}
misc$dispersion <- dpar
@@ -117,7 +117,7 @@ micmen <- function(rpar=0.001, divisor=10,
summary.dispersion=FALSE,
vfamily=c("micmen","vnonlinear"),
deriv=eval(substitute(expression({
- if(iter>1) {
+ if (iter>1) {
rpar = max(rpar / .divisor, 1000 * .Machine$double.eps)
} else {
rpar = .rpar
@@ -128,7 +128,7 @@ micmen <- function(rpar=0.001, divisor=10,
theta1 <- eta2theta(eta[,1], .link1, earg= .earg1)
theta2 <- eta2theta(eta[,2], .link2, earg= .earg2)
- if(TRUE) {
+ if (TRUE) {
dmus.dthetas = attr(eval(d3), "gradient")
} else {
dmu.dtheta1 <- Xm2 / (theta2 + Xm2)
@@ -139,10 +139,10 @@ micmen <- function(rpar=0.001, divisor=10,
dthetas.detas = cbind(dtheta.deta(theta1, .link1, earg= .earg1),
dtheta.deta(theta2, .link2, earg= .earg2))
- if(TRUE) {
+ if (TRUE) {
index = iam(NA, NA, M=M, both=TRUE)
temp200809 = dmus.dthetas * dthetas.detas
- if(M>1)
+ if (M>1)
temp200809[,2:M] = temp200809[,2:M] + sqrt(rpar)
w * (y-mu) * temp200809
} else {
@@ -154,10 +154,10 @@ micmen <- function(rpar=0.001, divisor=10,
.earg1=earg1, .earg2=earg2,
.divisor=divisor))),
weight=eval(substitute(expression({
- if(TRUE) {
+ if (TRUE) {
wz = dmus.dthetas[,index$row] * dmus.dthetas[,index$col] *
dthetas.detas[,index$row] * dthetas.detas[,index$col]
- if(M>1)
+ if (M > 1)
wz[,2:M] = wz[,2:M] + rpar
} else {
wz = cbind((dmus.dthetas[,1] * dthetas.detas[,1])^2,
@@ -166,7 +166,7 @@ micmen <- function(rpar=0.001, divisor=10,
dthetas.detas[,1] * dthetas.detas[,2])
}
w * wz
- }), list(.link1=link1, .link2=link2))))
+ }), list( .link1=link1, .link2=link2 ))))
}
diff --git a/R/family.normal.q b/R/family.normal.R
similarity index 83%
rename from R/family.normal.q
rename to R/family.normal.R
index b71ed66..aab25b1 100644
--- a/R/family.normal.q
+++ b/R/family.normal.R
@@ -1,18 +1,18 @@
# These functions are
-# Copyright (C) 1998-2009 T.W. Yee, University of Auckland. All rights reserved.
+# Copyright (C) 1998-2010 T.W. Yee, University of Auckland. All rights reserved.
VGAM.weights.function = function(w, M, n) {
ncolw = ncol(as.matrix(w))
- if(ncolw == 1) {
+ if (ncolw == 1) {
wz = matrix(w, nrow=n, ncol=M) # w_i * diag(M)
- } else if(ncolw == M) {
+ } else if (ncolw == M) {
wz = as.matrix(w)
- } else if(ncolw < M && M > 1) {
+ } else if (ncolw < M && M > 1) {
stop("ambiguous input for weights")
- } else if(ncolw > M*(M+1)/2) {
+ } else if (ncolw > M*(M+1)/2) {
stop("too many columns")
} else {
wz = as.matrix(w)
@@ -29,7 +29,7 @@ VGAM.weights.function = function(w, M, n) {
gaussianff = function(dispersion=0, parallel=FALSE, zero=NULL)
{
- if(!is.Numeric(dispersion, allow=1) || dispersion < 0)
+ if (!is.Numeric(dispersion, allow=1) || dispersion < 0)
stop("bad input for argument 'dispersion'")
estimated.dispersion = dispersion==0
@@ -41,11 +41,11 @@ VGAM.weights.function = function(w, M, n) {
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)
+ 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)
- if(residuals) {
- if(M > 1) {
+ if (residuals) {
+ if (M > 1) {
U <- vchol(wz, M=M, n=n)
temp = mux22(U, y-mu, M=M, upper=TRUE, as.matrix=TRUE)
dimnames(temp) = dimnames(y)
@@ -55,27 +55,27 @@ VGAM.weights.function = function(w, M, n) {
rss.vgam(y-mu, wz=wz, M=M)
},
initialize=eval(substitute(expression({
- if(is.R())
+ if (is.R())
assign("CQO.FastAlgorithm", TRUE, envir = VGAMenv) else
CQO.FastAlgorithm <<- TRUE
- if(any(function.name == c("cqo","cao")) &&
+ if (any(function.name == c("cqo","cao")) &&
(length( .zero ) || (is.logical( .parallel ) && .parallel )))
stop("cannot handle non-default arguments for cqo() and cao()")
- M = if(is.matrix(y)) ncol(y) else 1
+ M = if (is.matrix(y)) ncol(y) else 1
dy = dimnames(y)
- predictors.names = if(!is.null(dy[[2]])) dy[[2]] else
+ predictors.names = if (!is.null(dy[[2]])) dy[[2]] else
paste("Y",1:M,sep="")
- if(!length(etastart))
+ if (!length(etastart))
etastart = 0 * y
}), list( .parallel=parallel, .zero=zero ))),
inverse=function(eta, extra=NULL) eta,
last=eval(substitute(expression({
dy = dimnames(y)
- if(!is.null(dy[[2]]))
+ if (!is.null(dy[[2]]))
dimnames(fit$fitted.values) = dy
dpar = .dispersion
- if(!dpar) {
+ if (!dpar) {
wz = VGAM.weights.function(w=w, M=M, n=n)
temp = rss.vgam(y-mu, wz=wz, M=M)
dpar = temp / (length(y) -
@@ -87,8 +87,8 @@ VGAM.weights.function = function(w, M, n) {
misc$link = rep("identity", length=M)
names(misc$link) = predictors.names
- if(is.R()) {
- if(exists("CQO.FastAlgorithm", envir = VGAMenv))
+ if (is.R()) {
+ if (exists("CQO.FastAlgorithm", envir = VGAMenv))
rm("CQO.FastAlgorithm", envir = VGAMenv)
} else {
while(exists("CQO.FastAlgorithm"))
@@ -97,8 +97,8 @@ VGAM.weights.function = function(w, M, n) {
}), list( .dispersion=dispersion,
.estimated.dispersion=estimated.dispersion ))),
loglikelihood= 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)
+ 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)
temp = rss.vgam(y-mu, wz=wz, M=M)
-0.5 * temp
@@ -123,12 +123,12 @@ VGAM.weights.function = function(w, M, n) {
dposnorm = function(x, mean=0, sd=1, log=FALSE) {
log.arg = log
rm(log)
- if(!is.logical(log.arg) || length(log.arg)!=1)
+ 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);
- if(log.arg) {
+ if (log.arg) {
ifelse(x < 0, log(0), dnorm(x, m=mean, sd=sd, log=TRUE) -
pnorm(mean/sd, log=TRUE))
} else {
@@ -144,13 +144,13 @@ pposnorm = function(q, mean=0, sd=1) {
}
qposnorm = function(p, mean=0, sd=1) {
- if(!is.Numeric(p, posit=TRUE) || max(p) >= 1)
+ if (!is.Numeric(p, posit=TRUE) || max(p) >= 1)
stop("bad input for argument 'p'")
qnorm(p=p+(1-p)*pnorm(0, mean=mean, sd=sd), mean=mean, sd=sd)
}
rposnorm = function(n, mean=0, sd=1) {
- if(!is.Numeric(n, integ=TRUE, posit=TRUE))
+ if (!is.Numeric(n, integ=TRUE, posit=TRUE))
stop("bad input for argument 'n'")
mean = rep(mean, length=n)
sd = rep(sd, length=n)
@@ -173,18 +173,18 @@ rposnorm = function(n, mean=0, sd=1) {
{
warning("this VGAM family function is not working properly yet")
- if(mode(lmean) != "character" && mode(lmean) != "name")
+ if (mode(lmean) != "character" && mode(lmean) != "name")
lmean = as.character(substitute(lmean))
- if(mode(lsd) != "character" && mode(lsd) != "name")
+ if (mode(lsd) != "character" && mode(lsd) != "name")
lsd = as.character(substitute(lsd))
- if(length(zero) && !is.Numeric(zero, integer=TRUE, posit=TRUE))
+ if (length(zero) && !is.Numeric(zero, integer=TRUE, posit=TRUE))
stop("bad input for argument 'zero'")
- if(length(isd) && !is.Numeric(isd, posit=TRUE))
+ if (length(isd) && !is.Numeric(isd, posit=TRUE))
stop("bad input for argument 'isd'")
- if(!is.list(emean)) emean = list()
- if(!is.list(esd)) esd = list()
- if(length(nsimEIM))
- if(!is.Numeric(nsimEIM, allow=1, integ=TRUE) || nsimEIM <= 10)
+ if (!is.list(emean)) emean = list()
+ if (!is.list(esd)) esd = list()
+ if (length(nsimEIM))
+ if (!is.Numeric(nsimEIM, allow=1, integ=TRUE) || nsimEIM <= 10)
stop("'nsimEIM' should be an integer greater than 10")
new("vglmff",
@@ -196,17 +196,17 @@ rposnorm = function(n, mean=0, sd=1) {
constraints = cm.zero.vgam(constraints, x, .zero, M)
}), list( .zero=zero ))),
initialize=eval(substitute(expression({
- if(ncol(y <- cbind(y)) != 1)
+ if (ncol(y <- cbind(y)) != 1)
stop("response must be a vector or a one-column matrix")
- if(min(y) <= 0)
+ if (min(y) <= 0)
stop("response must be positive")
predictors.names = c(namesof("mean", .lmean, earg= .emean, tag= FALSE),
namesof("sd", .lsd, earg= .esd, tag= FALSE))
- if(!length(etastart)) {
- init.me = if(length( .imean)) rep( .imean, len=n) else NULL
- init.sd = if(length( .isd )) rep( .isd , len=n) else NULL
- if(!length(init.me)) init.me = rep(quantile(y, probs=0.40), len=n)
- if(!length(init.sd)) init.sd = rep(sd(y)*1.2, len=n)
+ if (!length(etastart)) {
+ init.me = if (length( .imean)) rep( .imean, len=n) else NULL
+ init.sd = if (length( .isd )) rep( .isd , len=n) else NULL
+ if (!length(init.me)) init.me = rep(quantile(y, probs=0.40), len=n)
+ if (!length(init.sd)) init.sd = rep(sd(y)*1.2, len=n)
etastart = cbind(theta2eta(init.me, .lmean, earg= .emean),
theta2eta(init.sd, .lsd, earg= .esd))
}
@@ -228,7 +228,7 @@ rposnorm = function(n, mean=0, sd=1) {
function(mu,y,w,residuals= FALSE,eta, extra=NULL) {
mymu = eta2theta(eta[,1], .lmean, earg= .emean)
mysd = eta2theta(eta[,2], .lsd, earg= .esd)
- if(residuals) stop("loglikelihood residuals not implemented yet") else {
+ if (residuals) stop("loglikelihood residuals not implemented yet") else {
sum(w * dposnorm(x=y, m=mymu, sd=mysd, log=TRUE))
}
@@ -250,7 +250,7 @@ rposnorm = function(n, mean=0, sd=1) {
weight=eval(substitute(expression({
run.varcov = 0
ind1 = iam(NA, NA, M=M, both=TRUE, diag=TRUE)
- if(length( .nsimEIM )) {
+ if (length( .nsimEIM )) {
for(ii in 1:( .nsimEIM )) {
ysim <- rposnorm(n, m=mymu, sd=mysd)
zedd = (ysim-mymu) / mysd
@@ -264,7 +264,7 @@ rposnorm = function(n, mean=0, sd=1) {
run.varcov = ((ii-1) * run.varcov +
temp3[,ind1$row.index]*temp3[,ind1$col.index]) / ii
}
- wz = if(intercept.only)
+ wz = if (intercept.only)
matrix(colMeans(run.varcov),
n, ncol(run.varcov), byrow=TRUE) else run.varcov
@@ -289,13 +289,14 @@ rposnorm = function(n, mean=0, sd=1) {
+
dbetanorm = function(x, shape1, shape2, mean=0, sd=1, log=FALSE) {
log.arg = log
rm(log)
- if(!is.logical(log.arg) || length(log.arg)!=1)
+ if (!is.logical(log.arg) || length(log.arg)!=1)
stop("bad input for argument 'log'")
ans =
- if(is.R() && log.arg) {
+ if (is.R() && log.arg) {
dnorm(x=x, mean=mean, sd=sd, log=TRUE) +
(shape1-1) * pnorm(q=x, mean=mean, sd=sd, log=TRUE) +
(shape2-1) * pnorm(q=x, mean=mean, sd=sd, lower=FALSE, log=TRUE) -
@@ -305,24 +306,27 @@ dbetanorm = function(x, shape1, shape2, mean=0, sd=1, log=FALSE) {
pnorm(q=x, mean=mean, sd=sd)^(shape1-1) *
pnorm(q=x, mean=mean, sd=sd, lower=FALSE)^(shape2-1) / beta(shape1, shape2)
}
- if(!is.R() && log.arg) ans = log(ans)
+ if (!is.R() && log.arg) ans = log(ans)
ans
}
+
pbetanorm = function(q, shape1, shape2, mean=0, sd=1,
lower.tail=TRUE, log.p=FALSE) {
pbeta(q=pnorm(q=q, mean=mean, sd=sd), shape1=shape1, shape2=shape2,
lower.tail = lower.tail, log.p = log.p)
}
+
qbetanorm = function(p, shape1, shape2, mean=0, sd=1) {
- if(!is.Numeric(p, posit=TRUE) || max(p) >= 1)
+ if (!is.Numeric(p, posit=TRUE) || max(p) >= 1)
stop("bad input for argument 'p'")
qnorm(p=qbeta(p=p, shape1=shape1, shape2=shape2), mean=mean, sd=sd)
}
+
rbetanorm = function(n, shape1, shape2, mean=0, sd=1) {
- if(!is.Numeric(n, integ=TRUE, posit=TRUE))
+ if (!is.Numeric(n, integ=TRUE, posit=TRUE))
stop("bad input for argument 'n'")
qnorm(p=qbeta(p=runif(n), shape1=shape1, shape2=shape2), mean=mean, sd=sd)
}
@@ -331,17 +335,17 @@ 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))
+ if (!is.logical(log.arg <- log))
stop("bad input for argument 'log'")
rm(log)
- if(!is.Numeric(d, allow=1) || max(d) >= 2)
+ if (!is.Numeric(d, allow=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) {
+ if (log.arg) {
dnorm(x=x, mean=mean, sd=sigma, log=TRUE) + log(KK) +
2 * log1p(((x-mean)/sigma)^2 / (2*hh))
} else {
@@ -352,7 +356,7 @@ dtikuv = function(x, d, mean=0, sigma=1, log = FALSE) {
ptikuv = function(q, d, mean=0, sigma=1) {
- if(!is.Numeric(d, allow=1) || max(d) >= 2)
+ if (!is.Numeric(d, allow=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);
@@ -360,13 +364,13 @@ ptikuv = function(q, d, mean=0, sigma=1) {
ans = q*0 + 0.5
hh = 2 - d
KK = 1 / (1 + 1/hh + 0.75/hh^2)
- if(any(lhs <- q < mean)) {
+ 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)) {
+ if (any(rhs <- q > mean)) {
ans[rhs] = 1.0 - Recall(q=(2*mean[rhs]-q[rhs]), d=d,
mean=mean[rhs], sigma=sigma[rhs])
}
@@ -375,13 +379,13 @@ ptikuv = function(q, d, mean=0, sigma=1) {
qtikuv = function(p, d, mean=0, sigma=1, ...) {
- if(!is.Numeric(p, posit=TRUE) || max(p) >= 1)
+ if (!is.Numeric(p, posit=TRUE) || max(p) >= 1)
stop("bad input for argument 'p'")
- if(!is.Numeric(d, allow=1) || max(d) >= 2)
+ if (!is.Numeric(d, allow=1) || max(d) >= 2)
stop("bad input for argument 'd'")
- if(!is.Numeric(mean))
+ if (!is.Numeric(mean))
stop("bad input for argument 'mean'")
- if(!is.Numeric(sigma))
+ 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);
@@ -403,15 +407,15 @@ qtikuv = function(p, d, mean=0, sigma=1, ...) {
rtikuv = function(n, d, mean=0, sigma=1, Smallno=1.0e-6) {
- if(!is.Numeric(n, posit=TRUE, integ=TRUE))
+ if (!is.Numeric(n, posit=TRUE, integ=TRUE))
stop("bad input for argument 'n'")
- if(!is.Numeric(d, allow=1) || max(d) >= 2)
+ if (!is.Numeric(d, allow=1) || max(d) >= 2)
stop("bad input for argument 'd'")
- if(!is.Numeric(mean, allow=1))
+ if (!is.Numeric(mean, allow=1))
stop("bad input for argument 'mean'")
- if(!is.Numeric(sigma, allow=1))
+ if (!is.Numeric(sigma, allow=1))
stop("bad input for argument 'sigma'")
- if(!is.Numeric(Smallno, posit=TRUE, allow=1) || Smallno > 0.01 ||
+ if (!is.Numeric(Smallno, posit=TRUE, allow=1) || Smallno > 0.01 ||
Smallno < 2 * .Machine$double.eps)
stop("bad input for argument 'Smallno'")
ans = rep(0.0, len=n)
@@ -432,7 +436,7 @@ rtikuv = function(n, d, mean=0, sigma=1, Smallno=1.0e-6) {
x = runif(2*n, min=Lower, max=Upper)
index = runif(2*n, max=ymax) < dtikuv(x,d=d,m=mean,s=sigma)
sindex = sum(index)
- if(sindex) {
+ if (sindex) {
ptr2 = min(n, ptr1 + sindex - 1)
ans[ptr1:ptr2] = (x[index])[1:(1+ptr2-ptr1)]
ptr1 = ptr2 + 1
@@ -448,17 +452,17 @@ rtikuv = function(n, d, mean=0, sigma=1, Smallno=1.0e-6) {
emean=list(), esigma=list(),
isigma=NULL, zero=2)
{
- if(mode(lmean) != "character" && mode(lmean) != "name")
+ if (mode(lmean) != "character" && mode(lmean) != "name")
lmean = as.character(substitute(lmean))
- if(mode(lsigma) != "character" && mode(lsigma) != "name")
+ if (mode(lsigma) != "character" && mode(lsigma) != "name")
lsigma = as.character(substitute(lsigma))
- if(length(zero) && (!is.Numeric(zero, integer=TRUE, posit=TRUE) ||
+ if (length(zero) && (!is.Numeric(zero, integer=TRUE, posit=TRUE) ||
max(zero) > 2))
stop("bad input for argument 'zero'")
- if(!is.Numeric(d, allow=1) || max(d) >= 2)
+ if (!is.Numeric(d, allow=1) || max(d) >= 2)
stop("bad input for argument 'd'")
- if(!is.list(emean)) emean = list()
- if(!is.list(esigma)) esigma = list()
+ 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",
@@ -472,13 +476,13 @@ rtikuv = function(n, d, mean=0, sigma=1, Smallno=1.0e-6) {
constraints = cm.zero.vgam(constraints, x, .zero, M)
}), list( .zero=zero ))),
initialize=eval(substitute(expression({
- if(ncol(cbind(y)) != 1)
+ 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 {
+ 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)
@@ -505,7 +509,7 @@ rtikuv = function(n, d, mean=0, sigma=1, Smallno=1.0e-6) {
function(mu,y,w,residuals= FALSE,eta, extra=NULL) {
mymu = eta2theta(eta[,1], .lmean, earg= .emean)
sigma = eta2theta(eta[,2], .lsigma, earg= .esigma)
- if(residuals) stop("loglikelihood residuals not implemented yet") else {
+ if (residuals) stop("loglikelihood residuals not implemented yet") else {
sum(w * dtikuv(x=y, d= .d, mean=mymu, sigma=sigma, log = TRUE))
}
}, list( .lmean=lmean, .lsigma=lsigma, .d=d,
@@ -541,9 +545,9 @@ 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, posit=TRUE) || !is.Numeric(a2, posit=TRUE))
+ if (!is.Numeric(a1, posit=TRUE) || !is.Numeric(a2, posit=TRUE))
stop("bad input for arguments 'a1' and 'a2'")
- if(any(a1 <= 0 | a2 <= 0))
+ 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)
@@ -553,9 +557,9 @@ dfnorm = function(x, mean=0, sd=1, a1=1, a2=1) {
}
pfnorm = function(q, mean=0, sd=1, a1=1, a2=1) {
- if(!is.Numeric(a1, posit=TRUE) || !is.Numeric(a2, posit=TRUE))
+ if (!is.Numeric(a1, posit=TRUE) || !is.Numeric(a2, posit=TRUE))
stop("bad input for arguments 'a1' and 'a2'")
- if(any(a1 <= 0 | a2 <= 0))
+ 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);
@@ -563,11 +567,11 @@ pfnorm = function(q, mean=0, sd=1, a1=1, a2=1) {
}
qfnorm = function(p, mean=0, sd=1, a1=1, a2=1, ...) {
- if(!is.Numeric(p, posit=TRUE) || max(p) >= 1)
+ if (!is.Numeric(p, posit=TRUE) || max(p) >= 1)
stop("bad input for argument 'p'")
- if(!is.Numeric(a1, posit=TRUE) || !is.Numeric(a2, posit=TRUE))
+ if (!is.Numeric(a1, posit=TRUE) || !is.Numeric(a2, posit=TRUE))
stop("bad input for arguments 'a1' and 'a2'")
- if(any(a1 <= 0 | a2 <= 0))
+ 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))
@@ -590,11 +594,11 @@ qfnorm = function(p, mean=0, sd=1, a1=1, a2=1, ...) {
}
rfnorm = function(n, mean=0, sd=1, a1=1, a2=1) {
- if(!is.Numeric(n, integ=TRUE, posit=TRUE))
+ if (!is.Numeric(n, integ=TRUE, posit=TRUE))
stop("bad input for argument 'n'")
- if(!is.Numeric(a1, posit=TRUE) || !is.Numeric(a2, posit=TRUE))
+ if (!is.Numeric(a1, posit=TRUE) || !is.Numeric(a2, posit=TRUE))
stop("bad input for arguments 'a1' and 'a2'")
- if(any(a1 <= 0 | a2 <= 0))
+ 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)
@@ -605,28 +609,28 @@ rfnorm = function(n, mean=0, sd=1, a1=1, a2=1) {
imean=NULL, isd=NULL, a1=1, a2=1, nsimEIM=500,
method.init=1, zero=NULL)
{
- if(!is.Numeric(a1, posit=TRUE, allow=1) ||
+ if (!is.Numeric(a1, posit=TRUE, allow=1) ||
!is.Numeric(a2, posit=TRUE, allow=1))
stop("bad input for arguments 'a1' and 'a2'")
- if(any(a1 <= 0 | a2 <= 0))
+ if (any(a1 <= 0 | a2 <= 0))
stop("arguments 'a1' and 'a2' must each be a positive value")
- if(!is.Numeric(method.init, allow=1, integ=TRUE, posit=TRUE) ||
+ if (!is.Numeric(method.init, allow=1, integ=TRUE, posit=TRUE) ||
method.init > 2)
stop("'method.init' must be 1 or 2")
- if(mode(lmean) != "character" && mode(lmean) != "name")
+ if (mode(lmean) != "character" && mode(lmean) != "name")
lmean = as.character(substitute(lmean))
- if(mode(lsd) != "character" && mode(lsd) != "name")
+ if (mode(lsd) != "character" && mode(lsd) != "name")
lsd = as.character(substitute(lsd))
- if(length(zero) && !is.Numeric(zero, integer=TRUE, posit=TRUE))
+ if (length(zero) && !is.Numeric(zero, integer=TRUE, posit=TRUE))
stop("bad input for argument 'zero'")
- if(!is.list(emean)) emean = list()
- if(!is.list(esd)) esd = list()
- if(!is.Numeric(nsimEIM, allow=1, integ=TRUE) || nsimEIM <= 10)
+ if (!is.list(emean)) emean = list()
+ if (!is.list(esd)) esd = list()
+ if (!is.Numeric(nsimEIM, allow=1, integ=TRUE) || nsimEIM <= 10)
stop("'nsimEIM' should be an integer greater than 10")
- if(length(imean) && !is.Numeric(imean))
+ if (length(imean) && !is.Numeric(imean))
stop("bad input for 'imean'")
- if(length(isd) && !is.Numeric(isd, posit=TRUE))
+ if (length(isd) && !is.Numeric(isd, posit=TRUE))
stop("bad input for 'isd'")
new("vglmff",
@@ -637,15 +641,15 @@ rfnorm = function(n, mean=0, sd=1, a1=1, a2=1) {
initialize=eval(substitute(expression({
predictors.names = c(namesof("mean", .lmean, earg=.emean, tag=FALSE),
namesof("sd", .lsd, earg=.esd, tag=FALSE))
- if((ncol(y <- cbind(y)) != 1) || any(y <= 0))
+ if ((ncol(y <- cbind(y)) != 1) || any(y <= 0))
stop("response must be a vector or a one-column matrix with positive values")
- if(!length(etastart)) {
- junk = if(is.R()) lm.wfit(x=x, y=y, w=w) else
+ 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")
-if(FALSE) {
- if((ncol(cbind(w)) != 1) || any(w != round(w)))
+ if (FALSE) {
+ if ((ncol(cbind(w)) != 1) || any(w != round(w)))
stop("'weights' must be a vector or a one-column matrix with integer values")
m1d = meany = weighted.mean(y, w)
m2d = weighted.mean(y^2, w)
@@ -695,7 +699,7 @@ if(FALSE) {
mysd = eta2theta(eta[,2], .lsd, earg= .esd)
a1vec = .a1
a2vec = .a2
- if(residuals) stop("loglikelihood residuals not implemented yet") else {
+ if (residuals) stop("loglikelihood residuals not implemented yet") else {
sum(w*log(dnorm(x=y/(a1vec*mysd) - mymu/mysd)/(a1vec*mysd) +
dnorm(x=y/(a2vec*mysd) + mymu/mysd)/(a2vec*mysd)))
}
@@ -736,7 +740,7 @@ if(FALSE) {
run.mean = ((ii-1) * run.mean + temp3) / ii
}
- wz = if(intercept.only)
+ wz = if (intercept.only)
matrix(colMeans(run.mean), n, dimm(M), byrow=TRUE) else run.mean
index0 = iam(NA, NA, M=M, both=TRUE, diag=TRUE)
@@ -758,15 +762,15 @@ lqnorm.control = function(trace=TRUE, ...)
lqnorm = function(qpower=2, link="identity", earg=list(),
method.init=1, imu=NULL, shrinkage.init=0.95)
{
- if(mode(link) != "character" && mode(link) != "name")
+ if (mode(link) != "character" && mode(link) != "name")
link = as.character(substitute(link))
- if(!is.list(earg)) eerg = list()
- if(!is.Numeric(qpower, allow=1) || qpower <= 1)
+ if (!is.list(earg)) eerg = list()
+ if (!is.Numeric(qpower, allow=1) || qpower <= 1)
stop("bad input for argument 'qpower'")
- if(!is.Numeric(method.init, allow=1, integ=TRUE, posit=TRUE) ||
+ if (!is.Numeric(method.init, allow=1, integ=TRUE, posit=TRUE) ||
method.init > 3)
stop("'method.init' must be 1 or 2 or 3")
- if(!is.Numeric(shrinkage.init, allow=1) || shrinkage.init < 0 ||
+ if (!is.Numeric(shrinkage.init, allow=1) || shrinkage.init < 0 ||
shrinkage.init > 1) stop("bad input for argument 'shrinkage.init'")
new("vglmff",
@@ -774,19 +778,19 @@ lqnorm = function(qpower=2, link="identity", earg=list(),
"Links: ",
namesof("Y1", link, earg=earg, tag= TRUE)),
initialize=eval(substitute(expression({
- M = if(is.matrix(y)) ncol(y) else 1
- if(M != 1)
+ M = if (is.matrix(y)) ncol(y) else 1
+ if (M != 1)
stop("response must be a vector or a one-column matrix")
dy = dimnames(y)
- predictors.names = if(!is.null(dy[[2]])) dy[[2]] else
+ predictors.names = if (!is.null(dy[[2]])) dy[[2]] else
paste("mu", 1:M, sep="")
predictors.names = namesof(predictors.names, link= .link,
earg= .earg, short=TRUE)
- if(!length(etastart)) {
+ if (!length(etastart)) {
meany = weighted.mean(y, w)
mean.init = rep(if(length( .imu)) .imu else
{if( .method.init == 2) median(y) else
- if( .method.init == 1) meany else
+ if ( .method.init == 1) meany else
.sinit * meany + (1 - .sinit) * y
}, len=n)
etastart = theta2eta(mean.init, link= .link, earg= .earg)
@@ -799,7 +803,7 @@ lqnorm = function(qpower=2, link="identity", earg=list(),
}, list( .link=link, .earg=earg ))),
last=eval(substitute(expression({
dy = dimnames(y)
- if(!is.null(dy[[2]]))
+ if (!is.null(dy[[2]]))
dimnames(fit$fitted.values) = dy
misc$link = rep( .link, length=M)
names(misc$link) = predictors.names
diff --git a/R/family.positive.q b/R/family.positive.R
similarity index 86%
rename from R/family.positive.q
rename to R/family.positive.R
index 8a91a3d..d9d22e2 100644
--- a/R/family.positive.q
+++ b/R/family.positive.R
@@ -1,5 +1,5 @@
# These functions are
-# Copyright (C) 1998-2009 T.W. Yee, University of Auckland. All rights reserved.
+# Copyright (C) 1998-2010 T.W. Yee, University of Auckland. All rights reserved.
@@ -13,7 +13,7 @@ dposnegbin = function(x, size, prob=NULL, munb=NULL, log=FALSE) {
stop("'prob' and 'munb' both specified")
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))
@@ -22,7 +22,7 @@ dposnegbin = function(x, size, prob=NULL, munb=NULL, log=FALSE) {
ans = dnbinom(x=x, size=size, prob=prob, log=log.arg)
index0 = x==0
- if(log.arg) {
+ if (log.arg) {
ans[ index0] = log(0.0)
ans[!index0] = ans[!index0] - log1p(-dnbinom(x=0 * x[!index0],
size=size[!index0], prob=prob[!index0]))
@@ -56,7 +56,7 @@ qposnegbin = function(p, size, prob=NULL, munb=NULL) {
stop("'prob' and 'munb' both specified")
prob <- size/(size + munb)
}
- if(!is.Numeric(p, posit=TRUE) || any(p >= 1))
+ if (!is.Numeric(p, posit=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)
@@ -64,8 +64,8 @@ qposnegbin = function(p, size, prob=NULL, munb=NULL) {
rposnegbin = function(n, size, prob=NULL, munb=NULL) {
- use.n = if((length.n <- length(n)) > 1) length.n else
- if(!is.Numeric(n, integ=TRUE, allow=1, posit=TRUE))
+ use.n = if ((length.n <- length(n)) > 1) length.n else
+ if (!is.Numeric(n, integ=TRUE, allow=1, posit=TRUE))
stop("bad input for argument 'n'") else n
if (length(munb)) {
@@ -96,21 +96,21 @@ rposnegbin = function(n, size, prob=NULL, munb=NULL) {
ik = NULL, zero = -2, cutoff = 0.995,
shrinkage.init=0.95, method.init=1)
{
- if(!is.Numeric(cutoff, allow=1) || cutoff<0.8 || cutoff>=1)
+ if (!is.Numeric(cutoff, allow=1) || cutoff<0.8 || cutoff>=1)
stop("range error in the argument 'cutoff'")
- if(!is.Numeric(method.init, allow=1, integ=TRUE, posit=TRUE) ||
+ if (!is.Numeric(method.init, allow=1, integ=TRUE, posit=TRUE) ||
method.init > 2) stop("argument 'method.init' must be 1 or 2")
- if(length(ik) && !is.Numeric(ik, posit=TRUE))
+ if (length(ik) && !is.Numeric(ik, posit=TRUE))
stop("bad input for argument 'ik'")
- if(!is.Numeric(shrinkage.init, allow=1) || shrinkage.init < 0 ||
+ if (!is.Numeric(shrinkage.init, allow=1) || shrinkage.init < 0 ||
shrinkage.init > 1) stop("bad input for argument 'shrinkage.init'")
- if(mode(lmunb) != "character" && mode(lmunb) != "name")
+ if (mode(lmunb) != "character" && mode(lmunb) != "name")
lmunb = as.character(substitute(lmunb))
- if(mode(lk) != "character" && mode(lk) != "name")
+ if (mode(lk) != "character" && mode(lk) != "name")
lk = as.character(substitute(lk))
- if(!is.list(emunb)) emunb = list()
- if(!is.list(ek)) ek = list()
+ if (!is.list(emunb)) emunb = list()
+ if (!is.list(ek)) ek = list()
new("vglmff",
blurb=c("Positive-negative binomial distribution\n\n",
@@ -120,12 +120,12 @@ rposnegbin = function(n, size, prob=NULL, munb=NULL) {
"Mean: munb / (1 - (k/(k+munb))^k)"),
constraints=eval(substitute(expression({
temp752 = .zero
- if(length(temp752) && all(temp752 == -2))
+ if (length(temp752) && all(temp752 == -2))
temp752 = 2*(1:ncol(y))
constraints = cm.zero.vgam(constraints, x, temp752, M)
}), list( .zero=zero ))),
initialize=eval(substitute(expression({
- if(any(y==0)) stop("there are zero values in the response")
+ if (any(y==0)) stop("there are zero values in the response")
y = as.matrix(y)
M = 2 * ncol(y)
extra$NOS = NOS = ncoly = ncol(y) # Number of species
@@ -135,10 +135,10 @@ rposnegbin = function(n, size, prob=NULL, munb=NULL) {
namesof(if(NOS==1) "k" else paste("k", 1:NOS, sep=""),
.lk, earg= .ek, tag= FALSE))
predictors.names = predictors.names[interleave.VGAM(M, M=2)]
- if(!length(etastart)) {
+ if (!length(etastart)) {
mu.init = y
for(iii in 1:ncol(y)) {
- use.this = if( .method.init == 2) {
+ use.this = if ( .method.init == 2) {
weighted.mean(y[,iii], w)
} else {
median(y[,iii])
@@ -146,7 +146,7 @@ rposnegbin = function(n, size, prob=NULL, munb=NULL) {
mu.init[,iii] = (1- .sinit) * y[,iii] + .sinit * use.this
}
- if( is.Numeric( .ik )) {
+ if ( is.Numeric( .ik )) {
kmat0 = matrix( .ik, nr=n, nc=NOS, byrow=TRUE)
} else {
posnegbinomial.Loglikfun =
@@ -183,7 +183,7 @@ rposnegbin = function(n, size, prob=NULL, munb=NULL) {
last=eval(substitute(expression({
temp0303 = c(rep( .lmunb, length=NOS), rep( .lk, length=NOS))
names(temp0303) = c(if(NOS==1) "munb" else paste("munb", 1:NOS, sep=""),
- if(NOS==1) "k" else paste("k", 1:NOS, sep=""))
+ if (NOS==1) "k" else paste("k", 1:NOS, sep=""))
temp0303 = temp0303[interleave.VGAM(M, M=2)]
misc$link = temp0303 # Already named
misc$earg = vector("list", 2*NOS)
@@ -202,7 +202,7 @@ rposnegbin = function(n, size, prob=NULL, munb=NULL) {
NOS = ncol(eta) / 2
munb = eta2theta(eta[,2*(1:NOS)-1,drop=FALSE], .lmunb, earg= .emunb )
kmat = eta2theta(eta[,2*(1:NOS),drop=FALSE], .lk, earg= .ek )
- if(residuals) stop("loglikelihood residuals not implemented yet") else {
+ if (residuals) stop("loglikelihood residuals not implemented yet") else {
sum(w * dposnegbin(x=y, size=kmat, munb=munb, log=TRUE))
}
@@ -250,7 +250,7 @@ rposnegbin = function(n, size, prob=NULL, munb=NULL) {
as.double(.cutoff),
as.integer(n), ok=as.integer(1), as.integer(NOS),
sumpdf=double(1), macheps=as.double(.Machine$double.eps))
- if(fred$ok != 1)
+ if (fred$ok != 1)
stop("error in Fortran subroutine exnbin")
dim(fred$ans) = c(n, NOS)
ed2l.dk2 = -fred$ans/(1-p0) - 1/kmat + 1/(kmat+munb) -
@@ -267,14 +267,14 @@ rposnegbin = function(n, size, prob=NULL, munb=NULL) {
dpospois = function(x, lambda, log=FALSE) {
- if(!is.logical(log.arg <- log)) stop("bad input for 'log'")
+ if (!is.logical(log.arg <- log)) stop("bad input for 'log'")
rm(log)
- if(!is.Numeric(lambda, posit=TRUE))
+ if (!is.Numeric(lambda, posit=TRUE))
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) {
+ ans = if (log.arg) {
ifelse(x==0, log(0.0), dpois(x, lambda, log=TRUE) - log1p(-exp(-lambda)))
} else {
ifelse(x==0, 0, -dpois(x, lambda) / expm1(-lambda))
@@ -284,7 +284,7 @@ dpospois = function(x, lambda, log=FALSE) {
ppospois = function(q, lambda) {
- if(!is.Numeric(lambda, posit=TRUE))
+ if (!is.Numeric(lambda, posit=TRUE))
stop("bad input for argument 'lambda'")
L = max(length(q), length(lambda))
q = rep(q, len=L); lambda = rep(lambda, len=L);
@@ -292,20 +292,20 @@ ppospois = function(q, lambda) {
}
qpospois = function(p, lambda) {
- if(!is.Numeric(lambda, posit=TRUE))
+ if (!is.Numeric(lambda, posit=TRUE))
stop("bad input for argument 'lambda'")
- if(!is.Numeric(p, posit=TRUE) || any(p >= 1))
+ if (!is.Numeric(p, posit=TRUE) || any(p >= 1))
stop("bad input for argument 'p'")
qpois(p * (-expm1(-lambda)) + exp(-lambda), lambda)
}
rpospois = function(n, lambda) {
- use.n = if((length.n <- length(n)) > 1) length.n else
- if(!is.Numeric(n, integ=TRUE, allow=1, posit=TRUE))
+ use.n = if ((length.n <- length(n)) > 1) length.n else
+ if (!is.Numeric(n, integ=TRUE, allow=1, posit=TRUE))
stop("bad input for argument 'n'") else n
- if(any(lambda == 0))
+ if (any(lambda == 0))
stop("no zero values allowed for argument 'lambda'")
ans = rpois(use.n, lambda)
lambda = rep(lambda, len=use.n)
@@ -324,14 +324,14 @@ rpospois = function(n, lambda) {
pospoisson = function(link="loge", earg=list(), expected=TRUE,
ilambda=NULL, method.init=1)
{
- if(!missing(link))
+ if (!missing(link))
link = as.character(substitute(link))
- if(!is.list(earg)) earg = list()
- if(!is.logical(expected) || length(expected) != 1)
+ if (!is.list(earg)) earg = list()
+ if (!is.logical(expected) || length(expected) != 1)
stop("bad input for argument 'expected'")
- if(length( ilambda) && !is.Numeric(ilambda, posit=TRUE))
+ if (length( ilambda) && !is.Numeric(ilambda, posit=TRUE))
stop("bad input for argument 'ilambda'")
- if(!is.Numeric(method.init, allow=1, integ=TRUE, posit=TRUE) ||
+ if (!is.Numeric(method.init, allow=1, integ=TRUE, posit=TRUE) ||
method.init > 3) stop("argument 'method.init' must be 1 or 2 or 3")
new("vglmff",
@@ -341,26 +341,26 @@ rpospois = function(n, lambda) {
"\n"),
initialize=eval(substitute(expression({
y = as.matrix(y)
- if(any(y < 1))
+ if (any(y < 1))
stop("all y values must be in 1,2,3,...")
- if(any(y != round(y )))
+ if (any(y != round(y )))
stop("the response must be integer-valued")
predictors.names = namesof(if(ncol(y)==1) "lambda"
else paste("lambda", 1:ncol(y), sep=""), .link,
earg= .earg, tag=FALSE)
- if( .method.init == 1) {
+ if ( .method.init == 1) {
lambda.init = apply(y, 2, median) + 1/8
lambda.init = matrix(lambda.init, n, ncol(y), byrow=TRUE)
- } else if( .method.init == 2) {
+ } else if ( .method.init == 2) {
lambda.init = apply(y, 2, weighted.mean, w=w) + 1/8
lambda.init = matrix(lambda.init, n, ncol(y), byrow=TRUE)
} else {
lambda.init = -y / expm1(-y)
}
- if(length( .ilambda))
+ if (length( .ilambda))
lambda.init = lambda.init*0 + .ilambda
- if(!length(etastart))
+ if (!length(etastart))
etastart = theta2eta(lambda.init, .link, earg= .earg)
}), list( .link=link, .earg= earg,
.ilambda=ilambda, .method.init=method.init ))),
@@ -371,7 +371,7 @@ rpospois = function(n, lambda) {
last=eval(substitute(expression({
misc$expected = .expected
misc$link = rep( .link, len=M)
- names(misc$link) = if(M==1) "lambda" else paste("lambda", 1:M, sep="")
+ names(misc$link) = if (M==1) "lambda" else paste("lambda", 1:M, sep="")
misc$earg = vector("list", M)
names(misc$earg) = names(misc$link)
for(ii in 1:M)
@@ -380,7 +380,7 @@ rpospois = function(n, lambda) {
loglikelihood=eval(substitute(
function(mu,y,w,residuals=FALSE, eta,extra=NULL) {
lambda = eta2theta(eta, .link, earg= .earg )
- if(residuals) stop("loglikelihood residuals not implemented yet") else {
+ if (residuals) stop("loglikelihood residuals not implemented yet") else {
sum(w * dpospois(x=y, lambda=lambda, log=TRUE))
}
}, list( .link=link, .earg= earg ))),
@@ -393,7 +393,7 @@ rpospois = function(n, lambda) {
w * dl.dlambda * dlambda.deta
}), list( .link=link, .earg= earg ))),
weight=eval(substitute(expression({
- if( .expected ) {
+ if ( .expected ) {
ed2l.dlambda2 = temp * (1/lambda - 1/(temp-1)) / (temp-1)
wz = (dlambda.deta^2) * ed2l.dlambda2
} else {
@@ -410,9 +410,9 @@ rpospois = function(n, lambda) {
posbinomial = function(link="logit", earg=list()) {
- if(!missing(link))
+ if (!missing(link))
link = as.character(substitute(link))
- if(!is.list(earg)) earg = list()
+ if (!is.list(earg)) earg = list()
new("vglmff",
blurb=c("Positive-Binomial distribution\n\n",
@@ -421,13 +421,13 @@ rpospois = function(n, lambda) {
initialize=eval(substitute(expression({
eval(binomialff(link= .link)@initialize)
yint = round(y*w)
- if(max(abs(yint - y*w)) > 0.0001)
+ if (max(abs(yint - y*w)) > 0.0001)
warning("rounding y*w to an integer")
- if(any(y <= 0))
+ if (any(y <= 0))
stop("the response must only contain positive values")
predictors.names = namesof("p", .link, earg= .earg , tag=FALSE)
if(length(extra)) extra$w = w else extra = list(w=w)
- if(!length(etastart))
+ if (!length(etastart))
etastart = cbind(theta2eta(mustart, .link, earg= .earg ))
}), list( .link = link, .earg=earg ))),
inverse=eval(substitute(function(eta, extra=NULL) {
@@ -444,11 +444,11 @@ rpospois = function(n, lambda) {
function(mu,y,w,residuals=FALSE,eta,extra=NULL) {
yint = round(y*w)
mymu = eta2theta(eta, .link, earg= .earg )
- if(max(abs(w - round(w))) > 0.0001) {
+ if (max(abs(w - round(w))) > 0.0001) {
warning("rounding w to an integer")
w = round(w)
}
- if(residuals) stop("loglikelihood residuals not implemented yet") else {
+ if (residuals) stop("loglikelihood residuals not implemented yet") else {
sum(w * dposbinom(x=yint, size=w, prob=mymu, log=TRUE))
}
}, list( .link=link, .earg=earg ))),
@@ -486,7 +486,7 @@ dposbinom = function(x, size, prob, log = FALSE) {
answer = dbinom(x=x, size=size, prob=prob, log=TRUE) -
log1p(-dbinom(x=0*x, size=size, prob=prob))
answer[!ok2] = NaN
- if(log.arg) {
+ if (log.arg) {
answer[is0 & ok2] = log(0.0)
} else {
answer = exp(answer)
@@ -496,7 +496,7 @@ dposbinom = function(x, size, prob, log = FALSE) {
}
pposbinom = function(q, size, prob, lower.tail = TRUE, log.p = FALSE) {
- if(!is.Numeric(prob, positive=TRUE))
+ 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);
@@ -505,20 +505,20 @@ pposbinom = function(q, size, prob, lower.tail = TRUE, log.p = FALSE) {
}
qposbinom = function(p, size, prob, lower.tail = TRUE, log.p = FALSE) {
- if(!is.Numeric(prob, positive=TRUE))
+ if (!is.Numeric(prob, positive=TRUE))
stop("no zero or non-numeric values allowed for argument 'prob'")
- if(!is.Numeric(p, posit=TRUE) || any(p >= 1))
+ if (!is.Numeric(p, posit=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)
}
rposbinom = function(n, size, prob) {
- use.n = if((length.n <- length(n)) > 1) length.n else
- if(!is.Numeric(n, integ=TRUE, allow=1, posit=TRUE))
+ use.n = if ((length.n <- length(n)) > 1) length.n else
+ if (!is.Numeric(n, integ=TRUE, allow=1, posit=TRUE))
stop("bad input for argument 'n'") else n
- if(any(prob == 0))
+ if (any(prob == 0))
stop("no zero values allowed for argument 'prob'")
ans = rbinom(n=use.n, size=size, prob=prob)
index = (ans == 0)
diff --git a/R/family.qreg.q b/R/family.qreg.R
similarity index 87%
rename from R/family.qreg.q
rename to R/family.qreg.R
index 4d3f0de..7a02894 100644
--- a/R/family.qreg.q
+++ b/R/family.qreg.R
@@ -1,5 +1,5 @@
# These functions are
-# Copyright (C) 1998-2009 T.W. Yee, University of Auckland. All rights reserved.
+# Copyright (C) 1998-2010 T.W. Yee, University of Auckland. All rights reserved.
@@ -31,18 +31,18 @@ lms.bcn <- function(percentiles=c(25,50,75),
ilambda=1,
isigma=NULL)
{
- if(mode(llambda) != "character" && mode(llambda) != "name")
+ if (mode(llambda) != "character" && mode(llambda) != "name")
llambda = as.character(substitute(llambda))
- if(mode(lmu) != "character" && mode(lmu) != "name")
+ if (mode(lmu) != "character" && mode(lmu) != "name")
lmu = as.character(substitute(lmu))
- if(mode(lsigma) != "character" && mode(lsigma) != "name")
+ if (mode(lsigma) != "character" && mode(lsigma) != "name")
lsigma = as.character(substitute(lsigma))
- if(!is.list(elambda)) elambda = list()
- if(!is.list(emu)) emu = list()
- if(!is.list(esigma)) esigma = list()
- if(!is.Numeric(ilambda))
+ if (!is.list(elambda)) elambda = list()
+ if (!is.list(emu)) emu = list()
+ if (!is.list(esigma)) esigma = list()
+ if (!is.Numeric(ilambda))
stop("bad input for argument 'ilambda'")
- if(length(isigma) && !is.Numeric(isigma, posit=TRUE))
+ if (length(isigma) && !is.Numeric(isigma, posit=TRUE))
stop("bad input for argument 'isigma'")
new("vglmff",
@@ -56,9 +56,9 @@ lms.bcn <- function(percentiles=c(25,50,75),
constraints = cm.zero.vgam(constraints, x, .zero, M)
}), list(.zero=zero))),
initialize=eval(substitute(expression({
- if(ncol(cbind(y)) != 1)
+ if (ncol(cbind(y)) != 1)
stop("response must be a vector or a one-column matrix")
- if(any(y<0, na.rm = TRUE))
+ if (any(y<0, na.rm = TRUE))
stop("negative responses not allowed")
predictors.names =
@@ -66,15 +66,15 @@ lms.bcn <- function(percentiles=c(25,50,75),
namesof("mu", .lmu, earg= .emu, short= TRUE),
namesof("sigma", .lsigma, earg= .esigma, short= TRUE))
- if(!length(etastart)) {
+ if (!length(etastart)) {
fit500=vsmooth.spline(x=x[,min(ncol(x),2)],y=y,w=w, df= .dfmu.init)
fv.init = c(predict(fit500, x=x[,min(ncol(x),2)])$y)
- lambda.init = if(is.Numeric( .ilambda)) .ilambda else 1.0
- sigma.init = if(is.null(.isigma)) {
+ 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)) {
+ 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)))
@@ -104,7 +104,7 @@ lms.bcn <- function(percentiles=c(25,50,75),
misc$links = c(lambda = .llambda, mu = .lmu, sigma = .lsigma)
misc$earg = list(lambda = .elambda, mu = .emu, sigma = .esigma)
misc$true.mu = FALSE # $fitted is not a true mu
- if(control$cdf) {
+ if (control$cdf) {
post$cdf = cdf.lms.bcn(y, eta0=matrix(c(lambda,mymu,sigma),
ncol=3, dimnames=list(dimnames(x)[[1]], NULL)))
}
@@ -117,7 +117,7 @@ lms.bcn <- function(percentiles=c(25,50,75),
mu = eta2theta(eta[,2], .lmu, earg= .emu)
sigma = eta2theta(eta[,3], .lsigma, earg= .esigma)
z = ((y/mu)^lambda - 1) / (lambda * sigma)
- if(residuals) stop("loglikelihood residuals not implemented yet") else
+ if (residuals) stop("loglikelihood residuals not implemented yet") else
sum(w * (lambda * log(y/mu) - log(sigma) - 0.5*z^2))
}, list( .llambda=llambda, .lmu=lmu, .lsigma=lsigma,
.elambda=elambda, .emu=emu, .esigma=esigma ))),
@@ -165,18 +165,18 @@ lms.bcg = function(percentiles=c(25,50,75),
ilambda=1,
isigma=NULL)
{
- if(mode(llambda) != "character" && mode(llambda) != "name")
+ if (mode(llambda) != "character" && mode(llambda) != "name")
llambda = as.character(substitute(llambda))
- if(mode(lmu) != "character" && mode(lmu) != "name")
+ if (mode(lmu) != "character" && mode(lmu) != "name")
lmu = as.character(substitute(lmu))
- if(mode(lsigma) != "character" && mode(lsigma) != "name")
+ if (mode(lsigma) != "character" && mode(lsigma) != "name")
lsigma = as.character(substitute(lsigma))
- if(!is.list(elambda)) elambda = list()
- if(!is.list(emu)) emu = list()
- if(!is.list(esigma)) esigma = list()
- if(!is.Numeric(ilambda))
+ if (!is.list(elambda)) elambda = list()
+ if (!is.list(emu)) emu = list()
+ if (!is.list(esigma)) esigma = list()
+ if (!is.Numeric(ilambda))
stop("bad input for argument 'ilambda'")
- if(length(isigma) && !is.Numeric(isigma, posit=TRUE))
+ if (length(isigma) && !is.Numeric(isigma, posit=TRUE))
stop("bad input for argument 'isigma'")
new("vglmff",
@@ -190,9 +190,9 @@ lms.bcg = function(percentiles=c(25,50,75),
constraints = cm.zero.vgam(constraints, x, .zero, M)
}), list(.zero=zero))),
initialize=eval(substitute(expression({
- if(ncol(cbind(y)) != 1)
+ if (ncol(cbind(y)) != 1)
stop("response must be a vector or a one-column matrix")
- if(any(y<0, na.rm = TRUE))
+ if (any(y<0, na.rm = TRUE))
stop("negative responses not allowed")
predictors.names = c(
@@ -200,16 +200,16 @@ lms.bcg = function(percentiles=c(25,50,75),
namesof("mu", .lmu, earg= .emu, short=TRUE),
namesof("sigma", .lsigma, earg= .esigma, short=TRUE))
- if(!length(etastart)) {
+ if (!length(etastart)) {
fit500=vsmooth.spline(x=x[,min(ncol(x),2)],y=y,w=w, df= .dfmu.init)
fv.init = c(predict(fit500, 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)) {
+ 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)) {
+ 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)
@@ -240,7 +240,7 @@ lms.bcg = function(percentiles=c(25,50,75),
misc$link = c(lambda = .llambda, mu = .lmu, sigma = .lsigma)
misc$earg = list(lambda = .elambda, mu = .emu, sigma = .esigma)
misc$true.mu = FALSE # $fitted is not a true mu
- if(control$cdf) {
+ if (control$cdf) {
post$cdf = cdf.lms.bcg(y, eta0=matrix(c(lambda,mymu,sigma),
ncol=3, dimnames=list(dimnames(x)[[1]], NULL)))
}
@@ -254,7 +254,7 @@ lms.bcg = function(percentiles=c(25,50,75),
sigma = eta2theta(eta[,3], .lsigma, earg= .esigma)
g = (y/mu)^lambda
theta = 1 / (sigma * lambda)^2
- if(residuals) stop("loglikelihood residuals not implemented yet") else
+ if (residuals) stop("loglikelihood residuals not implemented yet") else
sum(w * (log(abs(lambda)) + theta*(log(theta)+log(g)-g) -
lgamma(theta) - log(y)))
}, list( .llambda=llambda, .lmu=lmu, .lsigma=lsigma,
@@ -285,7 +285,7 @@ lms.bcg = function(percentiles=c(25,50,75),
tritheta = trigamma(theta)
wz = matrix(0, n, 6)
- if(TRUE) {
+ if (TRUE) {
part2 = dd + 2/theta - 2*log(theta)
wz[,iam(1,1,M)] = ((1 + theta*(tritheta*(1+4*theta) -
4*(1+1/theta) - log(theta)*(2/theta -
@@ -328,51 +328,51 @@ yeo.johnson = function(y, lambda, derivative=0,
epsilon=sqrt(.Machine$double.eps), inverse= FALSE)
{
- if(!is.Numeric(derivative, allow=1, integ=TRUE) || derivative<0)
+ if (!is.Numeric(derivative, allow=1, integ=TRUE) || derivative<0)
stop("'derivative' must be a non-negative integer")
ans = y
- if(!is.Numeric(epsilon, allow=1, posit=TRUE))
+ if (!is.Numeric(epsilon, allow=1, posit=TRUE))
stop("'epsilon' must be a single positive number")
L = max(length(lambda), length(y))
- if(length(y) != L) y = rep(y, len=L)
- if(length(lambda) != L) lambda = rep(lambda, len=L) # lambda may be of length 1
+ if (length(y) != L) y = rep(y, len=L)
+ if (length(lambda) != L) lambda = rep(lambda, len=L) # lambda may be of length 1
- if(inverse) {
- if(derivative!=0)
+ if (inverse) {
+ if (derivative!=0)
stop("derivative must 0 when inverse=TRUE")
- if(any(index <- y >= 0 & abs(lambda) > epsilon))
+ if (any(index <- y >= 0 & abs(lambda) > epsilon))
ans[index] = (y[index]*lambda[index] + 1)^(1/lambda[index]) - 1
- if(any(index <- y >= 0 & abs(lambda) <= epsilon))
+ if (any(index <- y >= 0 & abs(lambda) <= epsilon))
ans[index] = expm1(y[index])
- if(any(index <- y < 0 & abs(lambda-2) > epsilon))
+ if (any(index <- y < 0 & abs(lambda-2) > epsilon))
ans[index] = 1-(-(2-lambda[index])*y[index]+1)^(1/(2-lambda[index]))
- if(any(index <- y < 0 & abs(lambda-2) <= epsilon))
+ 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))
+ if (derivative==0) {
+ if (any(index <- y >= 0 & abs(lambda) > epsilon))
ans[index] = ((y[index]+1)^(lambda[index]) - 1) / lambda[index]
- if(any(index <- y >= 0 & abs(lambda) <= epsilon))
+ if (any(index <- y >= 0 & abs(lambda) <= epsilon))
ans[index] = log1p(y[index])
- if(any(index <- y < 0 & abs(lambda-2) > epsilon))
+ if (any(index <- y < 0 & abs(lambda-2) > epsilon))
ans[index] = -((-y[index]+1)^(2-lambda[index])-1)/(2-lambda[index])
- if(any(index <- y < 0 & abs(lambda-2) <= epsilon))
+ if (any(index <- y < 0 & abs(lambda-2) <= epsilon))
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))
+ if (any(index <- y >= 0 & abs(lambda) > epsilon))
ans[index] = ( (y[index]+1)^(lambda[index]) *
(log1p(y[index]))^(derivative) - derivative *
psi[index] ) / lambda[index]
- if(any(index <- y >= 0 & abs(lambda) <= epsilon))
+ if (any(index <- y >= 0 & abs(lambda) <= epsilon))
ans[index] = (log1p(y[index]))^(derivative + 1) / (derivative + 1)
- if(any(index <- y < 0 & abs(lambda-2) > epsilon))
+ 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])
- if(any(index <- y < 0 & abs(lambda-2) <= epsilon))
+ if (any(index <- y < 0 & abs(lambda-2) <= epsilon))
ans[index] = (-log1p(-y[index]))^(derivative + 1) / (derivative + 1)
}
ans
@@ -382,22 +382,22 @@ yeo.johnson = function(y, lambda, derivative=0,
dpsi.dlambda.yjn = function(psi, lambda, mymu, sigma,
derivative=0, smallno=1.0e-8) {
- if(!is.Numeric(derivative, allow=1, integ=TRUE) || derivative<0)
+ if (!is.Numeric(derivative, allow=1, integ=TRUE) || derivative<0)
stop("'derivative' must be a non-negative integer")
- if(!is.Numeric(smallno, allow=1, posit=TRUE))
+ if (!is.Numeric(smallno, allow=1, posit=TRUE))
stop("'smallno' must be a single positive number")
L = max(length(psi), length(lambda), length(mymu), length(sigma))
- if(length(psi) != L) psi = rep(psi, len=L)
- if(length(lambda) != L) lambda = rep(lambda, len=L)
- if(length(mymu) != L) mymu = rep(mymu, len=L)
- if(length(sigma) != L) sigma = rep(sigma, len=L)
+ if (length(psi) != L) psi = rep(psi, len=L)
+ if (length(lambda) != L) lambda = rep(lambda, len=L)
+ if (length(mymu) != L) mymu = rep(mymu, len=L)
+ if (length(sigma) != L) sigma = rep(sigma, len=L)
answer = matrix(as.numeric(NA), L, derivative+1)
CC = psi >= 0
BB = ifelse(CC, lambda, -2+lambda)
AA = psi * BB
- temp8 = if(derivative > 0) {
+ temp8 = if (derivative > 0) {
answer[,1:derivative] =
Recall(psi=psi, lambda=lambda, mymu=mymu, sigma=sigma,
derivative=derivative-1, smallno=smallno)
@@ -408,7 +408,7 @@ dpsi.dlambda.yjn = function(psi, lambda, mymu, sigma,
answer[,1+derivative] = ((AA+1) * (log1p(AA)/BB)^derivative - temp8) / BB
pos = (CC & abs(lambda) <= smallno) | (!CC & abs(lambda-2) <= smallno)
- if(any(pos))
+ if (any(pos))
answer[pos,1+derivative] = (answer[pos,1]^(1+derivative))/(derivative+1)
answer
}
@@ -416,7 +416,7 @@ dpsi.dlambda.yjn = function(psi, lambda, mymu, sigma,
gh.weight.yjn.11 = function(z, lambda, mymu, sigma, derivmat=NULL) {
- if(length(derivmat)) {
+ if (length(derivmat)) {
((derivmat[,2]/sigma)^2 + sqrt(2) * z * derivmat[,3] / sigma) / sqrt(pi)
} else {
# Long-winded way
@@ -429,7 +429,7 @@ gh.weight.yjn.11 = function(z, lambda, mymu, sigma, derivmat=NULL) {
}
gh.weight.yjn.12 = function(z, lambda, mymu, sigma, derivmat=NULL) {
- if(length(derivmat)) {
+ if (length(derivmat)) {
(-derivmat[,2]) / (sqrt(pi) * sigma^2)
} else {
psi = mymu + sqrt(2) * sigma * z
@@ -439,7 +439,7 @@ gh.weight.yjn.12 = function(z, lambda, mymu, sigma, derivmat=NULL) {
}
gh.weight.yjn.13 = function(z, lambda, mymu, sigma, derivmat=NULL) {
- if(length(derivmat)) {
+ if (length(derivmat)) {
sqrt(8 / pi) * (-derivmat[,2]) * z / sigma^2
} else {
psi = mymu + sqrt(2) * sigma * z
@@ -453,7 +453,7 @@ gh.weight.yjn.13 = function(z, lambda, mymu, sigma, derivmat=NULL) {
glag.weight.yjn.11 = function(z, lambda, mymu, sigma, derivmat=NULL) {
- if(length(derivmat)) {
+ if (length(derivmat)) {
derivmat[,4] * (derivmat[,2]^2 + sqrt(2) * sigma * z * derivmat[,3])
} else {
psi = mymu + sqrt(2) * sigma * z
@@ -468,7 +468,7 @@ glag.weight.yjn.11 = function(z, lambda, mymu, sigma, derivmat=NULL) {
glag.weight.yjn.12 = function(z, lambda, mymu, sigma, derivmat=NULL) {
discontinuity = -mymu / (sqrt(2) * sigma)
- if(length(derivmat)) {
+ if (length(derivmat)) {
derivmat[,4] * (-derivmat[,2])
} else {
psi = mymu + sqrt(2) * sigma * z
@@ -479,7 +479,7 @@ glag.weight.yjn.12 = function(z, lambda, mymu, sigma, derivmat=NULL) {
}
glag.weight.yjn.13 = function(z, lambda, mymu, sigma, derivmat=NULL) {
- if(length(derivmat)) {
+ if (length(derivmat)) {
derivmat[,4] * (-derivmat[,2]) * sqrt(8) * z
} else {
psi = mymu + sqrt(2) * sigma * z
@@ -497,7 +497,7 @@ gleg.weight.yjn.11 = function(z, lambda, mymu, sigma, derivmat=NULL) {
- if(length(derivmat)) {
+ if (length(derivmat)) {
derivmat[,4] * (derivmat[,2]^2 + sqrt(2) * sigma * z * derivmat[,3])
} else {
psi = mymu + sqrt(2) * sigma * z
@@ -509,7 +509,7 @@ gleg.weight.yjn.11 = function(z, lambda, mymu, sigma, derivmat=NULL) {
}
gleg.weight.yjn.12 = function(z, lambda, mymu, sigma, derivmat=NULL) {
- if(length(derivmat)) {
+ if (length(derivmat)) {
derivmat[,4] * (- derivmat[,2])
} else {
psi = mymu + sqrt(2) * sigma * z
@@ -519,7 +519,7 @@ gleg.weight.yjn.12 = function(z, lambda, mymu, sigma, derivmat=NULL) {
}
gleg.weight.yjn.13 = function(z, lambda, mymu, sigma, derivmat=NULL) {
- if(length(derivmat)) {
+ if (length(derivmat)) {
derivmat[,4] * (-derivmat[,2]) * sqrt(8) * z
} else {
psi = mymu + sqrt(2) * sigma * z
@@ -550,18 +550,18 @@ lms.yjn2 = function(percentiles=c(25,50,75),
nsimEIM=250)
{
- if(mode(llambda) != "character" && mode(llambda) != "name")
+ if (mode(llambda) != "character" && mode(llambda) != "name")
llambda = as.character(substitute(llambda))
- if(mode(lmu) != "character" && mode(lmu) != "name")
+ if (mode(lmu) != "character" && mode(lmu) != "name")
lmu = as.character(substitute(lmu))
- if(mode(lsigma) != "character" && mode(lsigma) != "name")
+ if (mode(lsigma) != "character" && mode(lsigma) != "name")
lsigma = as.character(substitute(lsigma))
- if(!is.list(elambda)) elambda = list()
- if(!is.list(emu)) emu = list()
- if(!is.list(esigma)) esigma = list()
- if(!is.Numeric(ilambda))
+ if (!is.list(elambda)) elambda = list()
+ if (!is.list(emu)) emu = list()
+ if (!is.list(esigma)) esigma = list()
+ if (!is.Numeric(ilambda))
stop("bad input for argument 'ilambda'")
- if(length(isigma) && !is.Numeric(isigma, posit=TRUE))
+ if (length(isigma) && !is.Numeric(isigma, posit=TRUE))
stop("bad input for argument 'isigma'")
new("vglmff",
@@ -577,7 +577,7 @@ lms.yjn2 = function(percentiles=c(25,50,75),
constraints = cm.zero.vgam(constraints, x, .zero, M)
}), list(.zero=zero))),
initialize=eval(substitute(expression({
- if(ncol(cbind(y)) != 1)
+ if (ncol(cbind(y)) != 1)
stop("response must be a vector or a one-column matrix")
predictors.names =
c(namesof("lambda", .llambda, earg= .elambda, short= TRUE),
@@ -585,16 +585,16 @@ lms.yjn2 = function(percentiles=c(25,50,75),
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.
+ if (!length(etastart)) {
+ 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)) {
+ 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)
@@ -602,8 +602,8 @@ lms.yjn2 = function(percentiles=c(25,50,75),
rep(weighted.mean(y, w), len=n)
}
- sigma.init = if(!is.Numeric(.isigma)) {
- if(is.Numeric( .dfsigma.init) && smoothok) {
+ 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)
@@ -647,7 +647,7 @@ lms.yjn2 = function(percentiles=c(25,50,75),
y = y.save # Restore back the value; to be attached to object
- if(control$cdf) {
+ 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)))
@@ -662,7 +662,7 @@ lms.yjn2 = function(percentiles=c(25,50,75),
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
+ if (residuals) stop("loglikelihood residuals not implemented yet") else
sum(w * (-log(sigma) - 0.5 * ((psi-mu)/sigma)^2 +
(lambda-1) * sign(y) * log1p(abs(y))))
}, list( .elambda=elambda, .emu=emu, .esigma=esigma,
@@ -707,7 +707,7 @@ lms.yjn2 = function(percentiles=c(25,50,75),
temp3[,ind1$row.index]*temp3[,ind1$col.index]) / ii
}
- if(intercept.only)
+ if (intercept.only)
run.varcov = matrix(colMeans(run.varcov),
nr=n, nc=ncol(run.varcov), byrow=TRUE)
@@ -738,15 +738,15 @@ lms.yjn <- function(percentiles=c(25,50,75),
- if(mode(lsigma) != "character" && mode(lsigma) != "name")
+ if (mode(lsigma) != "character" && mode(lsigma) != "name")
lsigma = as.character(substitute(lsigma))
- if(mode(llambda) != "character" && mode(llambda) != "name")
+ if (mode(llambda) != "character" && mode(llambda) != "name")
llambda = as.character(substitute(llambda))
- if(!is.list(elambda)) elambda = list()
- if(!is.list(esigma)) esigma = list()
+ if (!is.list(elambda)) elambda = list()
+ if (!is.list(esigma)) esigma = list()
rule = rule[1] # Number of points (common) for all the quadrature schemes
- if(rule != 5 && rule != 10)
+ if (rule != 5 && rule != 10)
stop("only rule=5 or 10 is supported")
new("vglmff",
@@ -760,7 +760,7 @@ lms.yjn <- function(percentiles=c(25,50,75),
constraints = cm.zero.vgam(constraints, x, .zero, M)
}), list(.zero=zero))),
initialize=eval(substitute(expression({
- if(ncol(cbind(y)) != 1)
+ if (ncol(cbind(y)) != 1)
stop("response must be a vector or a one-column matrix")
predictors.names =
c(namesof("lambda", .llambda, earg= .elambda, short= TRUE),
@@ -768,16 +768,16 @@ lms.yjn <- function(percentiles=c(25,50,75),
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)) {
+ 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)
@@ -785,8 +785,8 @@ lms.yjn <- function(percentiles=c(25,50,75),
fv.init = rep(weighted.mean(y, w), len=n)
}
- sigma.init = if(!is.Numeric(.isigma)) {
- if(is.Numeric( .dfsigma.init) && smoothok) {
+ 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)
@@ -828,7 +828,7 @@ lms.yjn <- function(percentiles=c(25,50,75),
y = y.save # Restore back the value; to be attached to object
- if(control$cdf) {
+ 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)))
@@ -843,7 +843,7 @@ lms.yjn <- function(percentiles=c(25,50,75),
mu = eta[,2]
sigma = eta2theta(eta[,3], .lsigma, earg= .esigma)
psi = yeo.johnson(y, lambda)
- if(residuals) stop("loglikelihood residuals not implemented yet") else
+ if (residuals) stop("loglikelihood residuals not implemented yet") else
sum(w * (-log(sigma) - 0.5 * ((psi-mu)/sigma)^2 +
(lambda-1) * sign(y) * log1p(abs(y))))
}, list( .esigma=esigma, .elambda=elambda,
@@ -877,7 +877,7 @@ lms.yjn <- function(percentiles=c(25,50,75),
wz[,iam(3,3,M)] = 2 * wz[,iam(2,2,M)] # 2 / sigma^2
- if(.rule == 10) {
+ if (.rule == 10) {
glag.abs=c(0.13779347054,0.729454549503,1.80834290174,3.40143369785,
5.55249614006,8.33015274676,11.8437858379,16.2792578314,
21.996585812, 29.9206970123)
@@ -892,7 +892,7 @@ lms.yjn <- function(percentiles=c(25,50,75),
3.611758679927785e-03, 2.336997238583738e-05)
}
- if(.rule == 10) {
+ if (.rule == 10) {
sgh.abs = c(0.03873852801690856, 0.19823332465268367, 0.46520116404433082,
0.81686197962535023, 1.23454146277833154, 1.70679833036403172,
2.22994030591819214, 2.80910399394755972, 3.46387269067033854,
@@ -908,7 +908,7 @@ lms.yjn <- function(percentiles=c(25,50,75),
0.0332466603513424663, 0.0008248533445158026)
}
- if(.rule == 10) {
+ if (.rule == 10) {
gleg.abs = c(-0.973906528517, -0.865063366689, -0.679409568299,
-0.433395394129, -0.148874338982)
gleg.abs = c(gleg.abs, rev(-gleg.abs))
@@ -928,7 +928,7 @@ lms.yjn <- function(percentiles=c(25,50,75),
LL = pmin(discontinuity, 0)
UU = pmax(discontinuity, 0)
- if(FALSE) {
+ if (FALSE) {
AA = (UU-LL)/2
for(kk in 1:length(gleg.wts)) {
temp1 = AA * gleg.wts[kk]
@@ -991,7 +991,7 @@ lms.yjn <- function(percentiles=c(25,50,75),
wz[,iam(1,1,M)] = wz[,iam(1,1,M)] * dlambda.deta^2
wz[,iam(1,2,M)] = wz[,iam(1,2,M)] * dlambda.deta
wz[,iam(1,3,M)] = wz[,iam(1,3,M)] * dsigma.deta * dlambda.deta
- if( .diagW && iter <= .iters.diagW) {
+ if ( .diagW && iter <= .iters.diagW) {
wz[,iam(1,2,M)] = wz[,iam(1,3,M)] = 0
}
wz[,iam(2,3,M)] = wz[,iam(2,3,M)] * dsigma.deta
@@ -1012,7 +1012,7 @@ lms.yjn <- function(percentiles=c(25,50,75),
lmscreg.control <- function(cdf= TRUE, at.arg=NULL, x0=NULL, ...)
{
- if(!is.logical(cdf)) {
+ if (!is.logical(cdf)) {
warning("'cdf' is not logical; using TRUE instead")
cdf = TRUE
}
@@ -1031,42 +1031,42 @@ Wr2 <- function(r, w) (r <= 0) * 1 + (r > 0) * w
amlnormal.deviance = function(mu, y, w, residuals = FALSE, eta, extra=NULL) {
- M <- length(extra$w.als)
+ M <- length(extra$w.aml)
- if(M > 1) y = matrix(y,extra$n,extra$M)
+ if (M > 1) y = matrix(y,extra$n,extra$M)
devi = cbind((y - mu)^2)
- if(residuals) {
+ if (residuals) {
stop("not sure here")
wz = VGAM.weights.function(w = w, M = extra$M, n = extra$n)
- return((y - mu) * sqrt(wz) * matrix(extra$w.als,extra$n,extra$M))
+ return((y - mu) * sqrt(wz) * matrix(extra$w.aml,extra$n,extra$M))
} else {
all.deviances = numeric(M)
myresid = matrix(y,extra$n,extra$M) - cbind(mu)
for(ii in 1:M) all.deviances[ii] = sum(w * devi[,ii] *
- Wr1(myresid[,ii], w=extra$w.als[ii]))
+ Wr1(myresid[,ii], w=extra$w.aml[ii]))
}
- if(is.logical(extra$individual) && extra$individual)
+ if (is.logical(extra$individual) && extra$individual)
all.deviances else sum(all.deviances)
}
- amlnormal <- function(w.als=1, parallel=FALSE,
+ amlnormal <- function(w.aml=1, parallel=FALSE,
lexpectile = "identity", eexpectile = list(),
iexpectile = NULL,
method.init=1, digw=4)
{
- if(!is.Numeric(w.als, posit=TRUE))
- stop("'w.als' must be a vector of positive values")
- if(!is.Numeric(method.init, allow=1, integ=TRUE, posit=TRUE) ||
+ if (!is.Numeric(w.aml, posit=TRUE))
+ stop("'w.aml' must be a vector of positive values")
+ if (!is.Numeric(method.init, allow=1, integ=TRUE, posit=TRUE) ||
method.init > 3) stop("argument 'method.init' must be 1, 2 or 3")
- if(mode(lexpectile) != "character" && mode(lexpectile) != "name")
+ if (mode(lexpectile) != "character" && mode(lexpectile) != "name")
lexpectile = as.character(substitute(lexpectile))
- if(!is.list(eexpectile)) eexpectile = list()
- if(length(iexpectile) && !is.Numeric(iexpectile))
+ if (!is.list(eexpectile)) eexpectile = list()
+ if (length(iexpectile) && !is.Numeric(iexpectile))
stop("bad input for argument 'iexpectile'")
new("vglmff",
@@ -1081,34 +1081,34 @@ amlnormal.deviance = function(mu, y, w, residuals = FALSE, eta, extra=NULL) {
eta=eta, extra=extra)
},
initialize=eval(substitute(expression({
- extra$w.als = .w.als
- if(ncol(y <- cbind(y)) != 1)
+ extra$w.aml = .w.aml
+ if (ncol(y <- cbind(y)) != 1)
stop("response must be a vector or a one-column matrix")
- extra$M = M = length(extra$w.als) # Recycle if necessary
+ extra$M = M = length(extra$w.aml) # Recycle if necessary
extra$n = n
- extra$y.names = y.names = paste("w.als=", round(extra$w.als, dig=.digw),
+ extra$y.names = y.names = paste("w.aml=", round(extra$w.aml, dig=.digw),
sep="")
predictors.names = c(namesof(
paste("expectile(",y.names,")", sep=""), .lexpectile,
earg=.eexpectile, tag=FALSE))
- if(!length(etastart)) {
- mean.init = if( .method.init == 1)
+ if (!length(etastart)) {
+ mean.init = if ( .method.init == 1)
rep(median(y), length=n) else
- if( .method.init == 2)
+ if ( .method.init == 2)
rep(weighted.mean(y, w), length=n) else {
- junk = if(is.R()) lm.wfit(x=x, y=y, w=w) else
+ junk = if (is.R()) lm.wfit(x=x, y=y, w=w) else
lm.wfit(x=x, y=y, w=w, method="qr")
junk$fitted
}
- if(length( .iexpectile))
+ if (length( .iexpectile))
mean.init = matrix( .iexpectile, n, M, byrow=TRUE)
etastart = matrix(theta2eta(mean.init, .lexpectile,
earg= .eexpectile), n, M)
}
}), list( .lexpectile=lexpectile, .eexpectile=eexpectile,
.iexpectile=iexpectile,
- .method.init=method.init, .digw = digw, .w.als=w.als ))),
+ .method.init=method.init, .digw = digw, .w.aml=w.aml ))),
inverse=eval(substitute(function(eta, extra=NULL) {
ans = eta = as.matrix(eta)
for(ii in 1:ncol(eta))
@@ -1139,7 +1139,7 @@ amlnormal.deviance = function(mu, y, w, residuals = FALSE, eta, extra=NULL) {
mymu = eta2theta(eta, .lexpectile, earg= .eexpectile)
dexpectile.deta = dtheta.deta(mymu, .lexpectile, earg= .eexpectile)
myresid = matrix(y,extra$n,extra$M) - cbind(mu)
- wor1 = Wr2(myresid, w= matrix(extra$w.als, extra$n, extra$M,
+ wor1 = Wr2(myresid, w= matrix(extra$w.aml, extra$n, extra$M,
byrow=TRUE))
w * myresid * wor1 * dexpectile.deta
}), list( .lexpectile=lexpectile, .eexpectile=eexpectile ))),
@@ -1162,12 +1162,12 @@ amlpoisson.deviance = function(mu, y, w, residuals = FALSE, eta, extra=NULL) {
M <- length(extra$w.aml)
- if(M > 1) y = matrix(y,extra$n,extra$M)
+ if (M > 1) y = matrix(y,extra$n,extra$M)
nz <- y > 0
devi = cbind(-(y - mu))
devi[nz] = devi[nz] + y[nz] * log(y[nz]/mu[nz])
- if(residuals) {
+ if (residuals) {
stop("not sure here")
return(sign(y - mu) * sqrt(2 * abs(devi) * w) *
matrix(extra$w,extra$n,extra$M))
@@ -1177,7 +1177,7 @@ amlpoisson.deviance = function(mu, y, w, residuals = FALSE, eta, extra=NULL) {
for(ii in 1:M) all.deviances[ii] = 2 * sum(w * devi[,ii] *
Wr1(myresid[,ii], w=extra$w.aml[ii]))
}
- if(is.logical(extra$individual) && extra$individual)
+ if (is.logical(extra$individual) && extra$individual)
all.deviances else sum(all.deviances)
}
@@ -1185,11 +1185,11 @@ amlpoisson.deviance = function(mu, y, w, residuals = FALSE, eta, extra=NULL) {
amlpoisson <- function(w.aml=1, parallel=FALSE, method.init=1, digw=4,
link="loge", earg=list())
{
- if(!is.Numeric(w.aml, posit=TRUE))
+ if (!is.Numeric(w.aml, posit=TRUE))
stop("'w.aml' must be a vector of positive values")
- if(mode(link)!= "character" && mode(link)!= "name")
+ if (mode(link)!= "character" && mode(link)!= "name")
link = as.character(substitute(link))
- if(!is.list(earg)) earg = list()
+ if (!is.list(earg)) earg = list()
new("vglmff",
blurb=c("Poisson expectile regression by",
@@ -1204,7 +1204,7 @@ amlpoisson <- function(w.aml=1, parallel=FALSE, method.init=1, digw=4,
},
initialize=eval(substitute(expression({
extra$w.aml = .w.aml
- if(ncol(y <- cbind(y)) != 1)
+ if (ncol(y <- cbind(y)) != 1)
stop("response must be a vector or a one-column matrix")
extra$M = M = length(extra$w.aml) # Recycle if necessary
extra$n = n
@@ -1214,12 +1214,12 @@ amlpoisson <- function(w.aml=1, parallel=FALSE, method.init=1, digw=4,
predictors.names = c(namesof(paste("expectile(",y.names,")", sep=""),
.link, earg=.earg, tag=FALSE))
- if(!length(etastart)) {
- mean.init = if( .method.init == 2)
+ if (!length(etastart)) {
+ mean.init = if ( .method.init == 2)
rep(median(y), length=n) else
- if( .method.init == 1)
+ if ( .method.init == 1)
rep(weighted.mean(y, w), length=n) else {
- junk = if(is.R()) lm.wfit(x=x, y=y, w=w) else
+ junk = if (is.R()) lm.wfit(x=x, y=y, w=w) else
lm.wfit(x=x, y=y, w=w, method="qr")
abs(junk$fitted)
}
@@ -1280,7 +1280,7 @@ amlbinomial.deviance = function(mu, y, w, residuals = FALSE, eta, extra=NULL) {
M <- length(extra$w.aml)
- if(M > 1) y = matrix(y,extra$n,extra$M)
+ if (M > 1) y = matrix(y,extra$n,extra$M)
devy <- y
@@ -1289,7 +1289,7 @@ amlbinomial.deviance = function(mu, y, w, residuals = FALSE, eta, extra=NULL) {
nz <- (1 - y) != 0
devy[nz] <- devy[nz] + (1 - y[nz]) * log1p(-y[nz])
devmu <- y * log(mu) + (1 - y) * log1p(-mu)
- if(any(small <- mu * (1 - mu) < .Machine$double.eps)) {
+ if (any(small <- mu * (1 - mu) < .Machine$double.eps)) {
warning("fitted values close to 0 or 1")
smu <- mu[small]
sy <- y[small]
@@ -1299,7 +1299,7 @@ amlbinomial.deviance = function(mu, y, w, residuals = FALSE, eta, extra=NULL) {
devmu[small] <- sy * log(smu) + (1 - sy) * log(onemsmu)
}
devi <- 2 * (devy - devmu)
- if(residuals) {
+ if (residuals) {
stop("not sure here")
return(sign(y - mu) * sqrt(abs(devi) * w))
} else {
@@ -1308,7 +1308,7 @@ amlbinomial.deviance = function(mu, y, w, residuals = FALSE, eta, extra=NULL) {
for(ii in 1:M) all.deviances[ii] = sum(w * devi[,ii] *
Wr1(myresid[,ii], w=extra$w.aml[ii]))
}
- if(is.logical(extra$individual) && extra$individual)
+ if (is.logical(extra$individual) && extra$individual)
all.deviances else sum(all.deviances)
}
@@ -1316,11 +1316,11 @@ amlbinomial.deviance = function(mu, y, w, residuals = FALSE, eta, extra=NULL) {
amlbinomial <- function(w.aml=1, parallel=FALSE, digw=4,
link="logit", earg=list())
{
- if(!is.Numeric(w.aml, posit=TRUE))
+ if (!is.Numeric(w.aml, posit=TRUE))
stop("'w.aml' must be a vector of positive values")
- if(mode(link)!= "character" && mode(link)!= "name")
+ if (mode(link)!= "character" && mode(link)!= "name")
link = as.character(substitute(link))
- if(!is.list(earg)) earg = list()
+ if (!is.list(earg)) earg = list()
new("vglmff",
blurb=c("Logistic expectile regression by ",
@@ -1336,20 +1336,20 @@ amlbinomial <- function(w.aml=1, parallel=FALSE, digw=4,
initialize=eval(substitute(expression({
{
NCOL = function (x)
- if(is.array(x) && length(dim(x)) > 1 ||
+ if (is.array(x) && length(dim(x)) > 1 ||
is.data.frame(x)) ncol(x) else as.integer(1)
- if(NCOL(y) == 1) {
- if(is.factor(y)) y = y != levels(y)[1]
+ if (NCOL(y) == 1) {
+ if (is.factor(y)) y = y != levels(y)[1]
nn = rep(1, n)
- if(!all(y >= 0 & y <= 1))
+ if (!all(y >= 0 & y <= 1))
stop("response values must be in [0, 1]")
mustart = (0.5 + w * y) / (1 + w)
no.successes = w * y
- if(any(abs(no.successes - round(no.successes)) > 0.001))
+ if (any(abs(no.successes - round(no.successes)) > 0.001))
stop("Number of successes must be integer-valued")
- } else if(NCOL(y) == 2) {
- if(any(abs(y - round(y)) > 0.001))
+ } 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)
@@ -1362,7 +1362,7 @@ amlbinomial <- function(w.aml=1, parallel=FALSE, digw=4,
mustart = matrix(mustart, n, length( .w.aml ))
extra$w.aml = .w.aml
- if(ncol(y <- cbind(y)) != 1)
+ if (ncol(y <- cbind(y)) != 1)
stop("response must be a vector or a one-column matrix")
extra$M = M = length(extra$w.aml) # Recycle if necessary
extra$n = n
@@ -1431,11 +1431,11 @@ amlexponential.deviance = function(mu, y, w, residuals = FALSE, eta, extra=NULL)
M <- length(extra$w.aml)
- if(M > 1) y = matrix(y,extra$n,extra$M)
+ if (M > 1) y = matrix(y,extra$n,extra$M)
devy = cbind(-log(y) - 1)
devi = cbind(-log(mu) - y / mu)
- if(residuals) {
+ if (residuals) {
stop("not sure here")
return(sign(y - mu) * sqrt(2 * abs(devi) * w) *
matrix(extra$w,extra$n,extra$M))
@@ -1446,7 +1446,7 @@ amlexponential.deviance = function(mu, y, w, residuals = FALSE, eta, extra=NULL)
(devy[,ii] - devi[,ii]) *
Wr1(myresid[,ii], w=extra$w.aml[ii]))
}
- if(is.logical(extra$individual) && extra$individual)
+ if (is.logical(extra$individual) && extra$individual)
all.deviances else sum(all.deviances)
}
@@ -1454,12 +1454,12 @@ amlexponential.deviance = function(mu, y, w, residuals = FALSE, eta, extra=NULL)
amlexponential <- function(w.aml=1, parallel=FALSE, method.init=1, digw=4,
link="loge", earg=list())
{
- if(!is.Numeric(w.aml, posit=TRUE))
+ if (!is.Numeric(w.aml, posit=TRUE))
stop("'w.aml' must be a vector of positive values")
- if(mode(link)!= "character" && mode(link)!= "name")
+ if (mode(link)!= "character" && mode(link)!= "name")
link = as.character(substitute(link))
- if(!is.list(earg)) earg = list()
- if(!is.Numeric(method.init, allow=1, integ=TRUE, posit=TRUE) ||
+ if (!is.list(earg)) earg = list()
+ if (!is.Numeric(method.init, allow=1, integ=TRUE, posit=TRUE) ||
method.init > 3) stop("argument 'method.init' must be 1, 2 or 3")
y.names = paste("w.aml=", round(w.aml, dig=digw), sep="")
@@ -1480,9 +1480,9 @@ amlexponential <- function(w.aml=1, parallel=FALSE, method.init=1, digw=4,
},
initialize=eval(substitute(expression({
extra$w.aml = .w.aml
- if(ncol(y <- cbind(y)) != 1)
+ if (ncol(y <- cbind(y)) != 1)
stop("response must be a vector or a one-column matrix")
- if(any(y <= 0.0))
+ if (any(y <= 0.0))
stop("all responses must be positive")
extra$M = M = length(extra$w.aml) # Recycle if necessary
extra$n = n
@@ -1492,10 +1492,10 @@ amlexponential <- function(w.aml=1, parallel=FALSE, method.init=1, digw=4,
predictors.names = c(namesof(
paste("expectile(",y.names,")", sep=""), .link, earg=.earg, tag=FALSE))
- if(!length(etastart)) {
- mean.init = if( .method.init == 1)
+ if (!length(etastart)) {
+ mean.init = if ( .method.init == 1)
rep(median(y), length=n) else
- if( .method.init == 2)
+ if ( .method.init == 2)
rep(weighted.mean(y, w), length=n) else {
1 / (y + 1)
}
@@ -1558,7 +1558,7 @@ rho1check = function(u, tau=0.5)
dalap = function(x, location=0, scale=1, tau=0.5,
kappa=sqrt(tau/(1-tau)), log=FALSE) {
- if(!is.logical(log.arg <- log)) stop("bad input for argument 'log'")
+ if (!is.logical(log.arg <- log)) stop("bad input for argument 'log'")
rm(log)
NN = max(length(x), length(location), length(scale), length(kappa))
@@ -1573,13 +1573,13 @@ dalap = function(x, location=0, scale=1, tau=0.5,
indexTF = (scale > 0) & (tau > 0) & (tau < 1) & (kappa > 0) # &
logconst[!indexTF] = NaN
- if(log.arg) logconst + exponent else exp(logconst + exponent)
+ if (log.arg) logconst + exponent else exp(logconst + exponent)
}
ralap = function(n, location=0, scale=1, tau=0.5, kappa=sqrt(tau/(1-tau))) {
- use.n = if((length.n <- length(n)) > 1) length.n else
- if(!is.Numeric(n, integ=TRUE, allow=1, posit=TRUE))
+ use.n = if ((length.n <- length(n)) > 1) length.n else
+ if (!is.Numeric(n, integ=TRUE, allow=1, posit=TRUE))
stop("bad input for argument 'n'") else n
location = rep(location, len=use.n); scale= rep(scale, len=use.n)
@@ -1636,10 +1636,10 @@ qalap = function(p, location=0, scale=1, tau=0.5, kappa=sqrt(tau/(1-tau))) {
-if(FALSE)
+ if (FALSE)
dqregal = function(x, tau=0.5, location=0, scale=1) {
- if(!is.Numeric(scale, posit=TRUE)) stop("'scale' must be positive")
- if(!is.Numeric(tau, posit=TRUE) || max(tau) >= 1)
+ if (!is.Numeric(scale, posit=TRUE)) stop("'scale' must be positive")
+ if (!is.Numeric(tau, posit=TRUE) || max(tau) >= 1)
stop("'tau' must have values in (0,1)")
const = tau * (1-tau) / scale
const * exp(-rho1check((x-location)/scale, tau=tau))
@@ -1647,12 +1647,12 @@ dqregal = function(x, tau=0.5, location=0, scale=1) {
-if(FALSE)
+ if (FALSE)
rqregal = function(n, tau=0.5, location=0, scale=1) {
- if(!is.Numeric(n, posit=TRUE, integ=TRUE, allow=1))
+ if (!is.Numeric(n, posit=TRUE, integ=TRUE, allow=1))
stop("bad input for argument 'n'")
- if(!is.Numeric(scale, posit=TRUE)) stop("'scale' must be positive")
- if(!is.Numeric(tau, posit=TRUE) || max(tau) >= 1)
+ if (!is.Numeric(scale, posit=TRUE)) stop("'scale' must be positive")
+ if (!is.Numeric(tau, posit=TRUE) || max(tau) >= 1)
stop("'tau' must have values in (0,1)")
location = rep(location, len=n); scale= rep(scale, len=n)
r = runif(n)
@@ -1661,16 +1661,16 @@ rqregal = function(n, tau=0.5, location=0, scale=1) {
-if(FALSE)
+ if (FALSE)
pqregal = function(q, tau=0.5, location=0, scale=1) {
- if(!all(scale == 1))
+ if (!all(scale == 1))
stop("currently can only handle scale == 1")
- if(!is.Numeric(q))
+ if (!is.Numeric(q))
stop("bad input for argument 'q'")
- if(!is.Numeric(location))
+ if (!is.Numeric(location))
stop("bad input for argument 'location'")
- if(!is.Numeric(scale, posit=TRUE)) stop("'scale' must be positive")
- if(!is.Numeric(tau, posit=TRUE) || max(tau) >= 1)
+ if (!is.Numeric(scale, posit=TRUE)) stop("'scale' must be positive")
+ if (!is.Numeric(tau, posit=TRUE) || max(tau) >= 1)
stop("'tau' must have values in (0,1)")
N = max(length(q), length(tau), length(location), length(scale))
location = rep(location, len=N); scale= rep(scale, len=N)
@@ -1681,23 +1681,23 @@ pqregal = function(q, tau=0.5, location=0, scale=1) {
ans
}
-if(FALSE)
+ if (FALSE)
qregal = function(tau=c(0.25, 0.5, 0.75),
llocation="identity",
elocation=list(),
lscale="loge", escale=list(),
ilocation=NULL,
parallel=FALSE, method.init=1, digt=4) {
- if(mode(llocation) != "character" && mode(llocation) != "name")
+ if (mode(llocation) != "character" && mode(llocation) != "name")
llocation = as.character(substitute(llocation))
- if(!is.Numeric(method.init, allow=1, integ=TRUE, posit=TRUE) ||
+ if (!is.Numeric(method.init, allow=1, integ=TRUE, posit=TRUE) ||
method.init > 2) stop("argument 'method.init' must be 1 or 2")
- if(!is.Numeric(tau, posit=TRUE) || max(tau) >= 1)
+ if (!is.Numeric(tau, posit=TRUE) || max(tau) >= 1)
stop("bad input for argument 'tau'")
- if(!is.list(elocation)) elocation = list()
- if(mode(lscale) != "character" && mode(lscale) != "name")
+ if (!is.list(elocation)) elocation = list()
+ if (mode(lscale) != "character" && mode(lscale) != "name")
lscale = as.character(substitute(lscale))
- if(!is.list(escale)) escale = list()
+ if (!is.list(escale)) escale = list()
new("vglmff",
blurb=c("Quantile REGression via an Asymmetric Laplace distribution\n\n",
@@ -1709,7 +1709,7 @@ qregal = function(tau=c(0.25, 0.5, 0.75),
}), list( .parallel=parallel ))),
initialize=eval(substitute(expression({
extra$tau = .tau
- if(ncol(y <- cbind(y)) != 1)
+ if (ncol(y <- cbind(y)) != 1)
stop("response must be a vector or a one-column matrix")
extra$M = M = 1 + length(extra$tau)
extra$n = n
@@ -1721,13 +1721,13 @@ qregal = function(tau=c(0.25, 0.5, 0.75),
namesof(paste("quantile(",y.names,")", sep=""),
link = .llocation, earg=.elocation, tag=FALSE))
- if(!length(etastart)) {
- if( .method.init == 1) {
+ if (!length(etastart)) {
+ if ( .method.init == 1) {
location.init = median(y)
} else {
location.init = y
}
- location.init = if(length(.ilocation)) {
+ location.init = if (length(.ilocation)) {
matrix( .ilocation, n, M-1, byrow=TRUE)
} else {
rep(location.init, len=n)
@@ -1775,7 +1775,7 @@ qregal = function(tau=c(0.25, 0.5, 0.75),
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
+ if (residuals) stop("loglikelihood residuals not implemented yet") else
sum(w * (-log(scalemat) + log(taumat) + log1p(-taumat) -
rho1check((ymat-locmat)/scalemat, tau=taumat)))
}, list( .elocation=elocation, .llocation=llocation,
@@ -1813,8 +1813,8 @@ qregal = function(tau=c(0.25, 0.5, 0.75),
rloglap = function(n, location.ald=0, scale.ald=1, tau=0.5,
kappa=sqrt(tau/(1-tau))) {
- use.n = if((length.n <- length(n)) > 1) length.n else
- if(!is.Numeric(n, integ=TRUE, allow=1, posit=TRUE))
+ use.n = if ((length.n <- length(n)) > 1) length.n else
+ if (!is.Numeric(n, integ=TRUE, allow=1, posit=TRUE))
stop("bad input for argument 'n'") else n
location.ald = rep(location.ald, len=use.n);
scale.ald= rep(scale.ald, len=use.n)
@@ -1830,7 +1830,7 @@ rloglap = function(n, location.ald=0, scale.ald=1, tau=0.5,
dloglap = function(x, location.ald=0, scale.ald=1, tau=0.5,
kappa=sqrt(tau/(1-tau)), log=FALSE) {
- 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)
NN = max(length(x), length(location.ald), length(scale.ald), length(kappa))
@@ -1847,7 +1847,7 @@ dloglap = function(x, location.ald=0, scale.ald=1, tau=0.5,
indexTF = (scale.ald > 0) & (tau > 0) & (tau < 1) & (kappa > 0) # &
logdensity[!indexTF] = NaN
logdensity[x < 0 & indexTF] = -Inf
- if(log.arg) logdensity else exp(logdensity)
+ if (log.arg) logdensity else exp(logdensity)
}
@@ -1911,7 +1911,7 @@ rlogitlap = function(n, location.ald=0, scale.ald=1, tau=0.5,
dlogitlap = function(x, location.ald=0, scale.ald=1, tau=0.5,
kappa=sqrt(tau/(1-tau)), log=FALSE, earg=list()) {
- if(!is.logical(log.arg <- log)) stop("bad input for argument 'log'")
+ 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))
@@ -1931,7 +1931,7 @@ dlogitlap = function(x, location.ald=0, scale.ald=1, tau=0.5,
logdensity[!indexTF] = NaN
logdensity[x < 0 & indexTF] = -Inf
logdensity[x > 1 & indexTF] = -Inf
- if(log.arg) logdensity else exp(logdensity)
+ if (log.arg) logdensity else exp(logdensity)
}
@@ -1979,7 +1979,7 @@ rprobitlap = function(n, location.ald=0, scale.ald=1, tau=0.5,
dprobitlap = function(x, location.ald=0, scale.ald=1, tau=0.5,
kappa=sqrt(tau/(1-tau)), log=FALSE,
earg=list(), meth2=TRUE) {
- if(!is.logical(log.arg <- log)) stop("bad input for argument 'log'")
+ 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))
@@ -1990,7 +1990,7 @@ dprobitlap = function(x, location.ald=0, scale.ald=1, tau=0.5,
logdensity = x * NaN
index1 = (x > 0) & (x < 1)
indexTF = (scale.ald > 0) & (tau > 0) & (tau < 1) & (kappa > 0) # &
- if(meth2) {
+ if (meth2) {
dx.dy = x
use.x = probit(x[index1], earg=earg)
logdensity[index1] = dalap(x=use.x, location=location.ald[index1],
@@ -2013,13 +2013,13 @@ dprobitlap = function(x, location.ald=0, scale.ald=1, tau=0.5,
logdensity[x < 0 & indexTF] = -Inf
logdensity[x > 1 & indexTF] = -Inf
- if(meth2) {
+ if (meth2) {
dx.dy[index1] = probit(x[index1], earg=earg, inverse=FALSE, deriv=1)
- dx.dy[!index1] = 0 # zz 0 seems to work. -Inf
+ 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)
+ if (log.arg) logdensity else exp(logdensity)
}
}
@@ -2067,7 +2067,7 @@ rclogloglap = function(n, location.ald=0, scale.ald=1, tau=0.5,
dclogloglap = function(x, location.ald=0, scale.ald=1, tau=0.5,
kappa=sqrt(tau/(1-tau)), log=FALSE,
earg=list(), meth2=TRUE) {
- if(!is.logical(log.arg <- log)) stop("bad input for argument 'log'")
+ 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))
@@ -2078,7 +2078,7 @@ dclogloglap = function(x, location.ald=0, scale.ald=1, tau=0.5,
logdensity = x * NaN
index1 = (x > 0) & (x < 1)
indexTF = (scale.ald > 0) & (tau > 0) & (tau < 1) & (kappa > 0) # &
- if(meth2) {
+ if (meth2) {
dx.dy = x
use.w = cloglog(x[index1], earg=earg)
logdensity[index1] = dalap(x=use.w, location=location.ald[index1],
@@ -2099,13 +2099,14 @@ dclogloglap = function(x, location.ald=0, scale.ald=1, tau=0.5,
logdensity[x < 0 & indexTF] = -Inf
logdensity[x > 1 & indexTF] = -Inf
- if(meth2) {
+ if (meth2) {
dx.dy[index1] = cloglog(x[index1], earg=earg, inverse=FALSE, deriv=1)
- dx.dy[!index1] = 0 # zz 0 seems to work. -Inf
+ 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)
+ if (log.arg) logdensity else exp(logdensity)
}
}
diff --git a/R/family.rcqo.q b/R/family.rcqo.R
similarity index 79%
rename from R/family.rcqo.q
rename to R/family.rcqo.R
index 2f0d95a..c2a7beb 100644
--- a/R/family.rcqo.q
+++ b/R/family.rcqo.R
@@ -1,5 +1,5 @@
# These functions are
-# Copyright (C) 1998-2009 T.W. Yee, University of Auckland. All rights reserved.
+# Copyright (C) 1998-2010 T.W. Yee, University of Auckland. All rights reserved.
@@ -14,7 +14,7 @@ rcqo <- function(n, p, S,
EqualMaxima = FALSE,
EqualTolerances = TRUE,
ESOptima = FALSE,
- loabundance = if(EqualMaxima) hiabundance else 10,
+ loabundance = if (EqualMaxima) hiabundance else 10,
hiabundance = 100,
sdlv = head(1.5/2^(0:3), Rank),
sdOptima = ifelse(ESOptima, 1.5/Rank, 1) *
@@ -34,40 +34,40 @@ rcqo <- function(n, p, S,
family = match.arg(family, c("poisson","negbinomial", "binomial-poisson",
"Binomial-negbinomial", "ordinal-poisson",
"Ordinal-negbinomial","gamma2"))[1]
- if(!is.Numeric(n, integer=TRUE, posit=TRUE, allow=1))
+ if (!is.Numeric(n, integer=TRUE, posit=TRUE, allow=1))
stop("bad input for argument 'n'")
- if(!is.Numeric(p, integer=TRUE, posit=TRUE, allow=1) || p < 1 + Rank)
+ if (!is.Numeric(p, integer=TRUE, posit=TRUE, allow=1) || p < 1 + Rank)
stop("bad input for argument 'p'")
- if(!is.Numeric(S, integer=TRUE, posit=TRUE, allow=1))
+ if (!is.Numeric(S, integer=TRUE, posit=TRUE, allow=1))
stop("bad input for argument 'S'")
- if(!is.Numeric(Rank, integer=TRUE, posit=TRUE, allow=1) || Rank > 4)
+ if (!is.Numeric(Rank, integer=TRUE, posit=TRUE, allow=1) || Rank > 4)
stop("bad input for argument 'Rank'")
- if(!is.Numeric(Kvector, posit=TRUE))
+ if (!is.Numeric(Kvector, posit=TRUE))
stop("bad input for argument 'Kvector'")
- if(!is.Numeric(rhox) || abs(rhox) >= 1)
+ if (!is.Numeric(rhox) || abs(rhox) >= 1)
stop("bad input for argument 'rhox'")
- if(length(seed) && !is.Numeric(seed, integer=TRUE, posit=TRUE))
+ if (length(seed) && !is.Numeric(seed, integer=TRUE, posit=TRUE))
stop("bad input for argument 'seed'")
- if(!is.logical(EqualTolerances) || length(EqualTolerances)>1)
+ if (!is.logical(EqualTolerances) || length(EqualTolerances)>1)
stop("bad input for argument 'EqualTolerances)'")
- if(!is.logical(sqrt) || length(sqrt)>1)
+ if (!is.logical(sqrt) || length(sqrt)>1)
stop("bad input for argument 'sqrt)'")
- if(family != "negbinomial" && sqrt)
+ if (family != "negbinomial" && sqrt)
warning("argument 'sqrt' is used only with family='negbinomial'")
- if(!EqualTolerances && !is.Numeric(sdTolerances, posit=TRUE))
+ if (!EqualTolerances && !is.Numeric(sdTolerances, posit=TRUE))
stop("bad input for argument 'sdTolerances'")
- if(!is.Numeric(loabundance, posit=TRUE))
+ if (!is.Numeric(loabundance, posit=TRUE))
stop("bad input for argument 'loabundance'")
- if(!is.Numeric(sdlv, posit=TRUE))
+ if (!is.Numeric(sdlv, posit=TRUE))
stop("bad input for argument 'sdlv'")
- if(!is.Numeric(sdOptima, posit=TRUE))
+ if (!is.Numeric(sdOptima, posit=TRUE))
stop("bad input for argument 'sdOptima'")
- if(EqualMaxima && loabundance != hiabundance)
+ if (EqualMaxima && loabundance != hiabundance)
stop("arguments 'loabundance' and 'hiabundance' must ",
"be equal when 'EqualTolerances=TRUE'")
- if(any(loabundance > hiabundance))
+ if (any(loabundance > hiabundance))
stop("loabundance > hiabundance is not allowed")
- if(!is.logical(Crow1positive)) {
+ if (!is.logical(Crow1positive)) {
stop("bad input for argument 'Crow1positive)'")
} else {
Crow1positive = rep(Crow1positive, len=Rank)
@@ -77,15 +77,15 @@ rcqo <- function(n, p, S,
sdOptima = rep(sdOptima, len=Rank)
sdTolerances = rep(sdTolerances, len=Rank)
AA = sdOptima / 3^0.5
- if(Rank > 1 && any(diff(sdlv) > 0))
+ if (Rank > 1 && any(diff(sdlv) > 0))
stop("argument 'sdlv)' must be a vector with decreasing values")
- if(FALSE)
+ if (FALSE)
change.seed.expression = expression({
- if(!exists(".Random.seed", envir = .GlobalEnv, inherits = FALSE)) {
+ if (!exists(".Random.seed", envir = .GlobalEnv, inherits = FALSE)) {
runif(1) # initialize the RNG if necessary
}
- if(is.null(seed)) {
+ if (is.null(seed)) {
RNGstate <- get(".Random.seed", envir = .GlobalEnv)
} else {
R.seed <- get(".Random.seed", envir = .GlobalEnv)
@@ -95,14 +95,14 @@ rcqo <- function(n, p, S,
}
})
change.seed.expression = expression({
- if(length(seed)) set.seed(seed)
+ if (length(seed)) set.seed(seed)
})
eval(change.seed.expression)
V = matrix(rhox, p-1, p-1)
diag(V) = 1
L = chol(V)
- if(length(xmat)) {
+ if (length(xmat)) {
xnames = colnames(xmat)
} else {
eval(change.seed.expression)
@@ -114,20 +114,20 @@ rcqo <- function(n, p, S,
eval(change.seed.expression)
ccoefs = matrix(rnorm((p-1)*Rank), p-1, Rank)
lvmat = cbind(xmat %*% ccoefs)
- if(Rank > 1) {
+ if (Rank > 1) {
Rmat = chol(var(lvmat))
iRmat = solve(Rmat)
lvmat = lvmat %*% iRmat # var(lvmat) == diag(Rank)
ccoefs = ccoefs %*% iRmat
}
for(r in 1:Rank)
- if(( Crow1positive[r] && ccoefs[1,r] < 0) ||
+ if (( Crow1positive[r] && ccoefs[1,r] < 0) ||
(!Crow1positive[r] && ccoefs[1,r] > 0)) {
ccoefs[,r] = -ccoefs[,r]
lvmat[,r] = -lvmat[,r]
}
- if(scalelv) {
+ if (scalelv) {
for(r in 1:Rank) {
sdlvr = sd(lvmat[,r])
lvmat[,r] = lvmat[,r] * sdlv[r] / sdlvr
@@ -139,18 +139,18 @@ rcqo <- function(n, p, S,
sdlvr = c(sdlvr, sd(lvmat[,r]))
}
}
- if(ESOptima) {
- if(!is.Numeric(S^(1/Rank), integ=TRUE) || S^(1/Rank) < 2)
+ if (ESOptima) {
+ if (!is.Numeric(S^(1/Rank), integ=TRUE) || S^(1/Rank) < 2)
stop("S^(1/Rank) must be an integer greater or equal to 2")
- if(Rank == 1) {
+ if (Rank == 1) {
optima = matrix(as.numeric(NA), S, Rank)
for(r in 1:Rank) {
optima[,r] = seq(-AA, AA, len=S^(1/Rank))
}
- } else if(Rank == 2) {
+ } else if (Rank == 2) {
optima = expand.grid(lv1=seq(-AA[1], AA[1], len=S^(1/Rank)),
lv2=seq(-AA[2], AA[2], len=S^(1/Rank)))
- } else if(Rank == 3) {
+ } else if (Rank == 3) {
optima = expand.grid(lv1=seq(-AA[1], AA[1], len=S^(1/Rank)),
lv2=seq(-AA[2], AA[2], len=S^(1/Rank)),
lv3=seq(-AA[3], AA[3], len=S^(1/Rank)))
@@ -160,7 +160,7 @@ rcqo <- function(n, p, S,
lv3=seq(-AA[3], AA[3], len=S^(1/Rank)),
lv4=seq(-AA[4], AA[4], len=S^(1/Rank)))
}
- if(Rank > 1)
+ if (Rank > 1)
optima = matrix(unlist(optima), S, Rank) # Make sure it is a matrix
} else {
optima = matrix(1, S, Rank)
@@ -175,14 +175,14 @@ rcqo <- function(n, p, S,
ynames = paste("y", 1:S, sep="")
Kvector = rep(Kvector, len=S)
names(Kvector) = ynames
- lvnames = if(Rank==1) "lv" else paste("lv", 1:Rank, sep="")
- Tols = if(EqualTolerances) matrix(1, S, Rank) else {
+ lvnames = if (Rank==1) "lv" else paste("lv", 1:Rank, sep="")
+ Tols = if (EqualTolerances) matrix(1, S, Rank) else {
eval(change.seed.expression)
temp = matrix(1, S, Rank)
- if(S > 1)
+ if (S > 1)
for(r in 1:Rank) {
temp[-1,r] = rnorm(S-1, mean=1, sd=sdTolerances[r])
- if(any(temp[,r] <= 0)) stop("negative tolerances!")
+ if (any(temp[,r] <= 0)) stop("negative tolerances!")
temp[,r] = temp[,r]^2 # Tolerance matrix = var-cov matrix)
}
temp
@@ -210,25 +210,25 @@ rcqo <- function(n, p, S,
"negbinomial"=2, "Binomial-negbinomial"=2, "Ordinal-negbinomial"=2,
"gamma2"=3)
eval(change.seed.expression)
- if(rootdist == 1) {
+ if (rootdist == 1) {
ymat = matrix(rpois(n*S, lam=exp(etamat)), n, S)
- } else if(rootdist == 2) {
+ } else if (rootdist == 2) {
mKvector = matrix(Kvector, n, S, byrow=TRUE)
ymat = matrix(rnbinom(n=n*S, mu=exp(etamat), size=mKvector),n,S)
- if(sqrt) ymat = ymat^0.5
- } else if(rootdist == 3) {
+ if (sqrt) ymat = ymat^0.5
+ } else if (rootdist == 3) {
Shape = matrix(Shape, n, S, byrow=TRUE)
ymat = matrix(rgamma(n*S, shape=Shape, scale=exp(etamat)/Shape),n,S)
- if(Log) ymat = log(ymat)
+ if (Log) ymat = log(ymat)
} else stop("argument 'rootdist' unmatched")
tmp1 = NULL
- if(any(family == c("ordinal-poisson","Ordinal-negbinomial"))) {
+ if (any(family == c("ordinal-poisson","Ordinal-negbinomial"))) {
tmp1 = cut(c(ymat), breaks=breaks, labels=NULL) #To get attributes(tmp1)
ymat = cut(c(ymat), breaks=breaks, labels=FALSE)
dim(ymat) = c(n,S)
}
- if(any(family == c("binomial-poisson","Binomial-negbinomial")))
+ if (any(family == c("binomial-poisson","Binomial-negbinomial")))
ymat = 0 + (ymat > 0)
myform = as.formula(paste(paste("cbind(",
@@ -257,26 +257,26 @@ rcqo <- function(n, p, S,
attr(ans, "ESOptima") = ESOptima
attr(ans, "seed") = seed # RNGstate
attr(ans, "sdTolerances") = sdTolerances
- attr(ans, "sdlv") = if(scalelv) sdlv else sdlvr
+ attr(ans, "sdlv") = if (scalelv) sdlv else sdlvr
attr(ans, "sdOptima") = sdOptima
attr(ans, "Shape") = Shape
attr(ans, "sqrt") = sqrt
attr(ans, "tolerances") = Tols^0.5 # Like a standard deviation
- attr(ans, "breaks") = if(length(tmp1)) attributes(tmp1) else breaks
+ attr(ans, "breaks") = if (length(tmp1)) attributes(tmp1) else breaks
ans
}
-if(FALSE)
+ if (FALSE)
dcqo <- function(x, p, S,
family = c("poisson", "binomial", "negbinomial", "ordinal"),
Rank = 1,
EqualTolerances = TRUE,
EqualMaxima = FALSE,
EquallySpacedOptima = FALSE,
- loabundance = if(EqualMaxima) 100 else 10,
+ loabundance = if (EqualMaxima) 100 else 10,
hiabundance = 100,
sdTolerances = 1,
sdOptima = 1,
@@ -286,31 +286,31 @@ dcqo <- function(x, p, S,
warning("12/6/06; needs a lot of work based on rcqo()")
- if(mode(family) != "character" && mode(family) != "name")
+ if (mode(family) != "character" && mode(family) != "name")
family = as.character(substitute(family))
family = match.arg(family, c("poisson", "binomial",
"negbinomial", "ordinal"))[1]
- if(!is.Numeric(p, integer=TRUE, posit=TRUE, allow=1) || p < 2)
+ if (!is.Numeric(p, integer=TRUE, posit=TRUE, allow=1) || p < 2)
stop("bad input for argument 'p'")
- if(!is.Numeric(S, integer=TRUE, posit=TRUE, allow=1))
+ if (!is.Numeric(S, integer=TRUE, posit=TRUE, allow=1))
stop("bad input for argument 'S'")
- if(!is.Numeric(Rank, integer=TRUE, posit=TRUE, allow=1))
+ if (!is.Numeric(Rank, integer=TRUE, posit=TRUE, allow=1))
stop("bad input for argument 'Rank'")
- if(length(seed) && !is.Numeric(seed, integer=TRUE, posit=TRUE))
+ if (length(seed) && !is.Numeric(seed, integer=TRUE, posit=TRUE))
stop("bad input for argument 'seed'")
- if(!is.logical(EqualTolerances) || length(EqualTolerances)>1)
+ if (!is.logical(EqualTolerances) || length(EqualTolerances)>1)
stop("bad input for argument 'EqualTolerances)'")
- if(EqualMaxima && loabundance != hiabundance)
+ if (EqualMaxima && loabundance != hiabundance)
stop("'loabundance' and 'hiabundance' must ",
"be equal when 'EqualTolerances=TRUE'")
- if(length(seed)) set.seed(seed)
+ if (length(seed)) set.seed(seed)
xmat = matrix(rnorm(n*(p-1)), n, p-1, dimnames=list(as.character(1:n),
paste("x", 2:p, sep="")))
ccoefs = matrix(rnorm((p-1)*Rank), p-1, Rank)
lvmat = xmat %*% ccoefs
optima = matrix(rnorm(Rank*S, sd=sdOptima), S, Rank)
- Tols = if(EqualTolerances) matrix(1, S, Rank) else
+ Tols = if (EqualTolerances) matrix(1, S, Rank) else
matrix(rnorm(Rank*S, mean=1, sd=1), S, Rank)
loeta = log(loabundance)
hieta = log(hiabundance)
@@ -326,14 +326,14 @@ dcqo <- function(x, p, S,
(lvmat[,r] - optmat[jay,r])
}
- ymat = if(family == "negbinomial") {
+ ymat = if (family == "negbinomial") {
} else {
matrix(rpois(n*S, lam=exp(etamat)), n, S)
}
- if(family == "binomial")
+ if (family == "binomial")
ymat = 0 + (ymat > 0)
dimnames(ymat) = list(as.character(1:n), paste("y", 1:S, sep=""))
@@ -367,7 +367,7 @@ getInitVals = function(gvals, llfun, ...) {
campp = function(q, size, prob, mu) {
if (!missing(mu)) {
- if(!missing(prob))
+ if (!missing(prob))
stop("'prob' and 'mu' both specified")
prob <- size/(size + mu)
}
diff --git a/R/family.rrr.q b/R/family.rrr.R
similarity index 81%
rename from R/family.rrr.q
rename to R/family.rrr.R
index b4a114e..2196a74 100644
--- a/R/family.rrr.q
+++ b/R/family.rrr.R
@@ -1,5 +1,5 @@
# These functions are
-# Copyright (C) 1998-2009 T.W. Yee, University of Auckland. All rights reserved.
+# Copyright (C) 1998-2010 T.W. Yee, University of Auckland. All rights reserved.
@@ -22,7 +22,7 @@ valt.control <- function(
Tolerance=1e-7, ...)
{
- if(mode(Criterion) != "character" && mode(Criterion) != "name")
+ if (mode(Criterion) != "character" && mode(Criterion) != "name")
Criterion <- as.character(substitute(Criterion))
Criterion <- match.arg(Criterion, c("rss", "coefficients"))[1]
@@ -39,18 +39,18 @@ valt.control <- function(
qrrvglm.xprod = function(numat, Aoffset, Quadratic, ITolerances) {
Rank = ncol(numat)
moff = NULL
- ans = if(Quadratic) {
+ ans = if (Quadratic) {
index = iam(NA, NA, M=Rank, diagonal=TRUE, both=TRUE)
temp1 = cbind(numat[,index$row] * numat[,index$col])
- if(ITolerances) {
+ if (ITolerances) {
moff = 0
for(ii in 1:Rank)
moff = moff - 0.5 * temp1[,ii]
}
- cbind(numat, if(ITolerances) NULL else temp1)
+ cbind(numat, if (ITolerances) NULL else temp1)
} else
as.matrix(numat)
- list(matrix=if(Aoffset>0) ans else ans[,-(1:Rank),drop=FALSE],
+ list(matrix = if (Aoffset>0) ans else ans[,-(1:Rank),drop=FALSE],
offset = moff)
}
@@ -77,42 +77,42 @@ valt <- function(x, z, U, Rank=1,
- if(mode(Criterion) != "character" && mode(Criterion) != "name")
+ if (mode(Criterion) != "character" && mode(Criterion) != "name")
Criterion <- as.character(substitute(Criterion))
Criterion <- match.arg(Criterion, c("rss", "coefficients"))[1]
- if(any(diff(Alphavec) <= 0))
+ if (any(diff(Alphavec) <= 0))
stop("Alphavec must be an increasing sequence")
- if(!is.matrix(z))
+ if (!is.matrix(z))
z <- as.matrix(z)
n <- nrow(z)
M <- ncol(z)
- if(!is.matrix(x))
+ if (!is.matrix(x))
x <- as.matrix(x)
colx2.index = (1:ncol(x))[-colx1.index]
p1 = length(colx1.index)
p2 = length(colx2.index)
p = p1 + p2
- if(!p2) stop("p2, the dimension of vars for reduced-rank regn, must be > 0")
+ if (!p2) stop("p2, the dimension of vars for reduced-rank regn, must be > 0")
- if(!length(Blist)) {
+ if (!length(Blist)) {
Blist = replace.constraints(vector("list", p), diag(M), 1:p)
}
dU <- dim(U)
- if(dU[2] != n)
+ if (dU[2] != n)
stop("input unconformable")
cmat2 = replace.constraints(vector("list", Rank+p1),
- if(length(Structural.zero))
+ if (length(Structural.zero))
diag(M)[,-Structural.zero,drop=FALSE] else diag(M), 1:Rank)
- if(p1)
+ if (p1)
for(kk in 1:p1)
cmat2[[Rank+kk]] <- Blist[[colx1.index[kk]]]
- if(is.null(Cinit))
+ if (is.null(Cinit))
Cinit <- matrix(rnorm(p2*Rank, sd=SD.Cinit), p2, Rank)
fit <- list(rss=0) # Only for initial old.crit below
@@ -125,7 +125,7 @@ valt <- function(x, z, U, Rank=1,
iter.save <- iter
lv.mat <- x[,colx2.index,drop=FALSE] %*% C
- new.lv.model.matrix = cbind(lv.mat, if(p1) x[,colx1.index] else NULL)
+ new.lv.model.matrix = cbind(lv.mat, if (p1) x[,colx1.index] else NULL)
fit = vlm.wfit(xmat=new.lv.model.matrix, z, Blist=cmat2, U=U,
matrix.out=TRUE, is.vlmX=FALSE, rss=FALSE, qr=FALSE, xij=xij)
A <- t(fit$mat.coef[1:Rank,,drop=FALSE])
@@ -137,7 +137,7 @@ valt <- function(x, z, U, Rank=1,
numat = x[,colx2.index,drop=FALSE] %*% C
evnu = eigen(var(numat))
- temp7 = if(Rank > 1) evnu$vector %*% diag(evnu$value^(-0.5)) else
+ temp7 = if (Rank > 1) evnu$vector %*% diag(evnu$value^(-0.5)) else
evnu$vector %*% evnu$value^(-0.5)
C = C %*% temp7
A = A %*% t(solve(temp7))
@@ -150,22 +150,22 @@ valt <- function(x, z, U, Rank=1,
coefficients=max(abs(C - old.crit) / (Tolerance+abs(C))),
rss=max(abs(fit$rss - old.crit) / (Tolerance+fit$rss)))
- if(trace) {
+ if (trace) {
cat(" Alternating iteration", iter,
" ratio =", format(ratio), "\n")
- if(!is.null(fit$rss))
+ if (!is.null(fit$rss))
cat(" rss =", fit$rss, "\n")
flush.console()
}
- if(ratio < Tolerance) {
- if(!Linesearch || (Linesearch && iter >= 3)) break
- } else if(iter == Maxit && !Suppress.warning) {
+ if (ratio < Tolerance) {
+ if (!Linesearch || (Linesearch && iter >= 3)) break
+ } else if (iter == Maxit && !Suppress.warning) {
warning("did not converge")
}
fini.linesearch = FALSE
- if(Linesearch && iter - recover >= 2) {
+ if (Linesearch && iter - recover >= 2) {
xnew <- C
direction1 <- (xnew-xold) # / sqrt(1 + sum((xnew-xold)^2))
@@ -176,12 +176,12 @@ valt <- function(x, z, U, Rank=1,
try.lv.mat <- x[,colx2.index,drop=FALSE] %*% CC
try.new.lv.model.matrix = cbind(try.lv.mat,
- if(p1) x[,colx1.index] else NULL)
+ if (p1) x[,colx1.index] else NULL)
try = vlm.wfit(xmat=try.new.lv.model.matrix, z, Blist=cmat2,
U=U, matrix.out=TRUE, is.vlmX=FALSE,
rss=TRUE, qr=FALSE, xij=xij)
- if(try$rss < ftemp) {
+ if (try$rss < ftemp) {
use.alpha <- Alphavec[itter]
fit <- try
ftemp <- try$rss
@@ -190,14 +190,14 @@ valt <- function(x, z, U, Rank=1,
lv.mat <- x[,colx2.index,drop=FALSE] %*% C
recover = iter # Give it some alt'g iterations to recover
} else {
- if(trace && use.alpha>0) {
+ if (trace && use.alpha>0) {
cat(" Finished line search using Alpha =",
use.alpha, "\n")
flush.console()
}
fini.linesearch = TRUE
}
- if(fini.linesearch) break
+ if (fini.linesearch) break
} # End of itter loop
}
@@ -224,38 +224,38 @@ lm2qrrvlm.model.matrix = function(x, Blist, C, control, assign=TRUE,
M = nrow(Blist[[1]])
p1 = length(colx1.index)
combine2 = c(control$Structural.zero,
- if(Corner) control$Index.corner else NULL)
+ if (Corner) control$Index.corner else NULL)
- Qoffset = if(Quadratic) ifelse(ITolerances, 0, sum(1:Rank)) else 0
+ Qoffset = if (Quadratic) ifelse(ITolerances, 0, sum(1:Rank)) else 0
NoA = length(combine2) == M # No unknown parameters in A
- cmat2 = if(NoA) {
+ cmat2 = if (NoA) {
Aoffset = 0
vector("list", Aoffset+Qoffset+p1)
} else {
Aoffset = Rank
replace.constraints(vector("list", Aoffset+Qoffset+p1),
- if(length(combine2)) diag(M)[,-combine2,drop=FALSE] else diag(M),
+ if (length(combine2)) diag(M)[,-combine2,drop=FALSE] else diag(M),
1:Rank) # If Corner then doesn't contain \bI_{Rank}
}
- if(Quadratic && !ITolerances)
+ if (Quadratic && !ITolerances)
cmat2 = replace.constraints(cmat2,
- if(control$EqualTolerances)
+ if (control$EqualTolerances)
matrix(1, M, 1) - eij(Dzero, M) else {
- if(length(Dzero)) diag(M)[,-Dzero,drop=FALSE] else diag(M)},
+ if (length(Dzero)) diag(M)[,-Dzero,drop=FALSE] else diag(M)},
Aoffset + (1:Qoffset))
- if(p1)
+ if (p1)
for(kk in 1:p1)
cmat2[[Aoffset+Qoffset+kk]] <- Blist[[colx1.index[kk]]]
- if(!no.thrills) {
+ if (!no.thrills) {
i63 = iam(NA, NA, M=Rank, both=TRUE)
names(cmat2) = c(
- if(NoA) NULL else paste("(lv", 1:Rank, ")", sep=""),
- if(Quadratic && Rank==1 && !ITolerances)
+ if (NoA) NULL else paste("(lv", 1:Rank, ")", sep=""),
+ if (Quadratic && Rank==1 && !ITolerances)
"(lv^2)" else
- if(Quadratic && Rank>1 && !ITolerances)
+ if (Quadratic && Rank>1 && !ITolerances)
paste("(lv", i63$row, ifelse(i63$row==i63$col, "^2",
paste("*lv", i63$col, sep="")), ")", sep="") else NULL,
- if(p1) names(colx1.index) else NULL)
+ if (p1) names(colx1.index) else NULL)
}
lv.mat = x[,control$colx2.index,drop=FALSE] %*% C
@@ -263,11 +263,11 @@ lm2qrrvlm.model.matrix = function(x, Blist, C, control, assign=TRUE,
tmp900 = qrrvglm.xprod(lv.mat, Aoffset, Quadratic, ITolerances)
new.lv.model.matrix = cbind(tmp900$matrix,
- if(p1) x[,colx1.index] else NULL)
- if(!no.thrills)
+ if (p1) x[,colx1.index] else NULL)
+ if (!no.thrills)
dimnames(new.lv.model.matrix) = list(dimnames(x)[[1]], names(cmat2))
- if(assign) {
+ if (assign) {
asx = attr(x, "assign")
asx = vector("list", ncol(new.lv.model.matrix))
names(asx) = names(cmat2)
@@ -277,7 +277,7 @@ lm2qrrvlm.model.matrix = function(x, Blist, C, control, assign=TRUE,
attr(new.lv.model.matrix, "assign") = asx
}
- if(no.thrills)
+ if (no.thrills)
list(new.lv.model.matrix = new.lv.model.matrix, constraints = cmat2,
offset = tmp900$offset) else
list(new.lv.model.matrix = new.lv.model.matrix, constraints = cmat2,
@@ -311,15 +311,15 @@ valt.1iter = function(x, z, U, Blist, C, control, lp.names=NULL, nice31=FALSE,
Corner = control$Corner
ITolerances = control$ITolerances
- Qoffset = if(Quadratic) ifelse(ITolerances, 0, sum(1:Rank)) else 0
+ Qoffset = if (Quadratic) ifelse(ITolerances, 0, sum(1:Rank)) else 0
tmp833 = lm2qrrvlm.model.matrix(x=x, Blist=Blist, C=C, control=control)
new.lv.model.matrix = tmp833$new.lv.model.matrix
cmat2.save = cmat2 = tmp833$constraints # Doesn't contain \bI_{Rank}
lv.mat = tmp833$lv.mat
- if(Corner)
+ if (Corner)
zedd[,Index.corner] = zedd[,Index.corner] - lv.mat
- if(nice31 && MSratio == 1) {
+ if (nice31 && MSratio == 1) {
fit = list(mat.coef = NULL, fitted.values = NULL, rss = 0)
cmat2 = NULL # for vlm.wfit
@@ -343,19 +343,19 @@ valt.1iter = function(x, z, U, Blist, C, control, lp.names=NULL, nice31=FALSE,
Eta.range = control$Eta.range,
xij=control$xij, lp.names=lp.names)
}
- A = if(tmp833$NoA) matrix(0, M, Rank) else
+ A = if (tmp833$NoA) matrix(0, M, Rank) else
t(fit$mat.coef[1:Rank,,drop=FALSE])
- if(Corner)
+ 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)
+ if (Corner)
fv[,Index.corner] = fv[,Index.corner] + lv.mat
- Dmat = if(Quadratic) {
- if(ITolerances) {
+ 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):
@@ -363,9 +363,9 @@ valt.1iter = function(x, z, U, Blist, C, control, lp.names=NULL, nice31=FALSE,
} 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=cmat2, rss=fit$rss,
- offset = if(length(tmp833$offset)) tmp833$offset else NULL)
+ offset = if (length(tmp833$offset)) tmp833$offset else NULL)
}
@@ -373,7 +373,7 @@ valt.1iter = function(x, z, U, Blist, C, control, lp.names=NULL, nice31=FALSE,
rrr.init.expression <- expression({
- if(control$Quadratic)
+ if (control$Quadratic)
copy_X_vlm <- TRUE
modelno = switch(family at vfamily[1], "poissonff"=2,
@@ -382,9 +382,9 @@ rrr.init.expression <- expression({
"quasibinomial"=1, "negbinomial"=3,
"gamma2"=5, "gaussianff"=8,
0) # stop("cannot fit this model using fast algorithm")
- if(modelno == 1) modelno = get("modelno", envir = VGAMenv)
+ if (modelno == 1) modelno = get("modelno", envir = VGAMenv)
rrcontrol$modelno = control$modelno = modelno
- if(modelno==3 || modelno==5) {
+ if (modelno==3 || modelno==5) {
M = 2 * ifelse(is.matrix(y), ncol(y), 1)
@@ -427,11 +427,11 @@ rrr.alternating.expression <- expression({
})
adjust.Dmat.expression = expression({
- if(length(Dmat)) {
+ if (length(Dmat)) {
ind0 = iam(NA, NA, both= TRUE, M=Rank)
for(kay in 1:M) {
elts = Dmat[kay,,drop=FALSE] # Manual recycling
- if(length(elts) < Rank)
+ if (length(elts) < Rank)
elts = matrix(elts, 1, Rank)
Dk = m2adefault(elts, M=Rank)[,,1]
Dk = matrix(Dk, Rank, Rank)
@@ -451,7 +451,7 @@ rrr.normalize = function(rrcontrol, A, C, x, Dmat=NULL) {
M = nrow(A)
C.old = C
- if(rrcontrol$Corner) {
+ if (rrcontrol$Corner) {
tmp87 = A[Index.corner,,drop=FALSE]
Mmat <- solve(tmp87) # The normalizing matrix
C <- C %*% t(tmp87)
@@ -460,9 +460,9 @@ rrr.normalize = function(rrcontrol, A, C, x, Dmat=NULL) {
eval(adjust.Dmat.expression)
}
- if(rrcontrol$Svd.arg) {
+ if (rrcontrol$Svd.arg) {
temp = svd(C %*% t(A))
- if(!is.matrix(temp$v))
+ if (!is.matrix(temp$v))
temp$v = as.matrix(temp$v)
C = temp$u[,1:Rank,drop=FALSE] %*%
diag(temp$d[1:Rank]^(1-rrcontrol$Alpha), nrow=Rank)
@@ -473,7 +473,7 @@ rrr.normalize = function(rrcontrol, A, C, x, Dmat=NULL) {
eval(adjust.Dmat.expression)
}
- if(rrcontrol$Uncor) {
+ if (rrcontrol$Uncorrelated.lv) {
lv.mat <- x[,colx2.index,drop=FALSE] %*% C
var.lv.mat <- var(lv.mat)
UU = chol(var.lv.mat)
@@ -485,10 +485,10 @@ rrr.normalize = function(rrcontrol, A, C, x, Dmat=NULL) {
}
- if(rrcontrol$Quadratic) {
+ if (rrcontrol$Quadratic) {
Mmat = diag(Rank)
for(LV in 1:Rank)
- if(( rrcontrol$Crow1positive[LV] && C[1,LV] < 0) ||
+ if (( rrcontrol$Crow1positive[LV] && C[1,LV] < 0) ||
(!rrcontrol$Crow1positive[LV] && C[1,LV] > 0)) {
C[,LV] = -C[,LV]
A[,LV] = -A[,LV]
@@ -504,12 +504,12 @@ rrr.normalize = function(rrcontrol, A, C, x, Dmat=NULL) {
rrr.end.expression = expression({
- if(exists(".VGAM.etamat", envir = VGAMenv))
+ if (exists(".VGAM.etamat", envir = VGAMenv))
rm(".VGAM.etamat", envir = VGAMenv)
- if(control$Quadratic) {
- if(!length(extra)) extra=list()
+ if (control$Quadratic) {
+ if (!length(extra)) extra=list()
extra$Cmat = Cmat # Saves the latest iteration
extra$Dmat = Dmat # Not the latest iteration
extra$B1 = B1.save # Not the latest iteration (not good)
@@ -517,7 +517,7 @@ rrr.end.expression = expression({
Blist = replace.constraints(Blist.save, Amat, colx2.index)
}
- X_vlm_save = if(control$Quadratic) {
+ X_vlm_save = if (control$Quadratic) {
tmp300 = lm2qrrvlm.model.matrix(x=x, Blist=Blist.save,
C=Cmat, control=control)
lv.mat = tmp300$lv.mat # Needed at the top of new.s.call
@@ -530,17 +530,17 @@ rrr.end.expression = expression({
fv <- tmp.fitted # Contains \bI \bnu
eta <- fv + offset
- if(FALSE && control$Rank == 1) {
+ if (FALSE && control$Rank == 1) {
ooo = order(lv.mat[,1])
}
mu <- family at inverse(eta, extra)
- if(any(is.na(mu)))
+ if (any(is.na(mu)))
warning("there are NAs in mu")
deriv.mu <- eval(family at deriv)
wz <- eval(family at weight)
- if(control$checkwz)
+ if (control$checkwz)
wz = checkwz(wz, M=M, trace=trace, wzeps=control$wzepsilon)
U <- vchol(wz, M=M, n=n, silent=!trace)
tvfor <- vforsub(U, as.matrix(deriv.mu), M=M, n=n)
@@ -559,12 +559,12 @@ rrr.derivative.expression <- expression({
- which.optimizer = if(control$Quadratic && control$FastAlgorithm) {
+ which.optimizer = if (control$Quadratic && control$FastAlgorithm) {
"BFGS"
} else {
- if(iter <= rrcontrol$Switch.optimizer) "Nelder-Mead" else "BFGS"
+ if (iter <= rrcontrol$Switch.optimizer) "Nelder-Mead" else "BFGS"
}
- if(trace && control$OptimizeWrtC) {
+ if (trace && control$OptimizeWrtC) {
cat("\n\n")
cat("Using", which.optimizer, "\n")
flush.console()
@@ -576,65 +576,65 @@ rrr.derivative.expression <- expression({
theta0 <- c(Cmat)
assign(".VGAM.dot.counter", 0, envir = VGAMenv)
- if(control$OptimizeWrtC) {
- if(control$Quadratic && control$FastAlgorithm) {
- if(iter == 2) {
- if(exists(".VGAM.etamat", envir = VGAMenv))
+ if (control$OptimizeWrtC) {
+ if (control$Quadratic && control$FastAlgorithm) {
+ if (iter == 2) {
+ if (exists(".VGAM.etamat", envir = VGAMenv))
rm(".VGAM.etamat", envir = VGAMenv)
}
- if(iter > 2 && !quasi.newton$convergence) {
- if(zthere <- exists(".VGAM.z", envir = VGAMenv)) {
+ if (iter > 2 && !quasi.newton$convergence) {
+ if (zthere <- exists(".VGAM.z", envir = VGAMenv)) {
..VGAM.z = get(".VGAM.z", envir = VGAMenv)
..VGAM.U = get(".VGAM.U", envir = VGAMenv)
..VGAM.beta = get(".VGAM.beta", envir = VGAMenv)
}
- if(zthere) {
+ if (zthere) {
z = matrix(..VGAM.z, n, M) # minus any offset
U = matrix(..VGAM.U, M, n)
}
}
- if(iter == 2 || quasi.newton$convergence) {
+ if (iter == 2 || quasi.newton$convergence) {
NOS = ifelse(modelno==3 || modelno==5, M/2, M)
canfitok = (exists("CQO.FastAlgorithm", envir=VGAMenv) &&
get("CQO.FastAlgorithm", envir = VGAMenv))
- if(!canfitok)
+ if (!canfitok)
stop("cannot fit this model using fast algorithm")
- p2star = if(nice31)
+ 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
+ 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
+ X_vlm_1save = if (p1star > 0) X_vlm_save[,-(1:p2star)] else NULL
quasi.newton = optim(par=Cmat, fn=callcqof,
- gr=if(control$GradientFunction) calldcqof else NULL,
+ gr = if (control$GradientFunction) calldcqof else NULL,
method=which.optimizer,
control=list(fnscale=1,trace=as.integer(control$trace),
parscale=rep(control$Parscale, len=length(Cmat)),
maxit=250),
etamat=eta, xmat=x, ymat=y, wvec=w,
- X_vlm_1save = if(nice31) NULL else X_vlm_1save,
+ 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 = VGAMenv)) {
+ if (zthere <- exists(".VGAM.z", envir = VGAMenv)) {
..VGAM.z = get(".VGAM.z", envir = VGAMenv)
..VGAM.U = get(".VGAM.U", envir = VGAMenv)
..VGAM.beta = get(".VGAM.beta", envir = VGAMenv)
}
- if(zthere) {
+ if (zthere) {
z = matrix(..VGAM.z, n, M) # minus any offset
U = matrix(..VGAM.U, M, n)
}
} else {
- if(exists(".VGAM.offset", envir = VGAMenv))
+ if (exists(".VGAM.offset", envir = VGAMenv))
rm(".VGAM.offset", envir = VGAMenv)
}
} else {
- use.reltol = if(length(rrcontrol$Reltol) >= iter)
+ use.reltol = if (length(rrcontrol$Reltol) >= iter)
rrcontrol$Reltol[iter] else rev(rrcontrol$Reltol)[1]
quasi.newton <-
optim(par=theta0,
@@ -644,7 +644,7 @@ rrr.derivative.expression <- expression({
maxit=rrcontrol$Maxit,
abstol=rrcontrol$Abstol,
reltol=use.reltol),
- U=U, z= if(control$ITolerances) z+offset else z,
+ U=U, z= if (control$ITolerances) z+offset else z,
M=M, xmat=x, # varbix2=varbix2,
Blist=Blist, rrcontrol=rrcontrol)
}
@@ -654,12 +654,12 @@ rrr.derivative.expression <- expression({
Cmat = matrix(quasi.newton$par, p2, Rank, byrow=FALSE)
- if(Rank > 1 && rrcontrol$ITolerances) {
+ if (Rank > 1 && rrcontrol$ITolerances) {
numat = x[,rrcontrol$colx2.index,drop=FALSE] %*% Cmat
evnu = eigen(var(numat))
Cmat = Cmat %*% evnu$vector
numat = x[,rrcontrol$colx2.index,drop=FALSE] %*% Cmat
- offset = if(Rank > 1) -0.5*rowSums(numat^2) else -0.5*numat^2
+ offset = if (Rank > 1) -0.5*rowSums(numat^2) else -0.5*numat^2
}
}
@@ -668,26 +668,26 @@ rrr.derivative.expression <- expression({
control=rrcontrol, lp.names=predictors.names)
- if(length(alt$offset))
+ if (length(alt$offset))
offset = alt$offset
B1.save = alt$B1 # Put later into extra
tmp.fitted = alt$fitted # contains \bI_{Rank} \bnu if Corner
- if(modelno!=33 && control$OptimizeWrtC)
+ if (modelno!=33 && control$OptimizeWrtC)
alt = rrr.normalize(rrc=rrcontrol, A=alt$Amat, C=alt$Cmat,
x=x, Dmat=alt$Dmat)
- if(trace && control$OptimizeWrtC) {
+ if (trace && control$OptimizeWrtC) {
cat("\n")
cat(which.optimizer, "using optim():\n")
cat("Objective =", quasi.newton$value, "\n")
- cat("Parameters (= c(C)) = ", if(length(quasi.newton$par) < 5)
+ cat("Parameters (= c(C)) = ", if (length(quasi.newton$par) < 5)
"" else "\n")
cat(alt$Cmat, fill=TRUE)
cat("\n")
cat("Number of function evaluations =", quasi.newton$count[1], "\n")
- if(length(quasi.newton$message))
+ if (length(quasi.newton$message))
cat("Message =", quasi.newton$message, "\n")
cat("\n")
flush.console()
@@ -706,17 +706,17 @@ rrr.derivative.expression <- expression({
rrr.derivC.rss = function(theta, U, z, M, xmat, Blist, rrcontrol,
omit.these=NULL) {
- if(rrcontrol$trace) {
+ if (rrcontrol$trace) {
cat(".")
flush.console()
}
alreadyThere = exists(".VGAM.dot.counter", envir = VGAMenv)
- if(alreadyThere) {
+ if (alreadyThere) {
VGAM.dot.counter = get(".VGAM.dot.counter", envir = VGAMenv)
VGAM.dot.counter = VGAM.dot.counter + 1
assign(".VGAM.dot.counter", VGAM.dot.counter, envir = VGAMenv)
- if(VGAM.dot.counter > max(50, options()$width - 5)) {
- if(rrcontrol$trace) {
+ if (VGAM.dot.counter > max(50, options()$width - 5)) {
+ if (rrcontrol$trace) {
cat("\n")
flush.console()
}
@@ -732,12 +732,12 @@ rrr.derivC.rss = function(theta, U, z, M, xmat, Blist, rrcontrol,
C=Cmat, control=rrcontrol, assign=FALSE)
Blist = tmp700$constraints # Doesn't contain \bI_{Rank} \bnu
- if(rrcontrol$Corner) {
+ if (rrcontrol$Corner) {
z = as.matrix(z) # should actually call this zedd
z[,rrcontrol$Index.corner] = z[,rrcontrol$Index.corner] - tmp700$lv.mat
}
- if(length(tmp700$offset)) z = z - tmp700$offset
+ if (length(tmp700$offset)) z = z - tmp700$offset
vlm.wfit(xmat=tmp700$new.lv.model.matrix, zmat=z,
@@ -795,53 +795,53 @@ nlminbcontrol = function(Abs.tol = 10^(-6),
Coef.qrrvglm <- function(object, varlvI = FALSE, reference = NULL, ...) {
- if(length(varlvI) != 1 || !is.logical(varlvI))
+ 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, allow=1, integ=TRUE))
+ if (length(reference) > 1) stop("'reference' must be of length 0 or 1")
+ if (length(reference) && is.Numeric(reference))
+ if (!is.Numeric(reference, allow=1, integ=TRUE))
stop("bad input for argument 'reference'")
- if(!is.logical(ConstrainedQO <- object at control$ConstrainedQO))
+ if (!is.logical(ConstrainedQO <- object at control$ConstrainedQO))
stop("cannot determine whether the model is constrained or not")
ocontrol = object at control
coef.object = object at coefficients
Rank = ocontrol$Rank
M = object at misc$M
- NOS = if(length(object at y)) ncol(object at y) else M
+ NOS = if (length(object at y)) ncol(object at y) else M
MSratio = M / NOS # First value is g(mean) = quadratic form in lv
- Quadratic = if(ConstrainedQO) ocontrol$Quadratic else TRUE
- if(!Quadratic) stop("object is not a quadratic ordination object")
+ Quadratic = if (ConstrainedQO) ocontrol$Quadratic else TRUE
+ if (!Quadratic) stop("object is not a quadratic ordination object")
p1 = length(ocontrol$colx1.index)
p2 = length(ocontrol$colx2.index)
Index.corner = ocontrol$Index.corner
Structural.zero = ocontrol$Structural.zero
EqualTolerances = ocontrol$EqualTolerances
Dzero = ocontrol$Dzero
- Corner = if(ConstrainedQO) ocontrol$Corner else FALSE
- estITol = if(ConstrainedQO) object at control$ITolerances else FALSE
+ Corner = if (ConstrainedQO) ocontrol$Corner else FALSE
+ estITol = if (ConstrainedQO) object at control$ITolerances else FALSE
modelno = object at control$modelno # 1,2,3,4,5,6,7 or 0
- combine2 = c(Structural.zero, if(Corner) Index.corner else NULL)
+ combine2 = c(Structural.zero, if (Corner) Index.corner else NULL)
NoA = length(combine2) == M # A is fully known # doesn't handle !Corner yet
- Qoffset = if(Quadratic) ifelse(estITol, 0, sum(1:Rank)) else 0
+ Qoffset = if (Quadratic) ifelse(estITol, 0, sum(1:Rank)) else 0
ynames = object at misc$ynames
- if(!length(ynames)) ynames = object at misc$predictors.names
- if(!length(ynames)) ynames = object at misc$ynames
- if(!length(ynames)) ynames = paste("Y", 1:NOS, sep="")
+ if (!length(ynames)) ynames = object at misc$predictors.names
+ if (!length(ynames)) ynames = object at misc$ynames
+ if (!length(ynames)) ynames = paste("Y", 1:NOS, sep="")
lp.names = object at misc$predictors.names
- if(!length(lp.names)) lp.names = NULL
+ if (!length(lp.names)) lp.names = NULL
dzero.vector = rep(FALSE, length=M)
- if(length(Dzero))
+ if (length(Dzero))
dzero.vector[Dzero] = TRUE
names(dzero.vector) = ynames
- lv.names = if(Rank==1) "lv" else paste("lv", 1:Rank, sep="")
+ lv.names = if (Rank==1) "lv" else paste("lv", 1:Rank, sep="")
td.expression = expression({
Tolerance = Darray = m2adefault(Dmat, M=Rank)
for(ii in 1:M)
- if(length(Dzero) && any(Dzero == ii)) {
+ if (length(Dzero) && any(Dzero == ii)) {
Tolerance[,,ii] = NA # Darray[,,ii] == O
bellshaped[ii] = FALSE
} else {
@@ -850,7 +850,7 @@ Coef.qrrvglm <- function(object, varlvI = FALSE, reference = NULL, ...) {
}
optimum = matrix(as.numeric(NA),Rank,M) # dimnames=list(lv.names,ynames)
for(ii in 1:M)
- if(bellshaped[ii])
+ if (bellshaped[ii])
optimum[,ii] = Tolerance[,,ii] %*% cbind(Amat[ii,])
})
Amat = object at extra$Amat # M x Rank
@@ -859,37 +859,37 @@ Coef.qrrvglm <- function(object, varlvI = FALSE, reference = NULL, ...) {
B1 = object at extra$B1 #
bellshaped = rep(FALSE, length=M)
- if(is.character(reference)) {
+ if (is.character(reference)) {
reference = (1:NOS)[reference == ynames]
- if(length(reference) != 1)
+ if (length(reference) != 1)
stop("could not match argument 'reference' with any response")
}
ptr1 = 1
- candidates = if(length(reference)) reference else {
- if(length(ocontrol$Dzero)) (1:M)[-ocontrol$Dzero] else (1:M)}
+ candidates = if (length(reference)) reference else {
+ if (length(ocontrol$Dzero)) (1:M)[-ocontrol$Dzero] else (1:M)}
repeat {
- if(ptr1 > 0) {
+ if (ptr1 > 0) {
this.spp = candidates[ptr1]
}
elts = Dmat[this.spp,,drop=FALSE]
- if(length(elts) < Rank)
+ if (length(elts) < Rank)
elts = matrix(elts, 1, Rank)
Dk = m2adefault(elts, M=Rank)[,,1] # Hopefully negative-def
temp400 = eigen(Dk)
ptr1 = ptr1 + 1
- if(all(temp400$value < 0)) break
- if(ptr1 > length(candidates)) break
+ if (all(temp400$value < 0)) break
+ if (ptr1 > length(candidates)) break
}
- if(all(temp400$value < 0)) {
+ if (all(temp400$value < 0)) {
temp1tol = -0.5 * solve(Dk)
dim(temp1tol) = c(Rank,Rank)
Mmat = t(chol(temp1tol))
- if(ConstrainedQO) {
+ if (ConstrainedQO) {
temp900 = solve(t(Mmat))
Cmat = Cmat %*% temp900
Amat = Amat %*% Mmat
}
- if(length(Cmat)) {
+ if (length(Cmat)) {
temp800 = crow1C(Cmat, ocontrol$Crow1positive, amat=Amat)
Cmat = temp800$cmat
Amat = temp800$amat
@@ -897,7 +897,7 @@ Coef.qrrvglm <- function(object, varlvI = FALSE, reference = NULL, ...) {
eval(adjust.Dmat.expression)
eval(td.expression)
} else {
- if(length(reference) == 1)
+ if (length(reference) == 1)
stop("tolerance matrix specified by 'reference' ",
"is not positive-definite") else
warning("could not find any positive-definite ",
@@ -905,9 +905,9 @@ Coef.qrrvglm <- function(object, varlvI = FALSE, reference = NULL, ...) {
}
- if(ConstrainedQO)
- if(Rank > 1) {
- if(!length(xmat <- object at x)) stop("cannot obtain the model matrix")
+ if (ConstrainedQO)
+ if (Rank > 1) {
+ if (!length(xmat <- object at x)) stop("cannot obtain the model matrix")
numat = xmat[,ocontrol$colx2.index,drop=FALSE] %*% Cmat
evnu = eigen(var(numat))
Mmat = solve(t(evnu$vector))
@@ -921,12 +921,12 @@ Coef.qrrvglm <- function(object, varlvI = FALSE, reference = NULL, ...) {
}
- if(ConstrainedQO)
- if(varlvI) {
- if(!length(xmat <- object at x)) stop("cannot obtain the model matrix")
+ if (ConstrainedQO)
+ if (varlvI) {
+ if (!length(xmat <- object at x)) stop("cannot obtain the model matrix")
numat = xmat[,ocontrol$colx2.index,drop=FALSE] %*% Cmat
sdnumat = sd(numat)
- Mmat = if(Rank > 1) diag(sdnumat) else matrix(sdnumat, 1, 1)
+ Mmat = if (Rank > 1) diag(sdnumat) else matrix(sdnumat, 1, 1)
Cmat = Cmat %*% solve(t(Mmat))
Amat = Amat %*% Mmat
temp800 = crow1C(Cmat, ocontrol$Crow1positive, amat=Amat)
@@ -938,7 +938,7 @@ Coef.qrrvglm <- function(object, varlvI = FALSE, reference = NULL, ...) {
cx1i = ocontrol$colx1.index
- maximum = if(length(cx1i)==1 && names(cx1i)=="(Intercept)") {
+ maximum = if (length(cx1i)==1 && names(cx1i)=="(Intercept)") {
eta.temp = B1
for(ii in 1:M)
eta.temp[ii] = eta.temp[ii] +
@@ -952,20 +952,20 @@ Coef.qrrvglm <- function(object, varlvI = FALSE, reference = NULL, ...) {
}
names(maximum) = ynames
- lv.mat = if(ConstrainedQO) {
+ lv.mat = if (ConstrainedQO) {
object at x[,ocontrol$colx2.index,drop=FALSE] %*% Cmat
} else {
object at lv
}
dimnames(Amat) = list(lp.names, lv.names)
- if(ConstrainedQO)
+ if (ConstrainedQO)
dimnames(Cmat) = list(names(ocontrol$colx2.index), lv.names)
- if(!length(xmat <- object at x)) stop("cannot obtain the model matrix")
+ if (!length(xmat <- object at x)) stop("cannot obtain the model matrix")
dimnames(lv.mat) = list(dimnames(xmat)[[1]], lv.names)
ans =
- new(Class=if(ConstrainedQO) "Coef.qrrvglm" else "Coef.uqo",
+ new(Class = if (ConstrainedQO) "Coef.qrrvglm" else "Coef.uqo",
A=Amat, B1=B1, Constrained=ConstrainedQO, D=Darray,
NOS = NOS, Rank = Rank,
lv = lv.mat,
@@ -976,27 +976,27 @@ Coef.qrrvglm <- function(object, varlvI = FALSE, reference = NULL, ...) {
Dzero=dzero.vector,
Maximum = maximum,
Tolerance=Tolerance)
- if(ConstrainedQO) {ans at C = Cmat} else {Cmat = NULL}
+ if (ConstrainedQO) {ans at C = Cmat} else {Cmat = NULL}
for(rrr in 1:Rank)
ans at OptimumOrder[rrr,] = order(ans at Optimum[rrr,])
for(rrr in 1:Rank)
ans at lvOrder[,rrr] = order(ans at lv[,rrr])
- if(length(object at misc$estimated.dispersion) &&
+ if (length(object at misc$estimated.dispersion) &&
object at misc$estimated.dispersion) {
p = length(object at coefficients)
n = object at misc$n
M = object at misc$M
- NOS = if(length(object at y)) ncol(object at y) else M
- pstar = if(ConstrainedQO) (p + length(Cmat)) else
+ NOS = if (length(object at y)) ncol(object at y) else M
+ pstar = if (ConstrainedQO) (p + length(Cmat)) else
p + n*Rank # Adjustment; not sure about UQO
adjusted.dispersion = object at misc$dispersion * (n*M - p) /
(n*M - pstar)
ans at dispersion = adjusted.dispersion
}
- if(MSratio > 1) {
+ if (MSratio > 1) {
keepIndex = seq(from=1, to=M, by=MSratio)
ans at Dzero = ans at Dzero[keepIndex]
ans at Optimum = ans at Optimum[,keepIndex,drop=FALSE]
@@ -1050,20 +1050,20 @@ printCoef.qrrvglm = function(x, ...) {
M = nrow(object at A)
NOS = object at NOS
mymat = matrix(as.numeric(NA), NOS, Rank)
- if(Rank == 1) { # || object at Diagonal
+ if (Rank == 1) { # || object at Diagonal
for(ii in 1:NOS) {
- fred = if(Rank>1) diag(object at Tolerance[,,ii,drop=F]) else
+ fred = if (Rank>1) diag(object at Tolerance[,,ii,drop=F]) else
object at Tolerance[,,ii]
- if(all(fred > 0))
+ if (all(fred > 0))
mymat[ii,] = sqrt(fred)
}
dimnames(mymat) = list(dimnames(object at Tolerance)[[3]],
- if(Rank==1) "lv" else
+ if (Rank==1) "lv" else
paste("Tolerance", dimnames(mymat)[[2]], sep=""))
} else {
for(ii in 1:NOS) {
fred = eigen(object at Tolerance[,,ii])
- if(all(fred$value > 0))
+ if (all(fred$value > 0))
mymat[ii,] = sqrt(fred$value)
}
dimnames(mymat) = list(dimnames(object at Tolerance)[[3]],
@@ -1071,20 +1071,20 @@ printCoef.qrrvglm = function(x, ...) {
}
dimnames(object at A) = list(dimnames(object at A)[[1]],
- if(Rank > 1) paste("A", dimnames(object at A)[[2]], sep=".") else "A")
+ if (Rank > 1) paste("A", dimnames(object at A)[[2]], sep=".") else "A")
- Maximum = if(length(object at Maximum)) cbind(Maximum=object at Maximum) else NULL
- if(length(Maximum) && length(mymat) && Rank==1)
+ Maximum = if (length(object at Maximum)) cbind(Maximum=object at Maximum) else NULL
+ if (length(Maximum) && length(mymat) && Rank==1)
Maximum[is.na(mymat),] = NA
optmat = cbind(t(object at Optimum))
dimnames(optmat) = list(dimnames(optmat)[[1]],
- if(Rank > 1) paste("Optimum", dimnames(optmat)[[2]], sep=".")
+ if (Rank > 1) paste("Optimum", dimnames(optmat)[[2]], sep=".")
else "Optimum")
- if(length(optmat) && length(mymat) && Rank==1)
+ if (length(optmat) && length(mymat) && Rank==1)
optmat[is.na(mymat),] = NA
- if( object at Constrained ) {
+ if ( object at Constrained ) {
cat("\nC matrix (constrained/canonical coefficients)\n")
print(object at C, ...)
}
@@ -1094,7 +1094,7 @@ printCoef.qrrvglm = function(x, ...) {
cat("\nOptima and maxima\n")
print(cbind(Optimum=optmat,
Maximum), ...)
- if(Rank > 1) { # !object at Diagonal && Rank > 1
+ if (Rank > 1) { # !object at Diagonal && Rank > 1
cat("\nTolerances\n") } else
cat("\nTolerance\n")
print(mymat, ...)
@@ -1122,17 +1122,17 @@ predict.qrrvglm <- function(object,
extra=object at extra,
varlvI = FALSE, reference = NULL, ...)
{
- if(se.fit)
+ if (se.fit)
stop("cannot handle se.fit==TRUE yet")
- if(deriv != 0)
+ if (deriv != 0)
stop("derivative is not equal to 0")
- if(mode(type) != "character" && mode(type) != "name")
+ if (mode(type) != "character" && mode(type) != "name")
type <- as.character(substitute(type))
type <- match.arg(type, c("link", "response", "lv", "terms"))[1]
- if(type=="lv")
+ if (type=="lv")
stop("cannot handle type='lv' yet")
- if(type=="terms")
+ if (type=="terms")
stop("cannot handle type='terms' yet")
M = object at misc$M
@@ -1141,31 +1141,31 @@ predict.qrrvglm <- function(object,
na.act = object at na.action
object at na.action = list()
- if(!length(newdata) && type=="response" && length(object at fitted.values)) {
- if(length(na.act)) {
+ if (!length(newdata) && type=="response" && length(object at fitted.values)) {
+ if (length(na.act)) {
return(napredict(na.act[[1]], object at fitted.values))
} else {
return(object at fitted.values)
}
}
- if(!length(newdata)) {
+ if (!length(newdata)) {
X <- model.matrixvlm(object, type="lm", ...)
offset <- object at offset
tt <- object at terms$terms # terms(object)
- if(!length(object at x))
+ if (!length(object at x))
attr(X, "assign") = attrassignlm(X, tt)
} else {
- if(is.smart(object) && length(object at smart.prediction)) {
+ if (is.smart(object) && length(object at smart.prediction)) {
setup.smart("read", smart.prediction=object at smart.prediction)
}
tt <- object at terms$terms # terms(object) # 11/8/03; object at terms$terms
X <- model.matrix(delete.response(tt), newdata, contrasts =
- if(length(object at contrasts)) object at contrasts else NULL,
+ if (length(object at contrasts)) object at contrasts else NULL,
xlev = object at xlevels)
- if(nrow(X) != nrow(newdata)) {
+ if (nrow(X) != nrow(newdata)) {
as.save = attr(X, "assign")
X = X[rep(1, nrow(newdata)),,drop=FALSE]
dimnames(X) = list(dimnames(newdata)[[1]], "(Intercept)")
@@ -1177,9 +1177,9 @@ predict.qrrvglm <- function(object,
} else if (!is.null(object at offset))
eval(object at call$offset, newdata)
- if(any(c(offset) != 0)) stop("currently cannot handle nonzero offsets")
+ if (any(c(offset) != 0)) stop("currently cannot handle nonzero offsets")
- if(is.smart(object) && length(object at smart.prediction)) {
+ if (is.smart(object) && length(object at smart.prediction)) {
wrapup.smart()
}
@@ -1192,14 +1192,14 @@ predict.qrrvglm <- function(object,
NOS = ncol(object at y)
sppnames = dimnames(object at y)[[2]]
modelno = ocontrol$modelno # 1,2,3,5 or 0
- M = if(any(slotNames(object) == "predictors") &&
+ M = if (any(slotNames(object) == "predictors") &&
is.matrix(object at predictors)) ncol(object at predictors) else
object at misc$M
MSratio = M / NOS # First value is g(mean) = quadratic form in lv
- if(MSratio != 1) stop("can only handle MSratio==1 for now")
+ if (MSratio != 1) stop("can only handle MSratio==1 for now")
- if(length(newdata)) {
+ if (length(newdata)) {
Coefs = Coef(object, varlvI = varlvI, reference = reference)
X1mat = X[,ocontrol$colx1.index,drop=FALSE]
X2mat = X[,ocontrol$colx2.index,drop=FALSE]
@@ -1219,9 +1219,9 @@ predict.qrrvglm <- function(object,
pred = switch(type,
response={
- fv = if(length(newdata)) object at family@inverse(etamat, extra) else
+ fv = if (length(newdata)) object at family@inverse(etamat, extra) else
fitted(object)
- if(M > 1 && is.matrix(fv)) {
+ if (M > 1 && is.matrix(fv)) {
dimnames(fv) <- list(dimnames(fv)[[1]],
dimnames(object at fitted.values)[[2]])
}
@@ -1231,8 +1231,8 @@ predict.qrrvglm <- function(object,
lv=stop("failure here"),
terms=stop("failure here"))
- if(!length(newdata) && length(na.act)) {
- if(se.fit) {
+ 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)
} else {
@@ -1247,7 +1247,7 @@ setMethod("predict", "qrrvglm", function(object, ...)
coefqrrvglm = function(object, matrix.out = FALSE,
label = TRUE) {
- if(matrix.out)
+ if (matrix.out)
stop("currently cannot handle matrix.out=TRUE")
coefvlm(object, matrix.out = matrix.out, label = label)
}
@@ -1269,13 +1269,13 @@ setMethod("residuals", "qrrvglm", function(object, ...)
printrrvglm <- function(x, ...)
{
- if(!is.null(cl <- x at call)) {
+ if (!is.null(cl <- x at call)) {
cat("Call:\n")
dput(cl)
}
vecOfBetas <- x at coefficients
- if(any(nas <- is.na(vecOfBetas))) {
- if(is.null(names(vecOfBetas)))
+ 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 = "")
@@ -1283,29 +1283,29 @@ printrrvglm <- function(x, ...)
cat("\nCoefficients:\n")
print.default(vecOfBetas, ...) # used to be print()
- if(FALSE) {
+ if (FALSE) {
Rank <- x at Rank
- if(!length(Rank))
+ if (!length(Rank))
Rank <- sum(!nas)
}
- if(FALSE) {
- nobs <- if(length(x at df.total)) x at df.total else length(x at residuals)
+ 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))
+ if (!length(rdf))
rdf <- nobs - Rank
}
cat("\n")
- if(length(deviance(x)))
+ if (length(deviance(x)))
cat("Residual Deviance:", format(deviance(x)), "\n")
- if(length(vll <- logLik.vlm(x)))
+ if (length(vll <- logLik.vlm(x)))
cat("Log-likelihood:", format(vll), "\n")
- if(length(x at criterion)) {
+ if (length(x at criterion)) {
ncrit <- names(x at criterion)
for(iii in ncrit)
- if(iii != "loglikelihood" && iii != "deviance")
+ if (iii != "loglikelihood" && iii != "deviance")
cat(paste(iii, ":", sep=""), format(x at criterion[[iii]]), "\n")
}
@@ -1343,13 +1343,13 @@ summary.rrvglm <- function(object, correlation=FALSE,
- if(!is.Numeric(h.step, allow=1) || abs(h.step)>1)
+ if (!is.Numeric(h.step, allow=1) || abs(h.step)>1)
stop("bad input for 'h.step'")
- if(!object at control$Corner)
+ if (!object at control$Corner)
stop("this function works with corner constraints only")
- if(is.null(dispersion))
+ if (is.null(dispersion))
dispersion <- object at misc$dispersion
newobject <- as(object, "vglm")
@@ -1370,7 +1370,7 @@ summary.rrvglm <- function(object, correlation=FALSE,
sigma=stuff at sigma)
- if(is.numeric(stuff at dispersion))
+ if (is.numeric(stuff at dispersion))
slot(answer, "dispersion") = stuff at dispersion
@@ -1378,27 +1378,27 @@ summary.rrvglm <- function(object, correlation=FALSE,
tmp5 <- get.rrvglm.se1(object, omit13=omit13,
numerical=numerical, h.step=h.step,
kill.all=kill.all, fixA=fixA, ...)
- if(any(diag(tmp5$cov.unscaled) <= 0) ||
+ if (any(diag(tmp5$cov.unscaled) <= 0) ||
any(eigen(tmp5$cov.unscaled)$value <= 0)) {
warning("cov.unscaled is not positive definite")
}
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)
+ if (is.numeric(dispersion)) {
+ if (is.numeric(od) && dispersion!=od)
warning("dispersion != object at misc$dispersion; using the former")
} else {
- dispersion <- if(is.numeric(od)) od else 1
+ dispersion <- if (is.numeric(od)) od else 1
}
tmp8 = object at misc$M - object at control$Rank -
length(object at control$Structural.zero)
answer at df[1] <- answer at df[1] + tmp8 * object at control$Rank
answer at df[2] <- answer at df[2] - tmp8 * object at control$Rank
- if(dispersion==0) {
+ if (dispersion==0) {
dispersion <- tmp5$rss / answer at df[2] # Estimate
}
@@ -1416,17 +1416,6 @@ summary.rrvglm <- function(object, correlation=FALSE,
-printsummary.rrvglm <- function(x, digits=NULL, quote= TRUE, prefix="")
-{
-
-
- printsummary.vglm(x, digits = NULL, quote = TRUE, prefix = "")
-
-
- invisible(x)
-}
-
-
get.rrvglm.se1 = function(fit, omit13=FALSE, kill.all=FALSE,
numerical=TRUE,
@@ -1436,13 +1425,13 @@ get.rrvglm.se1 = function(fit, omit13=FALSE, kill.all=FALSE,
- if(length(fit at control$Nested) && fit at control$Nested)
+ if (length(fit at control$Nested) && fit at control$Nested)
stop("sorry, cannot handle nested models yet")
Structural.zero = fit at control$Structural.zero
- if(!length(fit at x))
+ if (!length(fit at x))
stop("fix at x is empty. Run rrvglm(... , x= TRUE)")
colx1.index = fit at control$colx1.index
@@ -1456,15 +1445,15 @@ get.rrvglm.se1 = function(fit, omit13=FALSE, kill.all=FALSE,
Rank <- fit at control$Rank # fit at misc$Nested.Rank
Amat <- fit at constraints[[colx2.index[1]]]
- Bmat <- if(p1) coefvlm(fit, mat= TRUE)[colx1.index,,drop=FALSE] else NULL
+ Bmat <- if (p1) coefvlm(fit, mat= TRUE)[colx1.index,,drop=FALSE] else NULL
C.try <- coefvlm(fit, mat= TRUE)[colx2.index,,drop=FALSE]
Cmat <- C.try %*% Amat %*% solve(t(Amat) %*% Amat)
- x1mat <- if(p1) fit at x[,colx1.index,drop=FALSE] else NULL
+ x1mat <- if (p1) fit at x[,colx1.index,drop=FALSE] else NULL
x2mat <- fit at x[,colx2.index,drop=FALSE]
wz <- weights(fit, type="w") # old: wweights(fit) #fit at weights
- if(!length(wz))
+ if (!length(wz))
stop("cannot get fit at weights")
M <- fit at misc$M
@@ -1472,11 +1461,11 @@ get.rrvglm.se1 = function(fit, omit13=FALSE, kill.all=FALSE,
Index.corner <- fit at control$Index.corner # used to be (1:Rank);
zmat <- fit at predictors + fit at residuals
theta <- c(Amat[-c(Index.corner,Structural.zero),])
- if(fit at control$checkwz)
+ if (fit at control$checkwz)
wz = checkwz(wz, M=M, trace=trace, wzeps=fit at control$wzepsilon)
U <- vchol(wz, M=M, n=n, silent= TRUE)
- if(numerical) {
+ if (numerical) {
delct.da <- num.deriv.rrr(fit, M=M, r=Rank,
x1mat=x1mat, x2mat=x2mat, p2=p2,
Index.corner, Aimat=Amat, Bmat=Bmat, Cimat=Cmat,
@@ -1509,7 +1498,7 @@ get.rrvglm.se1 = function(fit, omit13=FALSE, kill.all=FALSE,
nassign = names(fit at constraints)
choose.from = varassign(fit at constraints, nassign)
for(ii in nassign)
- if(any(ii == names(colx2.index))) {
+ if (any(ii == names(colx2.index))) {
log.vec33 = c(log.vec33, choose.from[[ii]])
}
cov33 = cov2233[ log.vec33, log.vec33, drop=FALSE] # r*p2 by r*p2
@@ -1520,7 +1509,7 @@ get.rrvglm.se1 = function(fit, omit13=FALSE, kill.all=FALSE,
lv.mat <- x2mat %*% Cmat
offs = matrix(0, n, M) # The "0" handles Structural.zero's
offs[,Index.corner] = lv.mat
- if(M == (Rank+length(Structural.zero)))
+ if (M == (Rank+length(Structural.zero)))
stop("cannot handle full-rank models yet")
cm = matrix(0, M, M-Rank-length(Structural.zero))
cm[-c(Index.corner,Structural.zero),] = diag(M-Rank-length(Structural.zero))
@@ -1532,19 +1521,19 @@ get.rrvglm.se1 = function(fit, omit13=FALSE, kill.all=FALSE,
Blist[["I(lv.mat)"]] = cm
- if(p1) {
+ if (p1) {
ooo = fit at assign
bb = NULL
for(ii in 1:length(ooo)) {
- if(any(ooo[[ii]][1] == colx1.index))
+ if (any(ooo[[ii]][1] == colx1.index))
bb = c(bb, names(ooo)[ii])
}
has.intercept = any(bb=="(Intercept)")
bb[bb=="(Intercept)"] = "1"
- if(p1>1)
+ if (p1>1)
bb = paste(bb, collapse="+")
- if(has.intercept) {
+ if (has.intercept) {
bb = paste("zmat - offs ~ ", bb, " + I(lv.mat)", collapse=" ")
} else {
bb = paste("zmat - offs ~ -1 + ", bb, " + I(lv.mat)", collapse=" ")
@@ -1555,19 +1544,19 @@ get.rrvglm.se1 = function(fit, omit13=FALSE, kill.all=FALSE,
}
- if(fit at misc$dataname == "list") {
+ if (fit at misc$dataname == "list") {
dspec = FALSE
} else {
mytext1 = "exists(x=fit at misc$dataname, envir = VGAMenv)"
myexp1 = parse(text=mytext1)
is.there = eval(myexp1)
- bbdata= if(is.there) get(fit at misc$dataname, envir=VGAMenv) else
+ bbdata= if (is.there) get(fit at misc$dataname, envir=VGAMenv) else
get(fit at misc$dataname)
dspec = TRUE
}
- fit1122 <- if(dspec) vlm(bb,
+ fit1122 <- if (dspec) vlm(bb,
constraint=Blist, crit="d", weight=wz, data=bbdata,
save.weight=TRUE, smart=FALSE, trace=trace.arg, x=TRUE) else
vlm(bb,
@@ -1589,12 +1578,12 @@ get.rrvglm.se1 = function(fit, omit13=FALSE, kill.all=FALSE,
cov13 = delct.da %*% cov33
- if(omit13)
+ if (omit13)
cov13 = cov13 * 0 # zero it
- if(kill.all) {
+ if (kill.all) {
cov13 = cov13 * 0 # zero it
- if(fixA) {
+ if (fixA) {
cov12 = cov12 * 0 # zero it
} else {
cov23 = cov23 * 0 # zero it
@@ -1603,7 +1592,7 @@ get.rrvglm.se1 = function(fit, omit13=FALSE, kill.all=FALSE,
cov13 = -cov13 # Richards (1961)
- if(fixA) {
+ if (fixA) {
cov.unscaled <- rbind(cbind(cov1122, rbind(cov13, cov23)),
cbind(t(cov13), t(cov23), cov33))
} else {
@@ -1640,12 +1629,12 @@ num.deriv.rrr <- function(fit, M, r, x1mat, x2mat,
{
nn <- nrow(x2mat)
- if(nrow(Cimat)!=p2 || ncol(Cimat)!=r)
+ if (nrow(Cimat)!=p2 || ncol(Cimat)!=r)
stop("Cimat wrong shape")
dct.da <- matrix(as.numeric(NA), (M-r-length(Structural.zero))*r, r*p2)
- if((length(Index.corner) + length(Structural.zero)) == M)
+ if ((length(Index.corner) + length(Structural.zero)) == M)
stop("cannot handle full rank models yet")
cbindex = (1:M)[-c(Index.corner, Structural.zero)]
@@ -1658,8 +1647,8 @@ num.deriv.rrr <- function(fit, M, r, x1mat, x2mat,
for(ii in 1:p2)
small.Blist[[ii]] = pAmat
- offset = if(length(fit at offset)) fit at offset else 0
- if(all(offset==0)) offset = 0
+ offset = if (length(fit at offset)) fit at offset else 0
+ if (all(offset==0)) offset = 0
neweta = x1mat %*% Bmat + x2mat %*% Cimat %*% t(pAmat)
fit at predictors = neweta
@@ -1668,7 +1657,7 @@ num.deriv.rrr <- function(fit, M, r, x1mat, x2mat,
fit at fitted.values = newmu
fred = weights(fit, type="w", deriv= TRUE, ignore.slot= TRUE)
- if(!length(fred))
+ if (!length(fred))
stop("cannot get @weights and $deriv from object")
wz = fred$weights
deriv.mu <- fred$deriv
@@ -1699,11 +1688,11 @@ dctda.fast.only = function(theta, wz, U, zmat, M, r, x1mat, x2mat,
{
- if(length(Structural.zero))
+ if (length(Structural.zero))
stop("cannot handle Structural.zero in dctda.fast.only()")
nn = nrow(x2mat)
- if(nrow(Cimat) != p2 || ncol(Cimat) != r)
+ if (nrow(Cimat) != p2 || ncol(Cimat) != r)
stop("Cimat wrong shape")
fred = kronecker(matrix(1,1,r), x2mat)
@@ -1718,10 +1707,10 @@ dctda.fast.only = function(theta, wz, U, zmat, M, r, x1mat, x2mat,
G = solve(rowSums(temp, dims=2)) # p2*r by p2*r
dc.da = array(NA, c(p2, r, M, r)) # different from other functions
- if(length(Index.corner) == M)
+ if (length(Index.corner) == M)
stop("cannot handle full rank models yet")
cbindex = (1:M)[-Index.corner] # complement of Index.corner
- resid2 = if(length(x1mat))
+ resid2 = if (length(x1mat))
mux22(t(wz), zmat - x1mat %*% Bmat, M=M, upper=FALSE, as.mat=TRUE) else
mux22(t(wz), zmat , M=M, upper=FALSE, as.mat=TRUE)
@@ -1735,7 +1724,7 @@ dctda.fast.only = function(theta, wz, U, zmat, M, r, x1mat, x2mat,
wxx = Wiak[,ttt] * x2mat
blocki = t(x2mat) %*% wxx
temp4a = blocki %*% Cimat[,kkk]
- if(kkk==1) {
+ if (kkk==1) {
temp4b = blocki %*% Cimat[,sss]
}
temp2 = temp2 - kronecker(ei(sss,r), temp4a) -
@@ -1765,7 +1754,7 @@ dcda.fast = function(theta, wz, U, z, M, r, xmat, pp, Index.corner,
Aimat[Index.corner,] <- diag(r)
Aimat[-Index.corner,] <- theta # [-(1:M)]
- if(intercept) {
+ if (intercept) {
Blist <- vector("list", pp+1)
Blist[[1]] <- diag(M)
for(ii in 2:(pp+1))
@@ -1781,13 +1770,13 @@ dcda.fast = function(theta, wz, U, z, M, r, xmat, pp, Index.corner,
c3 <- coeffs <- t(coeffs) # transpose to make M x (pp+1)
- int.vec <- if(intercept) c3[,1] else 0 # \boldeta_0
- Cimat <- if(intercept) t(c3[Index.corner,-1,drop=FALSE]) else
+ int.vec <- if (intercept) c3[,1] else 0 # \boldeta_0
+ Cimat <- if (intercept) t(c3[Index.corner,-1,drop=FALSE]) else
t(c3[Index.corner,,drop=FALSE])
- if(nrow(Cimat)!=pp || ncol(Cimat)!=r)
+ 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)
@@ -1805,7 +1794,7 @@ dcda.fast = function(theta, wz, U, z, M, r, xmat, pp, Index.corner,
for(s in 1:r)
for(tt in cbindex) {
- fred <- (if(intercept) t(xmat[,-1,drop=FALSE]) else
+ fred <- (if (intercept) t(xmat[,-1,drop=FALSE]) else
t(xmat)) * matrix(resid2[,tt],pp,nn,byrow= TRUE)
temp2 <- kronecker(ei(s,r), rowSums(fred))
@@ -1813,8 +1802,10 @@ dcda.fast = function(theta, wz, U, z, M, r, xmat, pp, Index.corner,
for(k in 1:r) {
Wiak <- mux22(t(wz), matrix(Aimat[,k],nn,M,byrow= TRUE),
M=M, upper= FALSE, as.mat= TRUE) # mat= TRUE,
- wxx <- Wiak[,tt] * (if(intercept) xmat[,-1,drop=FALSE] else xmat)
- blocki <- (if(intercept) t(xmat[,-1,drop=FALSE]) else t(xmat)) %*% wxx
+ wxx <- Wiak[,tt] * (if (intercept) xmat[,-1,drop=FALSE] else
+ xmat)
+ blocki <- (if (intercept) t(xmat[,-1,drop=FALSE]) else
+ t(xmat)) %*% wxx
temp4 <- temp4 + blocki %*% Cimat[,k]
}
dc.da[,,tt,s] <- G %*% (temp2 - 2 * kronecker(ei(s,r),temp4))
@@ -1830,11 +1821,11 @@ dcda.fast = function(theta, wz, U, z, M, r, xmat, pp, Index.corner,
for(j in 1:r) {
t1 <- t(dc.da[,j,,s])
t1 <- matrix(t1, M, pp)
- detastar.da[,j,s,] <- t1 %*% (if(intercept)
+ detastar.da[,j,s,] <- t1 %*% (if (intercept)
t(xmat[,-1,drop=FALSE]) else t(xmat))
}
- etastar <- (if(intercept) xmat[,-1,drop=FALSE] else xmat) %*% Cimat
+ etastar <- (if (intercept) xmat[,-1,drop=FALSE] else xmat) %*% Cimat
eta <- matrix(int.vec, nn, M, byrow= TRUE) + etastar %*% t(Aimat)
sumWinv <- solve((m2adefault(t(colSums(wz)), M=M))[,,1])
@@ -1868,7 +1859,7 @@ rrr.deriv.rss = function(theta, wz, U, z, M, r, xmat,
Amat[Index.corner,] = diag(r)
Amat[-Index.corner,] = theta # [-(1:M)]
- if(intercept) {
+ if (intercept) {
Blist = vector("list", pp+1)
Blist[[1]] = diag(M)
for(ii in 2:(pp+1))
@@ -1899,7 +1890,7 @@ rrr.deriv.gradient.fast = function(theta, wz, U, z, M, r, xmat,
Aimat[Index.corner,] = diag(r)
Aimat[-Index.corner,] = theta # [-(1:M)]
- if(intercept) {
+ if (intercept) {
Blist = vector("list", pp+1)
Blist[[1]] = diag(M)
for(i in 2:(pp+1))
@@ -1915,13 +1906,13 @@ rrr.deriv.gradient.fast = function(theta, wz, U, z, M, r, xmat,
c3 = coeffs = t(coeffs) # transpose to make M x (pp+1)
- int.vec = if(intercept) c3[,1] else 0 # \boldeta_0
- Cimat = if(intercept) t(c3[Index.corner,-1,drop=FALSE]) else
+ int.vec = if (intercept) c3[,1] else 0 # \boldeta_0
+ Cimat = if (intercept) t(c3[Index.corner,-1,drop=FALSE]) else
t(c3[Index.corner,,drop=FALSE])
- if(nrow(Cimat)!=pp || ncol(Cimat)!=r)
+ 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)
@@ -1939,7 +1930,7 @@ rrr.deriv.gradient.fast = function(theta, wz, U, z, M, r, xmat,
for(s in 1:r)
for(tt in cbindex) {
- fred = (if(intercept) t(xmat[,-1,drop=FALSE]) else
+ fred = (if (intercept) t(xmat[,-1,drop=FALSE]) else
t(xmat)) * matrix(resid2[,tt],pp,nn,byrow= TRUE)
temp2 = kronecker(ei(s,r), rowSums(fred))
@@ -1947,8 +1938,8 @@ rrr.deriv.gradient.fast = function(theta, wz, U, z, M, r, xmat,
for(k in 1:r) {
Wiak = mux22(t(wz), matrix(Aimat[,k],nn,M,byrow= TRUE),
M=M, upper= FALSE, as.mat= TRUE) # mat= TRUE,
- wxx = Wiak[,tt] * (if(intercept) xmat[,-1,drop=FALSE] else xmat)
- blocki = (if(intercept) t(xmat[,-1,drop=FALSE]) else t(xmat)) %*% wxx
+ wxx = Wiak[,tt] * (if (intercept) xmat[,-1,drop=FALSE] else xmat)
+ blocki = (if (intercept) t(xmat[,-1,drop=FALSE]) else t(xmat)) %*% wxx
temp4 = temp4 + blocki %*% Cimat[,k]
}
dc.da[,,s,tt] = G %*% (temp2 - 2 * kronecker(ei(s,r),temp4))
@@ -1959,11 +1950,11 @@ rrr.deriv.gradient.fast = function(theta, wz, U, z, M, r, xmat,
for(j in 1:r) {
t1 = t(dc.da[,j,s,])
t1 = matrix(t1, M, pp)
- detastar.da[,j,s,] = t1 %*% (if(intercept)
+ detastar.da[,j,s,] = t1 %*% (if (intercept)
t(xmat[,-1,drop=FALSE]) else t(xmat))
}
- etastar = (if(intercept) xmat[,-1,drop=FALSE] else xmat) %*% Cimat
+ etastar = (if (intercept) xmat[,-1,drop=FALSE] else xmat) %*% Cimat
eta = matrix(int.vec, nn, M, byrow= TRUE) + etastar %*% t(Aimat)
sumWinv = solve((m2adefault(t(colSums(wz)), M=M))[,,1])
@@ -2003,7 +1994,7 @@ 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) {
- if(length(center) != 2) stop("center must be of length 2")
+ if (length(center) != 2) stop("center must be of length 2")
theta = 2*pi*(0:N)/N
x1 = R*cos(theta)
y1 = ratio*R*sin(theta)
@@ -2021,8 +2012,8 @@ biplot.qrrvglm = function(x, ...) {
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=""),
- ylab=if(Rank==1) switch(type, predictors="Predictors",
+ 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,
llty=par()$lty, lcol=par()$col, llwd=par()$lwd,
@@ -2039,21 +2030,21 @@ lvplot.qrrvglm = function(object, varlvI = FALSE, reference = NULL,
sfont=par()$font,
check.ok = TRUE, ...)
{
- if(mode(type) != "character" && mode(type) != "name")
+ if (mode(type) != "character" && mode(type) != "name")
type <- as.character(substitute(type))
type <- match.arg(type, c("fitted.values", "predictors"))[1]
- if(is.numeric(OriginC)) OriginC = rep(OriginC, len=2) else {
- if(mode(OriginC) != "character" && mode(OriginC) != "name")
+ if (is.numeric(OriginC)) OriginC = rep(OriginC, len=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(is.logical(ellipse)) {ellipse = if(ellipse) 0.95 else NULL}
+ 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
- if(Rank > 2)
+ if (Rank > 2)
stop("can only handle rank 1 or 2 models")
M = object at misc$M
NOS = ncol(object at y)
@@ -2061,21 +2052,21 @@ lvplot.qrrvglm = function(object, varlvI = FALSE, reference = NULL,
n = object at misc$n
colx2.index = object at control$colx2.index
cx1i = object at control$colx1.index
- if(check.ok)
- if(!(length(cx1i)==1 && names(cx1i)=="(Intercept)"))
+ if (check.ok)
+ 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
+ if ( C) Cmat = Coef.list at C
nustar = Coef.list at lv # n x Rank
- if(!plot.it) return(nustar)
+ if (!plot.it) return(nustar)
r.curves = slot(object, type) # n times M (\boldeta or \boldmu)
- if(!add) {
- if(Rank==1) {
+ 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]),
@@ -2084,7 +2075,7 @@ lvplot.qrrvglm = function(object, varlvI = FALSE, reference = NULL,
}
}
- if((length(pch) != 1 && length(pch) != ncol(r.curves)) ||
+ if ((length(pch) != 1 && length(pch) != ncol(r.curves)) ||
(length(pcol) != 1 && length(pcol) != ncol(r.curves)) ||
(length(pcex) != 1 && length(pcex) != ncol(r.curves)))
stop("pch, pcol and pcex must be of length 1 or ncol(r.curves)")
@@ -2099,7 +2090,7 @@ lvplot.qrrvglm = function(object, varlvI = FALSE, reference = NULL,
ecol <- rep(ecol, leng=ncol(r.curves))
elwd <- rep(elwd, leng=ncol(r.curves))
adj.arg <- rep(adj.arg, leng=ncol(r.curves))
- if( C ) {
+ if ( C ) {
Clwd <- rep(Clwd, leng=nrow(Cmat))
Clty <- rep(Clty, leng=nrow(Cmat))
Ccol <- rep(Ccol, leng=nrow(Cmat))
@@ -2107,7 +2098,7 @@ lvplot.qrrvglm = function(object, varlvI = FALSE, reference = NULL,
Ccex <- rep(Ccex, leng=nrow(Cmat))
}
- if(Rank==1) {
+ if (Rank==1) {
for(i in 1:ncol(r.curves)) {
xx = nustar
yy = r.curves[,i]
@@ -2115,62 +2106,62 @@ lvplot.qrrvglm = function(object, varlvI = FALSE, reference = NULL,
xx = xx[o]
yy = yy[o]
lines(xx, yy, col=lcol[i], lwd=llwd[i], lty=llty[i])
- if( y && type=="fitted.values") {
+ if ( y && type=="fitted.values") {
ypts = object at y
- if(ncol(as.matrix(ypts)) == ncol(r.curves))
+ if (ncol(as.matrix(ypts)) == ncol(r.curves))
points(xx, ypts[o,i], col=pcol[i], cex=pcex[i], pch=pch[i])
}
}
- if(rug) rug(xx)
+ if (rug) rug(xx)
} else {
for(i in 1:ncol(r.curves))
points(Coef.list at Optimum[1,i], Coef.list at Optimum[2,i],
col=pcol[i], cex=pcex[i], pch=pch[i])
- if(label.arg) {
+ if (label.arg) {
for(i in 1:ncol(r.curves))
text(Coef.list at Optimum[1,i], Coef.list at Optimum[2,i],
labels=(dimnames(Coef.list at Optimum)[[2]])[i],
adj=adj.arg[i], col=pcol[i], cex=pcex[i])
}
- if(chull.arg) {
+ if (chull.arg) {
hull = chull(nustar[,1], nustar[,2])
hull = c(hull, hull[1])
lines(nustar[hull,1], nustar[hull,2], type="b", pch=cpch,
lty=clty, col=ccol, lwd=clwd)
}
- if(length(ellipse)) {
- ellipse.temp = if(ellipse > 0) ellipse else 0.95
- if(ellipse < 0 && (!object at control$EqualTolerances || varlvI))
+ 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")
- if( check.ok ) {
+ if ( check.ok ) {
colx1.index = object at control$colx1.index
- if(!(length(colx1.index)==1 &&
+ if (!(length(colx1.index)==1 &&
names(colx1.index)=="(Intercept)"))
stop("can only plot ellipses for intercept models only")
}
for(i in 1:ncol(r.curves)) {
- cutpoint = object at family@link(if(Absolute) ellipse.temp
+ cutpoint = object at family@link( if (Absolute) ellipse.temp
else Coef.list at Maximum[i] * ellipse.temp,
extra=object at extra)
- if(MSratio > 1)
+ if (MSratio > 1)
cutpoint = cutpoint[1,1]
cutpoint = object at family@link(Coef.list at Maximum[i],
extra=object at extra) - cutpoint
- if(is.finite(cutpoint) && cutpoint > 0) {
+ if (is.finite(cutpoint) && cutpoint > 0) {
Mmat = diag(rep(ifelse(object at control$Crow1positive, 1, -1),
len=Rank))
etoli = eigen(t(Mmat) %*% Coef.list at Tolerance[,,i] %*% Mmat)
A=ifelse(etoli$val[1]>0,sqrt(2*cutpoint*etoli$val[1]),Inf)
B=ifelse(etoli$val[2]>0,sqrt(2*cutpoint*etoli$val[2]),Inf)
- if(ellipse < 0) A = B = -ellipse / 2
+ if (ellipse < 0) A = B = -ellipse / 2
theta.angle = asin(etoli$vector[2,1]) *
ifelse(object at control$Crow1positive[2], 1, -1)
- if(object at control$Crow1positive[1])
+ if (object at control$Crow1positive[1])
theta.angle = pi - theta.angle
- if(all(is.finite(c(A,B))))
+ if (all(is.finite(c(A,B))))
lines(vellipse(R=2*A, ratio=B/A, orient=theta.angle,
center=Coef.list at Optimum[,i], N=egrid),
lwd=elwd[i], col=ecol[i], lty=elty[i])
@@ -2178,17 +2169,17 @@ lvplot.qrrvglm = function(object, varlvI = FALSE, reference = NULL,
}
}
- if( C ) {
- if(is.character(OriginC) && OriginC=="mean")
+ if ( C ) {
+ if (is.character(OriginC) && OriginC=="mean")
OriginC = c(mean(nustar[,1]), mean(nustar[,2]))
- if(is.character(OriginC) && OriginC=="origin")
+ if (is.character(OriginC) && OriginC=="origin")
OriginC = c(0,0)
for(i in 1:nrow(Cmat))
arrows(x0=OriginC[1], y0=OriginC[2],
x1=OriginC[1] + stretchC*Cmat[i,1],
y1=OriginC[2] + stretchC*Cmat[i,2],
lty=Clty[i], col=Ccol[i], lwd=Clwd[i])
- if(label.arg) {
+ if (label.arg) {
temp200 = dimnames(Cmat)[[1]]
for(i in 1:nrow(Cmat))
text(OriginC[1] + stretchC*Cmat[i,1],
@@ -2196,9 +2187,9 @@ lvplot.qrrvglm = function(object, varlvI = FALSE, reference = NULL,
labels=temp200[i], adj=Cadj.arg[i], cex=Ccex[i])
}
}
- if(sites) {
+ if (sites) {
text(nustar[,1], nustar[,2], adj=0.5,
- labels=if(is.null(spch)) dimnames(nustar)[[1]] else
+ labels = if (is.null(spch)) dimnames(nustar)[[1]] else
rep(spch, length=nrow(nustar)), col=scol, cex=scex, font=sfont)
}
}
@@ -2215,7 +2206,7 @@ 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))
+ 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,
@@ -2240,7 +2231,7 @@ lvplot.rrvglm = function(object,
{
- if(object at control$Rank != 2 && plot.it)
+ if (object at control$Rank != 2 && plot.it)
stop("can only handle rank-2 models")
M = object at misc$M
n = object at misc$n
@@ -2255,27 +2246,27 @@ lvplot.rrvglm = function(object,
dimnames(Amat) = list(object at misc$predictors.names, NULL)
Cmat = Cmat / scaleA
- if(!length(object at x)) {
+ if (!length(object at x)) {
object at x = model.matrixvlm(object, type="lm")
}
x2mat = object at x[,colx2.index,drop=FALSE]
nuhat = x2mat %*% Cmat
- if(!plot.it) return(as.matrix(nuhat))
+ if (!plot.it) return(as.matrix(nuhat))
index.nosz = 1:M
- allmat = rbind(if(A) Amat else NULL,
- if(C) Cmat else NULL,
- if(scores) nuhat else NULL)
+ allmat = rbind(if (A) Amat else NULL,
+ if (C) Cmat else NULL,
+ if (scores) nuhat else NULL)
plot(allmat[,1], allmat[,2], type="n",
xlab=xlab, ylab=ylab, ...) # xlim etc. supplied through ...
- if(A) {
+ if (A) {
Aadj = rep(Aadj, len=length(index.nosz))
Acex = rep(Acex, len=length(index.nosz))
Acol = rep(Acol, len=length(index.nosz))
- if(length(Alabels) != M) stop("'Alabels' must be of length ", M)
- if(length(Apch)) {
+ if (length(Alabels) != M) stop("'Alabels' must be of length ", M)
+ if (length(Apch)) {
Apch = rep(Apch, len=length(index.nosz))
for(i in index.nosz)
points(Amat[i,1],Amat[i,2],pch=Apch[i],cex=Acex[i],col=Acol[i])
@@ -2286,7 +2277,7 @@ lvplot.rrvglm = function(object,
}
}
- if(C) {
+ if (C) {
p2 = nrow(Cmat)
gapC = rep(gapC, len=p2)
Cadj = rep(Cadj, len=p2)
@@ -2294,7 +2285,7 @@ lvplot.rrvglm = function(object,
Ccol = rep(Ccol, len=p2)
Clwd = rep(Clwd, len=p2)
Clty = rep(Clty, len=p2)
- if(length(Clabels) != p2)
+ if (length(Clabels) != p2)
stop("'length(Clabels)' must be equal to ", p2)
for(ii in 1:p2) {
arrows(0, 0, Cmat[ii,1], Cmat[ii,2],
@@ -2305,33 +2296,33 @@ lvplot.rrvglm = function(object,
}
}
- if(scores) {
+ if (scores) {
ugrp = unique(groups)
nlev = length(ugrp) # number of groups
clty = rep(clty, len=nlev)
clwd = rep(clwd, len=nlev)
ccol = rep(ccol, len=nlev)
- if(length(spch))
+ if (length(spch))
spch = rep(spch, len=n)
scol = rep(scol, len=n)
scex = rep(scex, len=n)
for(ii in ugrp) {
gp = groups == ii
- if(nlev > 1 && (length(unique(spch[gp])) != 1 ||
+ if (nlev > 1 && (length(unique(spch[gp])) != 1 ||
length(unique(scol[gp])) != 1 ||
length(unique(scex[gp])) != 1))
warning("spch/scol/scex is different for individuals ",
"from the same group")
temp = nuhat[gp,,drop=FALSE]
- if(length(spch)) {
+ if (length(spch)) {
points(temp[,1], temp[,2], cex=scex[gp], pch=spch[gp],
col=scol[gp])
} else {
text(temp[,1], temp[,2], label=slabels, cex=scex[gp],
col=scol[gp])
}
- if(chull.arg) {
+ 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],
@@ -2356,7 +2347,7 @@ Coef.rrvglm <- function(object, ...) {
p1 = length(colx1.index)
Amat <- object at constraints[[colx2.index[1]]]
- B1mat = if(p1) coefvlm(object, mat=TRUE)[colx1.index,,drop=FALSE] else NULL
+ B1mat = if (p1) coefvlm(object, mat=TRUE)[colx1.index,,drop=FALSE] else NULL
C.try <- coefvlm(object, mat= TRUE)[colx2.index,,drop=FALSE]
@@ -2366,7 +2357,7 @@ Coef.rrvglm <- function(object, ...) {
Rank = object at control$Rank
- lv.names = if(Rank>1) paste("lv", 1:Rank, sep="") else "lv"
+ lv.names = if (Rank>1) paste("lv", 1:Rank, sep="") else "lv"
dimnames(Amat) = list(object at misc$predictors.names, lv.names)
dimnames(Cmat) = list(dimnames(Cmat)[[1]], lv.names)
@@ -2377,7 +2368,7 @@ Coef.rrvglm <- function(object, ...) {
Rank = Rank,
colx1.index = colx1.index,
colx2.index = colx2.index)
- if(object at control$Corner)
+ if (object at control$Corner)
ans at Atilde = Amat[-c(object at control$Index.corner,
object at control$Structural.zero),,drop=FALSE]
ans
@@ -2389,23 +2380,20 @@ printCoef.rrvglm = function(x, ...) {
object = x
- cat("\nA matrix:\n")
+ cat("A matrix:\n")
print(object at A, ...)
- cat("\n")
cat("\nC matrix:\n")
print(object at C, ...)
- cat("\n")
cat("\nB1 matrix:\n")
print(object at B1, ...)
- cat("\n")
invisible(object)
}
-if(!isGeneric("biplot"))
+ if (!isGeneric("biplot"))
setGeneric("biplot", function(x, ...) standardGeneric("biplot"))
@@ -2441,7 +2429,7 @@ summary.qrrvglm = function(object,
answer at post$Coef = Coef(object, varlvI = varlvI, reference = reference,
...) # Store it here; non-elegant
- if(length((answer at post$Coef)@dispersion) &&
+ if (length((answer at post$Coef)@dispersion) &&
length(object at misc$estimated.dispersion) &&
object at misc$estimated.dispersion)
answer at dispersion =
@@ -2450,6 +2438,8 @@ summary.qrrvglm = function(object,
as(answer, "summary.qrrvglm")
}
+
+
printsummary.qrrvglm = function(x, ...) {
@@ -2459,15 +2449,15 @@ printsummary.qrrvglm = function(x, ...) {
print(x at post$Coef, ...) # non-elegant programming
- if(length(x at dispersion) > 1) {
+ if (length(x at dispersion) > 1) {
cat("\nDispersion parameters:\n")
- if(length(x at misc$ynames)) {
+ if (length(x at misc$ynames)) {
names(x at dispersion) = x at misc$ynames
print(x at dispersion, ...)
} else
cat(x at dispersion, fill=TRUE)
cat("\n")
- } else if(length(x at dispersion) == 1) {
+ } else if (length(x at dispersion) == 1) {
cat("\nDispersion parameter: ", x at dispersion, "\n")
}
@@ -2509,23 +2499,23 @@ grc = function(y, Rank=1, Index.corner=2:(1+Rank), Structural.zero=1,
myrrcontrol = rrvglm.control(Rank=Rank, Index.corner=Index.corner,
Structural.zero = Structural.zero, ...)
object.save = y
- if(is(y, "rrvglm")) {
+ if (is(y, "rrvglm")) {
y = object.save at y
} else {
y = as.matrix(y)
y = as(y, "matrix")
}
- if(length(dim(y)) != 2 || nrow(y) < 3 || ncol(y) < 3)
+ 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")
ei = function(i, n) diag(n)[,i,drop=FALSE]
.grc.df = data.frame(Row2 = ei(2, nrow(y)))
- yn1 = if(length(dimnames(y)[[1]])) dimnames(y)[[1]] else
+ yn1 = if (length(dimnames(y)[[1]])) dimnames(y)[[1]] else
paste("x2", 1:nrow(y), sep="")
warn.save = options()$warn
options(warn=-3) # Suppress the warnings (hopefully, temporarily)
- if(any(!is.na(as.numeric(substring(yn1, 1, 1)))))
+ if (any(!is.na(as.numeric(substring(yn1, 1, 1)))))
yn1 = paste("x2", 1:nrow(y), sep="")
options(warn=warn.save)
@@ -2548,12 +2538,12 @@ grc = function(y, Rank=1, Index.corner=2:(1+Rank), Structural.zero=1,
.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]])
str1 = "~ Row2"
- if(nrow(y)>2)
+ if (nrow(y)>2)
for(ii in 3:nrow(y))
str1 = paste(str1, paste("Row", ii, sep=""), sep=" + ")
for(ii in 2:ncol(y))
@@ -2567,12 +2557,12 @@ grc = function(y, Rank=1, Index.corner=2:(1+Rank), Structural.zero=1,
warn.save = options()$warn
options(warn=-3) # Suppress the warnings (hopefully, temporarily)
- answer = if(is(object.save, "rrvglm")) object.save else
+ answer = if (is(object.save, "rrvglm")) object.save else
rrvglm(as.formula(str2), fam=poissonff,
constraints=cms, control=myrrcontrol, data=.grc.df)
options(warn=warn.save)
- if(summary.arg) {
+ if (summary.arg) {
answer = as(answer, "rrvglm")
answer = summary.rrvglm(answer, h.step=h.step)
@@ -2580,7 +2570,7 @@ grc = function(y, Rank=1, Index.corner=2:(1+Rank), Structural.zero=1,
answer = as(answer, "grc")
}
- if(exists(".grc.df", envir = VGAMenv))
+ if (exists(".grc.df", envir = VGAMenv))
rm(".grc.df", envir = VGAMenv)
answer
@@ -2610,51 +2600,51 @@ trplot.qrrvglm = function(object,
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")
+ if (coef.obj at Rank != 1) stop("object must be a rank-1 model")
fv = fitted(object)
modelno = object at control$modelno # 1,2,3, or 0
NOS = ncol(fv) # Number of species
M = object at misc$M #
nn = nrow(fv) # Number of sites
- if(length(sitenames))
+ if (length(sitenames))
sitenames = rep(sitenames, len=nn)
sppNames = dimnames(object at y)[[2]]
- if(!length(whichSpecies)) {
+ if (!length(whichSpecies)) {
whichSpecies = sppNames[1:NOS]
whichSpecies.numer = 1:NOS
} else
- if(is.numeric(whichSpecies)) {
+ if (is.numeric(whichSpecies)) {
whichSpecies.numer = whichSpecies
whichSpecies = sppNames[whichSpecies.numer] # Convert to character
} else
whichSpecies.numer = match(whichSpecies, sppNames)
nos = length(whichSpecies) # nos = number of species to be plotted
- if(length(whichSpecies.numer) <= 1)
+ if (length(whichSpecies.numer) <= 1)
stop("must have at least 2 species to be plotted")
cx1i = object at control$colx1.index
- if(check.ok)
- if(!(length(cx1i)==1 && names(cx1i)=="(Intercept)"))
+ if (check.ok)
+ if (!(length(cx1i)==1 && names(cx1i)=="(Intercept)"))
stop("trajectory plots allowable only for Norrr = ~ 1 models")
first.spp = iam(1,1,M=M,both=TRUE,diag=FALSE)$row.index
second.spp = iam(1,1,M=M,both=TRUE,diag=FALSE)$col.index
- myxlab = if(length(whichSpecies.numer)==2) {
+ 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) {
+ 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
- if(!add) {
- xxx = if(axes.equal) fv[,whichSpecies.numer] else
+ myylab = if (length(ylab)) ylab else myylab
+ if (!add) {
+ xxx = if (axes.equal) fv[,whichSpecies.numer] else
fv[,whichSpecies.numer[first.spp]]
- yyy = if(axes.equal) fv[,whichSpecies.numer] else
+ yyy = if (axes.equal) fv[,whichSpecies.numer] else
fv[,whichSpecies.numer[second.spp]]
matplot(xxx, yyy, type="n", log=log, xlab=myxlab,
ylab=myylab, main=main, ...)
@@ -2669,10 +2659,10 @@ trplot.qrrvglm = function(object,
ii = 0
col = rep(col, length=nos*(nos-1)/2)
species.names = NULL
- if(plot.it)
+ if (plot.it)
for(i1 in seq(whichSpecies.numer)) {
for(i2 in seq(whichSpecies.numer))
- if(i1 < i2) {
+ if (i1 < i2) {
ii = ii + 1
species.names = rbind(species.names,
cbind(sppNames[i1], sppNames[i2]))
@@ -2680,8 +2670,8 @@ trplot.qrrvglm = function(object,
fv[oo,whichSpecies.numer[i2]],
type=type, add=TRUE,
lty=lty[ii], lwd=lwd[ii], col=col[ii],
- pch = if(label.sites) " " else "*" )
- if(label.sites && length(sitenames))
+ pch = if (label.sites) " " else "*" )
+ if (label.sites && length(sitenames))
text(fv[oo,whichSpecies.numer[i1]],
fv[oo,whichSpecies.numer[i2]],
labels=sitenames[oo], cex=cex, col=tcol[ii])
@@ -2691,7 +2681,7 @@ trplot.qrrvglm = function(object,
sitenames=sitenames[oo]))
}
-if(!isGeneric("trplot"))
+ if (!isGeneric("trplot"))
setGeneric("trplot", function(object, ...) standardGeneric("trplot"))
setMethod("trplot", "qrrvglm", function(object, ...) trplot.qrrvglm(object, ...))
@@ -2707,32 +2697,32 @@ 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,
len=M), ...) {
stop("this function is not yet completed")
- if(mode(MaxScale) != "character" && mode(MaxScale) != "name")
+ if (mode(MaxScale) != "character" && mode(MaxScale) != "name")
MaxScale <- as.character(substitute(MaxScale))
MaxScale <- match.arg(MaxScale, c("predictors", "response"))[1]
- if(MaxScale != "predictors")
+ if (MaxScale != "predictors")
stop("can currently only handle MaxScale='predictors'")
sobj = summary(object)
cobj = Coef(object, ITolerances = ITolerances, ...)
M = nrow(cobj at A)
dispersion = rep(dispersion, len=M)
- if(cobj at Rank != 1)
+ if (cobj at Rank != 1)
stop("object must be a rank 1 model")
dvecMax = cbind(1, -0.5 * cobj at A / c(cobj at D), (cobj at A / c(2*cobj at D))^2)
dvecTol = cbind(0, 0, 1 / c(-2 * cobj at D)^1.5)
dvecOpt = cbind(0, -0.5 / c(cobj at D), 0.5 * cobj at A / c(cobj at D^2))
- if((length(object at control$colx1.index) != 1) ||
+ 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.
- if(all(length(coef(object)) != okvals))
+ if (all(length(coef(object)) != okvals))
stop("Can only handle intercepts-only model with EqualTolerances=FALSE")
answer = NULL
@@ -2752,10 +2742,10 @@ vcovqrrvglm = function(object,
c(se2Opt=se2Opt, se2Tol=se2Tol, se2Max=se2Max))
}
- link.function = if(MaxScale=="predictors")
+ link.function = if (MaxScale=="predictors")
remove.arg(object at misc$predictors.names[1]) else ""
dimnames(answer) = list(dimnames(cobj at D)[[3]], c("Optimum", "Tolerance",
- if(nchar(link.function)) paste(link.function,"(Maximum)",sep="") else
+ if (nchar(link.function)) paste(link.function,"(Maximum)",sep="") else
"Maximum"))
NAthere = is.na(answer %*% rep(1, len=3))
answer[NAthere,] = NA # NA in tolerance means NA everywhere else
@@ -2781,7 +2771,7 @@ setClass(Class="vcov.qrrvglm", representation(
model.matrix.qrrvglm <- function(object, type=c("lv", "vlm"), ...) {
- if(mode(type) != "character" && mode(type) != "name")
+ if (mode(type) != "character" && mode(type) != "name")
type = as.character(substitute(type))
type = match.arg(type, c("lv","vlm"))[1]
@@ -2800,43 +2790,43 @@ setMethod("model.matrix", "qrrvglm", function(object, ...)
persp.qrrvglm = 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),
+ gridlength = if (Rank == 1) 301 else c(51,51),
whichSpecies = NULL,
- xlab = if(Rank==1) "Latent Variable" else "Latent Variable 1",
- ylab = if(Rank==1) "Expected Value" else "Latent Variable 2",
+ xlab = if (Rank==1) "Latent Variable" else "Latent Variable 1",
+ ylab = if (Rank==1) "Expected Value" else "Latent Variable 2",
zlab="Expected value",
labelSpecies = FALSE, # For Rank==1 only
stretch = 1.05, # quick and dirty, Rank==1 only
main="",
ticktype = "detailed",
- col = if(Rank==1) par()$col else "white",
+ 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)
- if((Rank <- coef.obj at Rank) > 2)
+ if ((Rank <- coef.obj at Rank) > 2)
stop("object must be a rank-1 or rank-2 model")
fv = fitted(object)
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)
- if(!length(oylim)) {
- ylim = if(Rank==1) c(0, max(fv)*stretch) else
+ 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)
}
gridlength = rep(gridlength, length=Rank)
lv1 = seq(xlim[1], xlim[2], length=gridlength[1])
- if(Rank==1) {
+ if (Rank==1) {
m = cbind(lv1)
} else {
lv2 = seq(ylim[1], ylim[2], length=gridlength[2])
m = expand.grid(lv1,lv2)
}
- if(dim(coef.obj at B1)[1] != 1 || dimnames(coef.obj at B1)[[1]] != "(Intercept)")
+ if (dim(coef.obj at B1)[1] != 1 || dimnames(coef.obj at B1)[[1]] != "(Intercept)")
stop("Norrr = ~ 1 is needed")
LP = coef.obj at A %*% t(cbind(m)) # M by n
LP = LP + c(coef.obj at B1) # Assumes \bix_1 = 1 (intercept only)
@@ -2855,30 +2845,30 @@ persp.qrrvglm = function(x, varlvI = FALSE, reference = NULL,
fitvals = object at family@inverse(LP) # n by NOS
dimnames(fitvals) = list(NULL, dimnames(fv)[[2]])
sppNames = dimnames(object at y)[[2]]
- if(!length(whichSpecies)) {
+ if (!length(whichSpecies)) {
whichSpecies = sppNames[1:NOS]
whichSpecies.numer = 1:NOS
} else
- if(is.numeric(whichSpecies)) {
+ if (is.numeric(whichSpecies)) {
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))
+ if (Rank==1) {
+ if (plot.it) {
+ if (!length(oylim))
ylim = c(0, max(fitvals[,whichSpecies.numer])*stretch) # A revision
col = rep(col, len=length(whichSpecies.numer))
llty = rep(llty, leng=length(whichSpecies.numer))
llwd = rep(llwd, leng=length(whichSpecies.numer))
- if(!add1)
+ if (!add1)
matplot(lv1, fitvals, xlab=xlab, ylab=ylab, type="n",
main=main, xlim=xlim, ylim=ylim, ...)
for(j in 1:length(whichSpecies.numer)) {
ptr2 = whichSpecies.numer[j] # points to species column
lines(lv1, fitvals[,ptr2], col=col[j],
lty=llty[j], lwd=llwd[j], ...)
- if(labelSpecies) {
+ if (labelSpecies) {
ptr1=(1:nrow(fitvals))[max(fitvals[,ptr2])==fitvals[,ptr2]]
ptr1 = ptr1[1]
text(lv1[ptr1], fitvals[ptr1,ptr2]+
@@ -2889,15 +2879,15 @@ persp.qrrvglm = function(x, varlvI = FALSE, reference = NULL,
}
} else {
maxfitted = matrix(fitvals[,whichSpecies[1]], length(lv1), length(lv2))
- if(length(whichSpecies) > 1)
+ if (length(whichSpecies) > 1)
for(j in whichSpecies[-1]) {
maxfitted = pmax(maxfitted, matrix(fitvals[,j],
length(lv1), length(lv2)))
}
- if(!length(zlim))
+ if (!length(zlim))
zlim = range(maxfitted, na.rm = TRUE)
- if(plot.it)
+ if (plot.it)
graphics:::persp.default(lv1, lv2, maxfitted,
zlim=zlim,
xlab=xlab, ylab=ylab, zlab=zlab,
@@ -2906,11 +2896,11 @@ persp.qrrvglm = function(x, varlvI = FALSE, reference = NULL,
invisible(list(fitted=fitvals,
lv1grid=lv1,
- lv2grid=if(Rank==2) lv2 else NULL,
- maxfitted=if(Rank==2) maxfitted else NULL))
+ lv2grid = if (Rank==2) lv2 else NULL,
+ maxfitted = if (Rank==2) maxfitted else NULL))
}
-if(!isGeneric("persp"))
+ if (!isGeneric("persp"))
setGeneric("persp", function(x, ...) standardGeneric("persp"))
setMethod("persp", "qrrvglm", function(x, ...) persp.qrrvglm(x=x, ...))
@@ -2922,7 +2912,7 @@ ccoef.qrrvglm = function(object, varlvI = FALSE, reference = NULL, ...) {
}
ccoef.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 C
}
@@ -2932,12 +2922,12 @@ lv.qrrvglm <- function(object, varlvI = FALSE, reference = NULL, ...) {
lv.rrvglm = function(object, ...) {
ans = lvplot(object, plot.it=FALSE)
- if(ncol(ans) == 1) dimnames(ans) = list(dimnames(ans)[[1]], "lv")
+ 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
}
@@ -2946,8 +2936,8 @@ Max.qrrvglm = function(object, varlvI = FALSE, reference = NULL, ...) {
}
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, ...)
}
@@ -2956,7 +2946,7 @@ Opt.qrrvglm = function(object, varlvI = FALSE, reference = NULL, ...) {
}
Opt.Coef.qrrvglm = function(object, ...) {
- if(length(list(...))) warning("Too late! Ignoring the extra arguments")
+ if (length(list(...))) warning("Too late! Ignoring the extra arguments")
Coef(object, ...)@Optimum
}
@@ -2965,13 +2955,13 @@ 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
+ if (length(list(...))) warning("Too late! Ignoring the extra arguments")
+ if (any(slotNames(object) == "Tolerance")) object at Tolerance else
Tol(object, ...)
}
-if(!isGeneric("ccoef"))
+ 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, ...))
@@ -2981,24 +2971,24 @@ setMethod("ccoef", "Coef.qrrvglm", function(object, ...) ccoef.Coef.qrrvglm(obje
setMethod("coef", "qrrvglm", function(object, ...) Coef.qrrvglm(object, ...))
setMethod("coefficients", "qrrvglm", function(object, ...) Coef.qrrvglm(object, ...))
-if(!isGeneric("lv"))
+ 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, ...))
-if(!isGeneric("Max"))
+ 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, ...))
-if(!isGeneric("Opt"))
+ 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, ...))
-if(!isGeneric("Tol"))
+ 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, ...))
@@ -3021,7 +3011,7 @@ is.bell.rrvglm <- function(object, ...) {
M = object at misc$M
ynames = object at misc$ynames
ans = rep(FALSE, len=M)
- if(length(ynames)) names(ans) = ynames
+ if (length(ynames)) names(ans) = ynames
ans
}
@@ -3034,7 +3024,7 @@ is.bell.cao <- function(object, ...) {
NA * Max(object, ...)
}
-if(!isGeneric("is.bell"))
+ 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,...))
diff --git a/R/family.survival.q b/R/family.survival.R
similarity index 79%
rename from R/family.survival.q
rename to R/family.survival.R
index f398cd0..2a78d10 100644
--- a/R/family.survival.q
+++ b/R/family.survival.R
@@ -1,5 +1,5 @@
# These functions are
-# Copyright (C) 1998-2009 T.W. Yee, University of Auckland. All rights reserved.
+# Copyright (C) 1998-2010 T.W. Yee, University of Auckland. All rights reserved.
@@ -13,11 +13,11 @@
earg=list(),
isd=NULL, zero=NULL)
{
- if(!is.Numeric(r1, allow=1, integ=TRUE) || r1<0) stop("bad input for r1")
- if(!is.Numeric(r2, allow=1, integ=TRUE) || r2<0) stop("bad input for r2")
- if(mode(link.sd) != "character" && mode(link.sd) != "name")
+ if (!is.Numeric(r1, allow=1, integ=TRUE) || r1<0) stop("bad input for r1")
+ if (!is.Numeric(r2, allow=1, integ=TRUE) || r2<0) stop("bad input for r2")
+ if (mode(link.sd) != "character" && mode(link.sd) != "name")
link.sd = as.character(substitute(link.sd))
- if(!is.list(earg)) earg = list()
+ if (!is.list(earg)) earg = list()
new("vglmff",
blurb=c("Univariate Normal distribution with double censoring\n\n",
@@ -31,16 +31,16 @@
initialize=eval(substitute(expression({
predictors.names =
c("mean", namesof("sd", .link.sd, earg=.earg, tag= FALSE))
- if(ncol(y <- cbind(y)) != 1)
+ if (ncol(y <- cbind(y)) != 1)
stop("the response must be a vector or a one-column matrix")
- if(length(w) != n || !is.Numeric(w, integ=TRUE, posit=TRUE))
+ if (length(w) != n || !is.Numeric(w, integ=TRUE, posit=TRUE))
stop("the argument 'weights' must be a vector ",
"of positive integers")
sumw = sum(w)
extra$bign = sumw + .r1 + .r2 # Tot num of censored & uncensored obsns
- if(!length(etastart)) {
- sd.y.est = if(length(.isd)) rep(.isd, len=n) else {
- junk = if(is.R()) lm.wfit(x=x, y=y, w=w) else
+ if (!length(etastart)) {
+ sd.y.est = if (length(.isd)) rep(.isd, len=n) else {
+ junk = if (is.R()) lm.wfit(x=x, y=y, w=w) else
lm.wfit(x=x, y=y, w=w, method="qr")
1.25 * sqrt( sum(w * junk$resid^2) / junk$df.residual )
}
@@ -61,7 +61,7 @@
loglikelihood=eval(substitute(
function(mu,y,w,residuals= FALSE,eta, extra=NULL) {
sd = eta2theta(eta[,2], .link.sd, earg=.earg)
- if(residuals) stop("loglikelihood residuals not implemented yet") else
+ if (residuals) stop("loglikelihood residuals not implemented yet") else
sum(w * (-log(sd) - 0.5 * ((y - mu)/sd)^2)) +
(if(.r1==0) 0 else {z1=min((y-mu)/sd); Fz1=pnorm(z1); .r1*log(Fz1)}) +
(if(.r2==0) 0 else {z2=max((y-mu)/sd); Fz2=pnorm(z2); .r2*log1p(-Fz2)})
@@ -73,12 +73,12 @@
q1 = .r1 / extra$bign
q2 = .r2 / extra$bign
pee = 1 - q1 - q2 # 1 if r1==r2==0
- z1 = if(.r1 == 0) -100 else min((y - mu) / sd) # 100==Inf
- z2 = if(.r2 == 0) +100 else max((y - mu) / sd) # 100==Inf
- fz1 = if(.r1 == 0) 0 else dnorm(z1)
- fz2 = if(.r2 == 0) 0 else dnorm(z2)
- Fz1 = if(.r1 == 0) 0.02 else pnorm(z1) # 0/0 undefined
- Fz2 = if(.r2 == 0) 0.99 else pnorm(z2)
+ z1 = if (.r1 == 0) -100 else min((y - mu) / sd) # 100==Inf
+ z2 = if (.r2 == 0) +100 else max((y - mu) / sd) # 100==Inf
+ fz1 = if (.r1 == 0) 0 else dnorm(z1)
+ fz2 = if (.r2 == 0) 0 else dnorm(z2)
+ Fz1 = if (.r1 == 0) 0.02 else pnorm(z1) # 0/0 undefined
+ Fz2 = if (.r2 == 0) 0.99 else pnorm(z2)
dl.dmu = (y-mu) / sd^2 +
((- .r1 * fz1/Fz1 + .r2 * fz2/(1-Fz2)) / sd) / (n*w)
dl.dsd = -1/sd + (y-mu)^2 / sd^3 +
@@ -111,7 +111,7 @@
dbisa = function(x, shape, scale=1, log = FALSE) {
- if(!is.logical(log.arg <- log))
+ if (!is.logical(log.arg <- log))
stop("bad input for argument 'log'")
rm(log)
@@ -125,13 +125,13 @@ dbisa = function(x, shape, scale=1, log = FALSE) {
0.5 * log(x[xok]) - 0.5 * log(scale[xok])
logdensity[scale <= 0] = NaN
logdensity[shape <= 0] = NaN
- if(log.arg) logdensity else exp(logdensity)
+ if (log.arg) logdensity else exp(logdensity)
}
pbisa = function(q, shape, scale=1) {
- if(!is.Numeric(q)) stop("bad input for argument 'q'")
- if(!is.Numeric(shape, pos=TRUE)) stop("bad input for argument 'shape'")
- if(!is.Numeric(scale, pos=TRUE)) stop("bad input for argument 'scale'")
+ if (!is.Numeric(q)) stop("bad input for argument 'q'")
+ if (!is.Numeric(shape, pos=TRUE)) stop("bad input for argument 'shape'")
+ if (!is.Numeric(scale, pos=TRUE)) stop("bad input for argument 'scale'")
ans = pnorm(((temp <- sqrt(q/scale)) - 1/temp) / shape)
ans[scale < 0 | shape < 0] = NA
ans[q <= 0] = 0
@@ -139,10 +139,10 @@ pbisa = function(q, shape, scale=1) {
}
qbisa = function(p, shape, scale=1) {
- if(!is.Numeric(p, posit=TRUE) || any(p >= 1))
+ if (!is.Numeric(p, posit=TRUE) || any(p >= 1))
stop("argument 'p' must have values inside the interval (0,1)")
- if(!is.Numeric(shape, pos=TRUE)) stop("bad input for argument 'shape'")
- if(!is.Numeric(scale, pos=TRUE)) stop("bad input for argument 'scale'")
+ if (!is.Numeric(shape, pos=TRUE)) stop("bad input for argument 'shape'")
+ if (!is.Numeric(scale, pos=TRUE)) stop("bad input for argument 'scale'")
A = qnorm(p)
temp1 = A * shape * sqrt(4 + A^2 * shape^2)
ans1 = (2 + A^2 * shape^2 + temp1) * scale / 2
@@ -151,8 +151,8 @@ qbisa = function(p, shape, scale=1) {
}
rbisa = function(n, shape, scale=1) {
- use.n = if((length.n <- length(n)) > 1) length.n else
- if(!is.Numeric(n, integ=TRUE, allow=1, posit=TRUE))
+ use.n = if ((length.n <- length(n)) > 1) length.n else
+ if (!is.Numeric(n, integ=TRUE, allow=1, posit=TRUE))
stop("bad input for argument 'n'") else n
A = rnorm(use.n)
@@ -175,19 +175,19 @@ rbisa = function(n, shape, scale=1) {
ishape = NULL, iscale=1,
method.init=1, zero=NULL)
{
- if(mode(lshape) != "character" && mode(lshape) != "name")
+ if (mode(lshape) != "character" && mode(lshape) != "name")
lshape = as.character(substitute(lshape))
- if(mode(lscale) != "character" && mode(lscale) != "name")
+ if (mode(lscale) != "character" && mode(lscale) != "name")
lscale = as.character(substitute(lscale))
- if(length(ishape) && !is.Numeric(ishape, posit=TRUE))
+ if (length(ishape) && !is.Numeric(ishape, posit=TRUE))
stop("bad input for argument 'ishape'")
- if(!is.Numeric(iscale, posit=TRUE))
+ if (!is.Numeric(iscale, posit=TRUE))
stop("bad input for argument 'iscale'")
- if(!is.Numeric(method.init, allow=1, integ=TRUE, posit=TRUE) ||
+ if (!is.Numeric(method.init, allow=1, integ=TRUE, posit=TRUE) ||
method.init > 3)
stop("method.init must be 1 or 2 or 3")
- if(!is.list(eshape)) eshape = list()
- if(!is.list(escale)) escale = list()
+ if (!is.list(eshape)) eshape = list()
+ if (!is.list(escale)) escale = list()
new("vglmff",
blurb=c("Birnbaum-Saunders distribution\n\n",
@@ -198,18 +198,18 @@ rbisa = function(n, shape, scale=1) {
constraints = cm.zero.vgam(constraints, x, .zero, M)
}) , list( .zero=zero))),
initialize=eval(substitute(expression({
- if(ncol(y <- cbind(y)) != 1)
+ if (ncol(y <- cbind(y)) != 1)
stop("the response must be a vector or a one-column matrix")
predictors.names = c(namesof("shape", .lshape,earg= .eshape,tag=FALSE),
namesof("scale", .lscale, tag=FALSE))
- if(!length(etastart)) {
+ if (!length(etastart)) {
scale.init = rep( .iscale, len=n)
- shape.init = if(is.Numeric( .ishape)) rep( .ishape, len=n) else {
- if( .method.init==1) {
+ shape.init = if (is.Numeric( .ishape)) rep( .ishape, len=n) else {
+ if ( .method.init==1) {
ybar = rep(weighted.mean(y, w), len=n)
ybarr = rep(1 / weighted.mean(1/y, w), len=n) # Reqrs y > 0
sqrt(ybar / scale.init + scale.init / ybarr - 2)
- } else if( .method.init==2) {
+ } else if ( .method.init==2) {
sqrt(2*( pmax(y, scale.init+0.1) / scale.init - 1))
} else {
ybar = rep(weighted.mean(y, w), len=n)
@@ -239,7 +239,7 @@ rbisa = function(n, shape, scale=1) {
function(mu,y,w,residuals= FALSE,eta, extra=NULL) {
sh = eta2theta(eta[,1], .lshape, earg= .eshape)
sc = eta2theta(eta[,2], .lscale, earg= .escale)
- if(residuals) stop("loglikelihood residuals not implemented yet") else {
+ if (residuals) stop("loglikelihood residuals not implemented yet") else {
sum(w * dbisa(x=y, shape=sh, scale=sc, log = TRUE))
}
} , list( .lshape=lshape, .lscale=lscale,
diff --git a/R/family.ts.q b/R/family.ts.R
similarity index 89%
rename from R/family.ts.q
rename to R/family.ts.R
index efa3e53..a945e46 100644
--- a/R/family.ts.q
+++ b/R/family.ts.R
@@ -1,5 +1,5 @@
# These functions are
-# Copyright (C) 1998-2009 T.W. Yee, University of Auckland. All rights reserved.
+# Copyright (C) 1998-2010 T.W. Yee, University of Auckland. All rights reserved.
@@ -15,21 +15,21 @@
Ak1 <- diag(MM)
for(j in 1:MM) {
for(i in 1:MM) {
- if(i>j && (MM+1)-(Ranks.[j]-1) <= i) {
+ if (i > j && (MM+1)-(Ranks.[j]-1) <= i) {
ptr <- ptr + 1
Ak1[i,j] <- coeffs[ptr]
}
}
}
- if(aa>0 && ptr != aa) stop("something wrong")
+ if (aa > 0 && ptr != aa) stop("something wrong")
Ak1
}
rrar.Di <- function(i, Ranks.) {
- if(Ranks.[1]==Ranks.[i]) diag(Ranks.[i]) else
+ if (Ranks.[1]==Ranks.[i]) diag(Ranks.[i]) else
rbind(diag(Ranks.[i]), matrix(0, Ranks.[1]-Ranks.[i], Ranks.[i]))
}
rrar.Mi <- function(i, MM, Ranks., ki) {
- if(Ranks.[ki[i]]==MM)
+ if (Ranks.[ki[i]]==MM)
return(NULL)
hi <- Ranks.[ki[i]] - Ranks.[ki[i+1]]
Ji <- matrix(0, hi, Ranks.[1])
@@ -50,11 +50,11 @@
Mmat
}
block.diag <- function(A, B) {
- if(is.null(A) && is.null(B))
+ if (is.null(A) && is.null(B))
return(NULL)
- if(!is.null(A) && is.null(B))
+ if (!is.null(A) && is.null(B))
return(A)
- if(is.null(A) && !is.null(B))
+ if (is.null(A) && !is.null(B))
return(B)
A <- as.matrix(A)
@@ -67,7 +67,7 @@
Mmat <- rrar.Mmat(MM, uu, Ranks., ki) # NULL if full rank
Ak1 <- rrar.Ak1(MM, coeffs, Ranks., aa)
- if(!is.null(Mmat))
+ if (!is.null(Mmat))
for(i in 1:plag) {
Di <- rrar.Di(i, Ranks.)
Ci <- rrar.Ci(i, coeffs, aa, Ranks., MM)
@@ -84,7 +84,7 @@
}
rrar.Ut <- function(y, tt, plag, MM) {
Ut <- NULL
- if(plag>1)
+ if (plag>1)
for(i in 1:plag) {
Ut <- rbind(Ut, kronecker(diag(MM), cbind(y[tt-i,])))
}
@@ -108,7 +108,7 @@
rrar.control <- function(stepsize=0.5, save.weight=TRUE, ...)
{
- if(stepsize <= 0 || stepsize > 1) {
+ if (stepsize <= 0 || stepsize > 1) {
warning("bad value of stepsize; using 0.5 instead")
stepsize <- 0.5
}
@@ -136,9 +136,9 @@ rrar <- function(Ranks=1, coefstart=NULL)
copy_X_vlm <- TRUE # X_vlm_save matrix changes at each iteration
dsrank <- -sort(-Ranks.) # ==rev(sort(Ranks.))
- if(any(dsrank != Ranks.))
+ if (any(dsrank != Ranks.))
stop("Ranks must be a non-increasing sequence")
- if(!is.matrix(y) || ncol(y) ==1) {
+ if (!is.matrix(y) || ncol(y) ==1) {
stop("response must be a matrix with more than one column")
} else {
MM <- ncol(y)
@@ -150,23 +150,23 @@ rrar <- function(Ranks=1, coefstart=NULL)
Ranks. <- c(Ranks., 0) # For computing a
aa <- sum( (MM-Ranks.[ki[1:uu]]) * (Ranks.[ki[1:uu]]-Ranks.[ki[-1]]) )
}
- if(!intercept.only)
+ if (!intercept.only)
warning("ignoring explanatory variables")
- if(any(MM < Ranks.))
+ if (any(MM < Ranks.))
stop("'max(Ranks)' can only be ", MM, " or less")
y.save <- y # Save the original
- if(any(w != 1))
+ if (any(w != 1))
stop("all weights should be 1")
new.coeffs <- .coefstart # Needed for iter=1 of $weight
- new.coeffs <- if(length(new.coeffs))
+ new.coeffs <- if (length(new.coeffs))
rep(new.coeffs, len=aa+sum(Ranks.)*MM) else
runif(aa+sum(Ranks.)*MM)
temp8 <- rrar.Wmat(y.save,Ranks.,MM,ki,plag,aa,uu,nn,new.coeffs)
X_vlm_save <- temp8$UU %*% temp8$Ht
- if(!length(etastart)) {
+ if (!length(etastart)) {
etastart <- X_vlm_save %*% new.coeffs
etastart <- matrix(etastart, ncol=ncol(y), byrow=TRUE) # So M=ncol(y)
}
@@ -178,7 +178,7 @@ rrar <- function(Ranks=1, coefstart=NULL)
keep.assign <- attr(x, "assign")
x <- x[-indices,,drop=FALSE]
- if(is.R())
+ if (is.R())
attr(x, "assign") <- keep.assign
y <- y[-indices,,drop=FALSE]
w <- w[-indices]
@@ -252,30 +252,29 @@ rrar <- function(Ranks=1, coefstart=NULL)
+
+
vglm.garma.control <- function(save.weight=TRUE, ...)
{
list(save.weight = as.logical(save.weight)[1])
}
-garma <- function(link=c("identity","loge","reciprocal",
- "logit","probit","cloglog","cauchit"),
+garma <- function(link="identity",
earg=list(),
p.ar.lag=1, q.lag.ma=0,
coefstart=NULL,
step=1.0)
{
- if(mode(link) != "character" && mode(link) != "name")
+ if (mode(link) != "character" && mode(link) != "name")
link = as.character(substitute(link))
- link = match.arg(link, c("identity","loge","reciprocal",
- "logit","probit","cloglog","cauchit"))[1]
- if(!is.Numeric(p.ar.lag, integer=TRUE))
+ if (!is.Numeric(p.ar.lag, integer=TRUE))
stop("bad input for argument 'p.ar.lag'")
- if(!is.Numeric(q.lag.ma, integer=TRUE))
+ if (!is.Numeric(q.lag.ma, integer=TRUE))
stop("bad input for argument 'q.lag.ma'")
- if(q.lag.ma != 0)
+ if (q.lag.ma != 0)
stop("sorry, only q.lag.ma=0 is currently implemented")
- if(!is.list(earg)) earg = list()
+ if (!is.list(earg)) earg = list()
new("vglmff",
blurb=c("GARMA(", p.ar.lag, ",", q.lag.ma, ")\n\n",
@@ -291,7 +290,7 @@ garma <- function(link=c("identity","loge","reciprocal",
copy_X_vlm <- TRUE # x matrix changes at each iteration
- if( .link == "logit" || .link == "probit" || .link == "cloglog" ||
+ if ( .link == "logit" || .link == "probit" || .link == "cloglog" ||
.link == "cauchit") {
delete.zero.colns <- TRUE
eval(process.categorical.data.vgam)
@@ -304,9 +303,9 @@ garma <- function(link=c("identity","loge","reciprocal",
w.save <- w # Save the original
new.coeffs <- .coefstart # Needed for iter=1 of @weight
- new.coeffs <- if(length(new.coeffs)) rep(new.coeffs, len=pp+plag) else
+ new.coeffs <- if (length(new.coeffs)) rep(new.coeffs, len=pp+plag) else
c(runif(pp), rep(0, plag))
- if(!length(etastart)) {
+ if (!length(etastart)) {
etastart <- x[-indices,,drop=FALSE] %*% new.coeffs[1:pp]
}
x <- cbind(x, matrix(as.numeric(NA), n, plag)) # Right size now
@@ -315,7 +314,7 @@ garma <- function(link=c("identity","loge","reciprocal",
dimnames(x) <- list(dx[[1]], c(dx[[2]], morenames))
x <- x[-indices,,drop=FALSE]
- class(x) = if(is.R()) "matrix" else "model.matrix" # Added 27/2/02; 26/2/04
+ class(x) = if (is.R()) "matrix" else "model.matrix" # Added 27/2/02; 26/2/04
y <- y[-indices]
w <- w[-indices]
n.save <- n <- n - plag
@@ -335,7 +334,7 @@ garma <- function(link=c("identity","loge","reciprocal",
}), list( .link=link, .earg=earg ))),
loglikelihood=eval(substitute(
function(mu, y, w, residuals = FALSE, eta, extra=NULL) {
- if(residuals) switch( .link,
+ if (residuals) switch( .link,
identity=y-mu,
loge=w*(y/mu - 1),
inverse=w*(y/mu - 1),
@@ -377,7 +376,7 @@ garma <- function(link=c("identity","loge","reciprocal",
}
class(x)=if(is.R()) "matrix" else "model.matrix" # Added 27/2/02; 26/2/04
- if(iter==1)
+ if (iter==1)
old.coeffs <- new.coeffs
X_vlm_save <- lm2vlm.model.matrix(x, Blist, xij=control$xij)
@@ -397,7 +396,7 @@ garma <- function(link=c("identity","loge","reciprocal",
-if(FALSE) {
+ if (FALSE) {
setClass(Class="Coef.rrar", representation(
"plag" = "integer",
"Ranks" = "integer",
diff --git a/R/family.univariate.q b/R/family.univariate.R
similarity index 81%
rename from R/family.univariate.q
rename to R/family.univariate.R
index 0bdae67..ee74d79 100644
--- a/R/family.univariate.q
+++ b/R/family.univariate.R
@@ -1,5 +1,5 @@
# These functions are
-# Copyright (C) 1998-2009 T.W. Yee, University of Auckland. All rights reserved.
+# Copyright (C) 1998-2010 T.W. Yee, University of Auckland. All rights reserved.
@@ -24,19 +24,19 @@
getMaxMin = function(vov, objfun, y, x, w, extraargs=NULL, maximize=TRUE,
abs.arg=FALSE) {
- if(!is.vector(vov)) stop("'vov' must be a vector")
+ if (!is.vector(vov)) stop("'vov' must be a vector")
objvals = vov
for(ii in 1:length(vov))
objvals[ii] = objfun(vov[ii], y=y, x=x, w=w, extraargs=extraargs)
- try.this = if(abs.arg) {
- if(maximize) vov[abs(objvals) == max(abs(objvals))] else
+ try.this = if (abs.arg) {
+ if (maximize) vov[abs(objvals) == max(abs(objvals))] else
vov[abs(objvals) == min(abs(objvals))]
} else {
- if(maximize) vov[objvals == max(objvals)] else
+ if (maximize) vov[objvals == max(objvals)] else
vov[objvals == min(objvals)]
}
- if(!length(try.this)) stop("something has gone wrong!")
- if(length(try.this) == 1) try.this else sample(try.this, size=1)
+ if (!length(try.this)) stop("something has gone wrong!")
+ if (length(try.this) == 1) try.this else sample(try.this, size=1)
}
@@ -47,17 +47,17 @@ getMaxMin = function(vov, objfun, y, x, w, extraargs=NULL, maximize=TRUE,
enu=if(lnu == "logoff") list(offset=0.5) else list(),
zero=NULL)
{
- if(mode(ltheta) != "character" && mode(ltheta) != "name")
+ if (mode(ltheta) != "character" && mode(ltheta) != "name")
ltheta = as.character(substitute(ltheta))
- if(mode(lnu) != "character" && mode(lnu) != "name")
+ if (mode(lnu) != "character" && mode(lnu) != "name")
lnu = as.character(substitute(lnu))
- if(length(zero) && !is.Numeric(zero, integer=TRUE, posit=TRUE))
+ if (length(zero) && !is.Numeric(zero, integer=TRUE, posit=TRUE))
stop("bad input for argument 'zero'")
- if(!is.list(etheta)) etheta = list()
- if(!is.list(enu)) enu = list()
+ if (!is.list(etheta)) etheta = list()
+ if (!is.list(enu)) enu = list()
new("vglmff",
- blurb=c("McCullagh (1989)'s distribution \n",
+ blurb = c("McCullagh (1989)'s distribution \n",
"f(y) = (1-2*theta*y+theta^2)^(-nu) * [1 - y^2]^(nu-1/2) /\n",
" Beta[nu+1/2, 1/2], ",
" -1 < y < 1, -1 < theta < 1, nu > -1/2\n",
@@ -72,13 +72,13 @@ getMaxMin = function(vov, objfun, y, x, w, extraargs=NULL, maximize=TRUE,
}), list( .zero=zero ))),
initialize=eval(substitute(expression({
y = as.numeric(y)
- if(any(y <= -1 | y >= 1))
+ if (any(y <= -1 | y >= 1))
stop("all y values must be in (-1,1)")
predictors.names= 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 {
+ if (!length(etastart)) {
+ 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)
@@ -104,7 +104,7 @@ getMaxMin = function(vov, objfun, y, x, w, extraargs=NULL, maximize=TRUE,
nu*Theta/(1+nu)
}, list( .ltheta=ltheta, .lnu=lnu,
.etheta = etheta, .enu=enu ))),
- last=eval(substitute(expression({
+ last = eval(substitute(expression({
misc$link = c("theta"= .ltheta, "nu"= .lnu)
misc$earg = list(theta = .etheta, nu= .enu )
}), list( .ltheta=ltheta, .lnu=lnu, .etheta = etheta, .enu=enu ))),
@@ -112,7 +112,7 @@ getMaxMin = function(vov, objfun, y, x, w, extraargs=NULL, maximize=TRUE,
function(mu,y,w,residuals= FALSE,eta, extra=NULL) {
Theta = eta2theta(eta[,1], .ltheta, earg= .etheta )
nu = eta2theta(eta[,2], .lnu, earg= .enu )
- if(residuals) stop("loglikelihood residuals not implemented yet") else
+ if (residuals) stop("loglikelihood residuals not implemented yet") else
sum(w * ((nu-0.5)*log1p(-y^2) - nu * log1p(-2*Theta*y + Theta^2) -
lbeta(nu+0.5,0.5 )))
}, list( .ltheta=ltheta, .lnu=lnu, .etheta = etheta, .enu=enu ))),
@@ -153,12 +153,12 @@ hzeta.control <- function(save.weight=TRUE, ...)
stopifnot(ialpha > 0)
stopifnot(nsimEIM > 10, length(nsimEIM)==1, nsimEIM==round(nsimEIM))
- if(mode(link) != "character" && mode(link) != "name")
+ if (mode(link) != "character" && mode(link) != "name")
link = as.character(substitute(link))
- if(!is.list(earg)) earg = list()
+ if (!is.list(earg)) earg = list()
new("vglmff",
- blurb=c(
+ blurb = c(
"Haight's Zeta distribution f(y) = (2y-1)^(-alpha) - (2y+1)^(-alpha),\n",
" alpha>0, y=1,2,....\n\n",
"Link: ",
@@ -168,15 +168,15 @@ hzeta.control <- function(save.weight=TRUE, ...)
"Variance: (1-2^(1-alpha)) * zeta(alpha-1) - mean^2 if alpha>2"),
initialize=eval(substitute(expression({
y = as.numeric(y)
- if(ncol(cbind(y)) != 1)
+ if (ncol(cbind(y)) != 1)
stop("response must be a vector or a one-column matrix")
- if(any(y < 1))
+ if (any(y < 1))
stop("all y values must be in 1,2,3,....")
predictors.names = namesof("alpha", .link, earg= .earg, tag=FALSE)
- if(!length(etastart)) {
- a.init = if(length( .ialpha)) .ialpha else {
- if((meany <- weighted.mean(y,w)) < 1.5) 3.0 else
- if(meany < 2.5) 1.4 else 1.1
+ if (!length(etastart)) {
+ a.init = if (length( .ialpha)) .ialpha else {
+ if ((meany <- weighted.mean(y,w)) < 1.5) 3.0 else
+ if (meany < 2.5) 1.4 else 1.1
}
a.init = rep(a.init, length=n)
etastart = theta2eta(a.init, .link, earg= .earg )
@@ -188,7 +188,7 @@ hzeta.control <- function(save.weight=TRUE, ...)
mu[alpha <= 1] = Inf
mu
}, list( .link=link, .earg=earg ))),
- last=eval(substitute(expression({
+ last = eval(substitute(expression({
misc$link = c(alpha= .link)
misc$earg = list(alpha= .earg)
misc$nsimEIM = .nsimEIM
@@ -196,7 +196,7 @@ hzeta.control <- function(save.weight=TRUE, ...)
loglikelihood=eval(substitute(
function(mu,y,w,residuals= FALSE,eta, extra=NULL) {
alpha = eta2theta(eta, .link, earg= .earg )
- if(residuals) stop("loglikelihood residuals not implemented yet") else {
+ if (residuals) stop("loglikelihood residuals not implemented yet") else {
sum(w * dhzeta(x=y, alpha=alpha, log=TRUE))
}
}, list( .link=link, .earg=earg ))),
@@ -222,7 +222,7 @@ hzeta.control <- function(save.weight=TRUE, ...)
temp3 = dl.dalpha
run.var = ((ii-1) * run.var + temp3^2) / ii
}
- wz = if(intercept.only)
+ wz = if (intercept.only)
matrix(colMeans(cbind(run.var)),
n, dimm(M), byrow=TRUE) else cbind(run.var)
@@ -236,11 +236,11 @@ hzeta.control <- function(save.weight=TRUE, ...)
dhzeta = function(x, alpha, log = FALSE)
{
- if(!is.logical(log.arg <- log))
+ if (!is.logical(log.arg <- log))
stop("bad input for argument 'log'")
rm(log)
- if(!is.Numeric(alpha, posit=TRUE))
+ if (!is.Numeric(alpha, posit=TRUE))
stop("'alpha' must be numeric and have positive values")
nn = max(length(x), length(alpha))
x = rep(x, len=nn); alpha = rep(alpha, len=nn)
@@ -248,13 +248,13 @@ dhzeta = function(x, alpha, log = FALSE)
zero = ox | round(x) != x | x < 1
ans = rep(0, len=nn)
ans[!zero] = (2*x[!zero]-1)^(-alpha[!zero]) - (2*x[!zero]+1)^(-alpha[!zero])
- if(log.arg) log(ans) else ans
+ if (log.arg) log(ans) else ans
}
phzeta = function(q, alpha)
{
- if(!is.Numeric(alpha, posit=TRUE))
+ if (!is.Numeric(alpha, posit=TRUE))
stop("'alpha' must be numeric and have positive values")
nn = max(length(q), length(alpha))
q = rep(q, len=nn)
@@ -270,9 +270,9 @@ phzeta = function(q, alpha)
qhzeta = function(p, alpha)
{
- if(!is.Numeric(alpha, posit=TRUE))
+ if (!is.Numeric(alpha, posit=TRUE))
stop("'alpha' must be numeric and have positive values")
- if(!is.Numeric(p, posit=TRUE) || any(p >= 1))
+ if (!is.Numeric(p, posit=TRUE) || any(p >= 1))
stop("argument 'p' must have values inside the interval (0,1)")
nn = max(length(p), length(alpha))
p = rep(p, len=nn)
@@ -283,9 +283,9 @@ qhzeta = function(p, alpha)
rhzeta = function(n, alpha)
{
- if(!is.Numeric(alpha, posit=TRUE))
+ if (!is.Numeric(alpha, posit=TRUE))
stop("'alpha' must be numeric and have positive values")
- if(!is.Numeric(n, posit=TRUE, integ=TRUE, allow=1))
+ if (!is.Numeric(n, posit=TRUE, integ=TRUE, allow=1))
stop("argument 'n' must be a positive integer")
ans = ((runif(n)^(-1/alpha) - 1) / 2)
floor(ans+1)
@@ -296,31 +296,31 @@ rhzeta = function(n, alpha)
iphi = 0.10, parallel= FALSE, zero="M")
{
- if(mode(lphi) != "character" && mode(lphi) != "name")
+ if (mode(lphi) != "character" && mode(lphi) != "name")
lphi = as.character(substitute(lphi))
- if(length(zero) &&
+ if (length(zero) &&
!(is.Numeric(zero, integer=TRUE, posit=TRUE) || is.character(zero )))
stop("bad input for argument 'zero'")
- if(!is.Numeric(iphi, positive=TRUE) || max(iphi) >= 1.0)
+ if (!is.Numeric(iphi, positive=TRUE) || max(iphi) >= 1.0)
stop("bad input for argument 'iphi'")
- if(!is.list(ephi)) ephi = list()
+ if (!is.list(ephi)) ephi = list()
new("vglmff",
- blurb=c("Dirichlet-multinomial distribution\n\n",
- "Links: ",
- "log(prob[1]/prob[M]), ..., log(prob[M-1]/prob[M]), ",
- namesof("phi", lphi, earg=ephi), "\n", "\n",
- "Mean: shape_j / sum_j(shape_j)"),
+ blurb = c("Dirichlet-multinomial distribution\n\n",
+ "Links: ",
+ "log(prob[1]/prob[M]), ..., log(prob[M-1]/prob[M]), ",
+ namesof("phi", lphi, earg=ephi), "\n", "\n",
+ "Mean: shape_j / sum_j(shape_j)"),
constraints=eval(substitute(expression({
.ZERO = .zero
- if(is.character(.ZERO)) .ZERO = eval(parse(text = .ZERO))
+ if (is.character(.ZERO)) .ZERO = eval(parse(text = .ZERO))
.PARALLEL = .parallel
- if(is.logical(.PARALLEL) && .PARALLEL) {
- mycmatrix = if(length(.ZERO))
+ if (is.logical(.PARALLEL) && .PARALLEL) {
+ mycmatrix = if (length(.ZERO))
stop("can only handle parallel=TRUE when zero=NULL") else
cbind(rbind(matrix(1,M-1,1), 0), rbind(matrix(0,M-1,1), 1))
} else
- mycmatrix = if(M==1) diag(1) else diag(M)
+ mycmatrix = if (M==1) diag(1) else diag(M)
constraints=cm.vgam(mycmatrix, x, .PARALLEL, constraints, int=TRUE)
constraints = cm.zero.vgam(constraints, x, .ZERO, M)
}), list( .parallel=parallel, .zero=zero ))),
@@ -331,15 +331,15 @@ rhzeta = function(n, alpha)
y = as.matrix(y)
ycount = as.matrix(y * w)
M = ncol(y)
- if(max(abs(ycount - round(ycount ))) > 1.0e-6)
+ if (max(abs(ycount - round(ycount ))) > 1.0e-6)
warning("there appears to be non-integer responses")
- if(min(ycount) < 0)
+ if (min(ycount) < 0)
stop("all values of the response (matrix) must be non-negative")
predictors.names =
c(paste("log(prob[,",1:(M-1),"]/prob[,",M,"])", sep=""),
namesof("phi", .lphi, short=TRUE))
extra$n2 = w # aka omega, must be integer # as.vector(apply(y, 1, sum))
- if(!length(etastart)) {
+ if (!length(etastart)) {
prob.init = colSums(ycount)
prob.init = prob.init / sum(prob.init)
prob.init = matrix(prob.init, n, M, byrow=TRUE)
@@ -349,11 +349,11 @@ rhzeta = function(n, alpha)
}
}), list( .lphi=lphi, .ephi=ephi, .iphi=iphi ))),
inverse=eval(substitute(function(eta, extra=NULL) {
- M = if(is.matrix(eta)) ncol(eta) else 1
+ M = if (is.matrix(eta)) ncol(eta) else 1
temp = cbind(exp(eta[,-M]), 1)
temp / as.vector(temp %*% rep(1, M))
}, list( .ephi=ephi, .lphi=lphi ))),
- last=eval(substitute(expression({
+ last = eval(substitute(expression({
misc$link = c(rep("noLinkFunction", length=M-1), .lphi)
names(misc$link) = c(paste("prob", 1:(M-1), sep=""), "phi")
misc$earg = vector("list", M)
@@ -361,28 +361,28 @@ rhzeta = function(n, alpha)
for(ii in 1:(M-1)) misc$earg[[ii]] = list()
misc$earg[[M]] = .ephi
misc$expected = TRUE
- if(intercept.only) {
+ if (intercept.only) {
misc$shape=probs[1,]*(1/phi[1]-1) # phi & probs computed in @deriv
}
}), list( .ephi=ephi, .lphi=lphi ))),
loglikelihood=eval(substitute(
function(mu,y,w,residuals= FALSE,eta, extra=NULL) {
- M = if(is.matrix(eta)) ncol(eta) else 1
+ M = if (is.matrix(eta)) ncol(eta) else 1
probs = cbind(exp(eta[,-M]), 1)
probs = probs / as.vector(probs %*% rep(1, M))
phi = eta2theta(eta[,M], .lphi, earg= .ephi )
n = length(phi)
ycount = as.matrix(y * w)
- if(residuals) stop("loglikelihood residuals not implemented yet") else {
+ if (residuals) stop("loglikelihood residuals not implemented yet") else {
ans = rep(0.0, len=n)
omega = extra$n2
for(jay in 1:M) {
maxyj = max(ycount[,jay])
loopOveri = n < maxyj
- if(loopOveri) {
+ if (loopOveri) {
for(iii in 1:n) {
rrr = 1:ycount[iii,jay] # a vector
- if(ycount[iii,jay] > 0)
+ if (ycount[iii,jay] > 0)
ans[iii] = ans[iii] + sum(log((1-phi[iii]) *
probs[iii,jay] + (rrr-1)*phi[iii]))
@@ -390,7 +390,7 @@ rhzeta = function(n, alpha)
} else {
for(rrr in 1:maxyj) {
index = (rrr <= ycount[,jay]) & (ycount[,jay] > 0)
- if(any(index))
+ if (any(index))
ans[index] = ans[index] + log((1-phi[index]) *
probs[index,jay] + (rrr-1)*phi[index])
}
@@ -399,7 +399,7 @@ rhzeta = function(n, alpha)
maxomega = max(omega)
loopOveri = n < maxomega
- if(loopOveri) {
+ if (loopOveri) {
for(iii in 1:n) {
rrr = 1:omega[iii]
ans[iii]= ans[iii] - sum(log1p(-phi[iii] + (rrr-1)*phi[iii]))
@@ -425,16 +425,16 @@ rhzeta = function(n, alpha)
for(jay in 1:M) {
maxyj = max(ycount[,jay])
loopOveri = n < maxyj
- if(loopOveri) {
+ if (loopOveri) {
for(iii in 1:n) {
rrr = 1:ycount[iii,jay]
- if(ycount[iii,jay] > 0) {
+ if (ycount[iii,jay] > 0) {
PHI = phi[iii]
dl.dphi[iii]=dl.dphi[iii] + sum((rrr-1-probs[iii,jay]) /
((1-PHI)*probs[iii,jay] + (rrr-1)*PHI))
tmp9 = (1-PHI) / ((1-PHI)*probs[iii,jay] + (rrr-1)*PHI)
- if(jay < M) {
+ if (jay < M) {
dl.dprobs[iii,jay] = dl.dprobs[iii,jay] + sum(tmp9)
} else {
for(jay2 in 1:(M-1))
@@ -449,7 +449,7 @@ rhzeta = function(n, alpha)
dl.dphi[index] = dl.dphi[index] + (rrr-1-probs[index,jay]) /
((1-PHI)*probs[index,jay] + (rrr-1)*PHI)
tmp9 = (1-PHI) / ((1-PHI)*probs[index,jay] + (rrr-1)*PHI)
- if(jay < M) {
+ if (jay < M) {
dl.dprobs[index,jay] = dl.dprobs[index,jay] + tmp9
} else {
for(jay2 in 1:(M-1))
@@ -460,7 +460,7 @@ rhzeta = function(n, alpha)
} # end of jay loop
maxomega = max(omega)
loopOveri = n < maxomega
- if(loopOveri) {
+ if (loopOveri) {
for(iii in 1:n) {
rrr = 1:omega[iii]
dl.dphi[iii]=dl.dphi[iii] - sum((rrr-2)/(1 + (rrr-2)*phi[iii]))
@@ -479,7 +479,7 @@ rhzeta = function(n, alpha)
weight=eval(substitute(expression({
wz = matrix(0, n, dimm(M))
loopOveri = n < maxomega
- if(loopOveri) {
+ if (loopOveri) {
for(iii in 1:n) {
rrr = 1:omega[iii] # A vector
PHI = phi[iii]
@@ -498,7 +498,7 @@ rhzeta = function(n, alpha)
wz[iii,iam(jay,jay,M)] = wz[iii,iam(jay,jay,M)] +
sum(pYij.ge.rrr / denomj) +
sum(pYiM.ge.rrr / denomM)
- for(kay in jay:(M-1)) if(kay > jay) {
+ for(kay in jay:(M-1)) if (kay > jay) {
wz[iii,iam(jay,kay,M)] = wz[iii,iam(jay,kay,M)] +
sum(pYiM.ge.rrr / denomM)
}
@@ -527,7 +527,7 @@ rhzeta = function(n, alpha)
shape2=(1-probs[ind5,jay])*(1/PHI-1))
wz[ind5,iam(jay,jay,M)] = wz[ind5,iam(jay,jay,M)] +
pYij.ge.rrr / denomj + pYiM.ge.rrr / denomM
- for(kay in jay:(M-1)) if(kay > jay) {
+ for(kay in jay:(M-1)) if (kay > jay) {
wz[ind5,iam(jay,kay,M)] = wz[ind5,iam(jay,kay,M)] +
pYiM.ge.rrr / denomM
}
@@ -559,19 +559,19 @@ dirmul.old = function(link="loge", earg=list(), init.alpha = 0.01,
parallel= FALSE, zero=NULL)
{
- if(mode(link) != "character" && mode(link) != "name")
+ if (mode(link) != "character" && mode(link) != "name")
link = as.character(substitute(link))
- if(length(zero) && !is.Numeric(zero, integer=TRUE, posit=TRUE))
+ if (length(zero) && !is.Numeric(zero, integer=TRUE, posit=TRUE))
stop("bad input for argument 'zero'")
- if(!is.Numeric(init.alpha, posit=TRUE))
+ if (!is.Numeric(init.alpha, posit=TRUE))
stop("'init.alpha' must contain positive values only")
- if(!is.list(earg)) earg = list()
+ if (!is.list(earg)) earg = list()
new("vglmff",
- blurb=c("Dirichlet-Multinomial distribution\n\n",
- "Links: ",
- namesof("shape1", link, earg=earg), ", ..., ",
- namesof("shapeM", link, earg=earg), "\n\n",
+ blurb = c("Dirichlet-Multinomial distribution\n\n",
+ "Links: ",
+ namesof("shape1", link, earg=earg), ", ..., ",
+ namesof("shapeM", link, earg=earg), "\n\n",
"Posterior mean: (n_j + shape_j)/(2*sum(n_j) + sum(shape_j))\n"),
constraints=eval(substitute(expression({
constraints = cm.vgam(matrix(1,M,1), x, .parallel, constraints, int= TRUE)
@@ -580,15 +580,15 @@ dirmul.old = function(link="loge", earg=list(), init.alpha = 0.01,
initialize=eval(substitute(expression({
y = as.matrix(y)
M = ncol(y)
- if(any(y != round(y )))
+ if (any(y != round(y )))
stop("all y values must be integer-valued")
predictors.names = namesof(paste("shape", 1:M, sep=""), .link,
earg=.earg, short=TRUE)
extra$n2 = rowSums(y) # Nb. don't multiply by 2
extra$y = y
- if(!length(etastart)) {
- yy = if(is.numeric(.init.alpha))
+ if (!length(etastart)) {
+ 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)
@@ -596,11 +596,11 @@ dirmul.old = function(link="loge", earg=list(), init.alpha = 0.01,
}), list( .link=link, .earg=earg, .init.alpha=init.alpha ))),
inverse=eval(substitute(function(eta, extra=NULL) {
shape = eta2theta(eta, .link, earg=.earg)
- M = if(is.matrix(eta)) ncol(eta) else 1
+ M = if (is.matrix(eta)) ncol(eta) else 1
sumshape = as.vector(shape %*% rep(1, len=M))
(extra$y + shape) / (extra$n2 + sumshape)
}, list( .link=link, .earg=earg ))),
- last=eval(substitute(expression({
+ last = eval(substitute(expression({
misc$link = rep(.link, length=M)
names(misc$link) = paste("shape", 1:M, sep="")
misc$earg = vector("list", M)
@@ -611,9 +611,9 @@ dirmul.old = function(link="loge", earg=list(), init.alpha = 0.01,
loglikelihood=eval(substitute(
function(mu,y,w,residuals= FALSE,eta, extra=NULL) {
shape = eta2theta(eta, .link, earg=.earg)
- M = if(is.matrix(eta)) ncol(eta) else 1
+ M = if (is.matrix(eta)) ncol(eta) else 1
sumshape = as.vector(shape %*% rep(1, len=M))
- if(residuals) stop("loglikelihood residuals not implemented yet") else
+ if (residuals) stop("loglikelihood residuals not implemented yet") else
sum(w*(lgamma(sumshape) - lgamma(extra$n2 + sumshape ))) +
sum(w * (lgamma(y + shape) - lgamma(shape )))
}, list( .link=link, .earg=earg ))),
@@ -634,7 +634,7 @@ dirmul.old = function(link="loge", earg=list(), init.alpha = 0.01,
wz = -wz * dsh.deta[, index$row] * dsh.deta[, index$col]
- if(TRUE && intercept.only) {
+ if (TRUE && intercept.only) {
sumw = sum(w)
for(ii in 1:ncol(wz))
wz[,ii] = sum(wz[,ii]) / sumw
@@ -651,7 +651,7 @@ dirmul.old = function(link="loge", earg=list(), init.alpha = 0.01,
rdiric = function(n, shape, dimension=NULL) {
- if(!is.numeric(dimension))
+ if (!is.numeric(dimension))
dimension = length(shape)
shape = rep(shape, len=dimension)
@@ -666,17 +666,17 @@ rdiric = function(n, shape, dimension=NULL) {
dirichlet = function(link="loge", earg=list(), parallel= FALSE, zero=NULL)
{
- if(mode(link) != "character" && mode(link) != "name")
+ if (mode(link) != "character" && mode(link) != "name")
link = as.character(substitute(link))
- if(length(zero) && !is.Numeric(zero, integer=TRUE, posit=TRUE))
+ if (length(zero) && !is.Numeric(zero, integer=TRUE, posit=TRUE))
stop("bad input for argument 'zero'")
- if(!is.list(earg)) earg = list()
+ if (!is.list(earg)) earg = list()
new("vglmff",
- blurb=c("Dirichlet distribution\n\n",
- "Links: ",
- namesof("shapej", link, earg=earg), "\n\n",
- "Mean: shape_j/(1 + sum(shape_j)), j=1,..,ncol(y)"),
+ blurb = c("Dirichlet distribution\n\n",
+ "Links: ",
+ namesof("shapej", link, earg=earg), "\n\n",
+ "Mean: shape_j/(1 + sum(shape_j)), j=1,..,ncol(y)"),
constraints=eval(substitute(expression({
constraints = cm.vgam(matrix(1,M,1), x, .parallel, constraints, int= TRUE)
constraints = cm.zero.vgam(constraints, x, .zero, M)
@@ -684,22 +684,22 @@ rdiric = function(n, shape, dimension=NULL) {
initialize=eval(substitute(expression({
y = as.matrix(y)
M = ncol(y)
- if(any(y <= 0) || any(y>=1))
+ if (any(y <= 0) || any(y>=1))
stop("all y values must be > 0 and < 1")
predictors.names = namesof(paste("shape", 1:M, sep=""), .link,
earg=.earg, short=TRUE)
- if(!length(etastart)) {
+ if (!length(etastart)) {
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 ))),
inverse=eval(substitute(function(eta, extra=NULL) {
shape = eta2theta(eta, .link, earg= .earg )
- M = if(is.matrix(eta)) ncol(eta) else 1
+ M = if (is.matrix(eta)) ncol(eta) else 1
sumshape = rowSums(shape)
shape / sumshape
}, list( .link=link, .earg=earg ))),
- last=eval(substitute(expression({
+ last = eval(substitute(expression({
misc$link = c(shape= .link)
temp.names = paste("shape", 1:M, sep="")
misc$link = rep( .link, len=M)
@@ -712,9 +712,9 @@ rdiric = function(n, shape, dimension=NULL) {
loglikelihood=eval(substitute(
function(mu,y,w,residuals= FALSE,eta, extra=NULL) {
shape = eta2theta(eta, .link, earg= .earg )
- M = if(is.matrix(eta)) ncol(eta) else 1
+ M = if (is.matrix(eta)) ncol(eta) else 1
sumshape = as.vector(shape %*% rep(1, len=M))
- if(residuals) stop("loglikelihood residuals not implemented yet") else
+ if (residuals) stop("loglikelihood residuals not implemented yet") else
sum(w * (lgamma(sumshape) - lgamma(shape) + (shape-1)*log(y )))
}, list( .link=link, .earg=earg ))),
vfamily=c("dirichlet"),
@@ -741,19 +741,19 @@ rdiric = function(n, shape, dimension=NULL) {
deriv.arg = deriv
- if(!is.Numeric(deriv.arg, allow=1, integer=TRUE, positi=TRUE) && deriv.arg!=0)
+ if (!is.Numeric(deriv.arg, allow=1, integer=TRUE, positi=TRUE) && deriv.arg!=0)
stop("'deriv' must be a single non-negative integer")
- if(!(deriv.arg==0 || deriv.arg==1 || deriv.arg==2))
+ if (!(deriv.arg==0 || deriv.arg==1 || deriv.arg==2))
stop("'deriv' must be 0, 1, or 2")
- if(deriv.arg > 0)
+ if (deriv.arg > 0)
return(zeta.derivative(x, deriv=deriv))
- if(any(special <- Re(x) <= 1)) {
+ if (any(special <- Re(x) <= 1)) {
ans <- x
ans[special] <- Inf # For Re(x)==1
@@ -765,13 +765,13 @@ rdiric = function(n, shape, dimension=NULL) {
special2 <- Re(x) < 0
- if(any(special2)) {
+ if (any(special2)) {
x2 = x[special2]
cx = 1-x2
ans[special2] = 2^(x2) * pi^(x2-1) * sin(pi*x2/2) * gamma(cx) * Recall(cx)
}
- if(any(!special)) {
+ if (any(!special)) {
ans[!special] <- Recall(x[!special])
}
return(ans)
@@ -800,26 +800,26 @@ zeta.derivative = function(x, deriv=0)
deriv.arg = deriv
- if(!is.Numeric(deriv.arg, allow=1, integer=TRUE, positi=TRUE) && deriv.arg!=0)
+ if (!is.Numeric(deriv.arg, allow=1, integer=TRUE, positi=TRUE) && deriv.arg!=0)
stop("'deriv' must be a single non-negative integer")
- if(!(deriv.arg==0 || deriv.arg==1 || deriv.arg==2))
+ if (!(deriv.arg==0 || deriv.arg==1 || deriv.arg==2))
stop("'deriv' must be 0, 1, or 2")
- if(any(Im(x) != 0))
+ if (any(Im(x) != 0))
stop("Sorry, currently can only handle x real, not complex")
- if(any(x < 0))
+ if (any(x < 0))
stop("Sorry, currently cannot handle x < 0")
ok = is.finite(x) & x > 0 & x != 1 # Handles NAs
ans = rep(as.numeric(NA), length(x))
nn = sum(ok) # Effective length (excludes x < 0 and x = 1 values)
- if(nn)
- ans[ok] = dotFortran(name="vzetawr", as.double(x[ok]), ans=double(nn),
+ if (nn)
+ ans[ok] = dotC(name="aaaa_vzetawr", as.double(x[ok]), ans=double(nn),
as.integer(deriv.arg), as.integer(nn))$ans
- if(deriv==0)
+ if (deriv==0)
ans[is.finite(x) & abs(x) < 1.0e-12] = -0.5
ans
@@ -828,65 +828,66 @@ zeta.derivative = function(x, deriv=0)
dzeta = function(x, p, log = FALSE)
{
- if(!is.logical(log.arg <- log))
+ if (!is.logical(log.arg <- log))
stop("bad input for argument 'log'")
rm(log)
- if(!is.Numeric(p, posit=TRUE)) # || min(p) <= 1
+ if (!is.Numeric(p, posit=TRUE)) # || min(p) <= 1
stop("'p' must be numeric and > 0")
LLL = max(length(p), length(x))
x = rep(x, len=LLL); p = rep(p, len=LLL)
ox = !is.finite(x)
zero = ox | round(x) != x | x < 1
- if(any(zero)) warning("non-integer x and/or x < 1 or NAs")
+ if (any(zero)) warning("non-integer x and/or x < 1 or NAs")
ans = rep(if(log.arg) log(0) else 0, len=LLL)
- if(any(!zero)) {
- if(log.arg) {
+ if (any(!zero)) {
+ if (log.arg) {
ans[!zero] = (-p[!zero]-1)*log(x[!zero]) - log(zeta(p[!zero]+1))
} else {
ans[!zero] = x[!zero]^(-p[!zero]-1) / zeta(p[!zero]+1)
}
}
- if(any(ox)) ans[ox] = NA
+ if (any(ox)) ans[ox] = NA
ans
}
zetaff = function(link="loge", earg=list(), init.p=NULL)
{
- if(length(init.p) && !is.Numeric(init.p, positi=TRUE))
+ if (length(init.p) && !is.Numeric(init.p, positi=TRUE))
stop("argument 'init.p' must be > 0")
- if(mode(link) != "character" && mode(link) != "name")
+ if (mode(link) != "character" && mode(link) != "name")
link = as.character(substitute(link))
- if(!is.list(earg)) earg = list()
+ if (!is.list(earg)) earg = list()
new("vglmff",
- blurb=c("Zeta distribution f(y) = 1/(y^(p+1) zeta(p+1)), p>0, y=1,2,..\n\n",
- "Link: ",
- namesof("p", link, earg=earg), "\n\n",
- "Mean: zeta(p) / zeta(p+1), provided p>1\n",
- "Variance: zeta(p-1) / zeta(p+1) - mean^2, provided p>2"),
+ blurb = c("Zeta distribution ",
+ "f(y) = 1/(y^(p+1) zeta(p+1)), p>0, y=1,2,..\n\n",
+ "Link: ",
+ namesof("p", link, earg=earg), "\n\n",
+ "Mean: zeta(p) / zeta(p+1), provided p>1\n",
+ "Variance: zeta(p-1) / zeta(p+1) - mean^2, provided p>2"),
initialize=eval(substitute(expression({
y = as.numeric(y)
- if(any(y < 1))
+ if (any(y < 1))
stop("all y values must be in 1,2,3,...")
- if(any(y != round(y )))
+ if (any(y != round(y )))
warning("'y' should be integer-valued")
- if(ncol(cbind(y)) != 1)
+ if (ncol(cbind(y)) != 1)
stop("response must be a vector or a one-column matrix")
predictors.names = namesof("p", .link, earg=.earg, tag=FALSE)
- if(!length(etastart)) {
+ if (!length(etastart)) {
zetaff.Loglikfun = function(pp, y, x, w, extraargs) {
sum(w * dzeta(x=y, p=pp, log=TRUE))
}
p.grid = seq(0.1, 3.0, len=19)
- pp.init = if(length( .init.p )) .init.p else
+ pp.init = if (length( .init.p )) .init.p else
getMaxMin(p.grid, objfun=zetaff.Loglikfun, y=y, x=x, w=w)
pp.init = rep(pp.init, length=length(y))
- if( .link == "loglog") pp.init[pp.init <= 1] = 1.2
+ if ( .link == "loglog") pp.init[pp.init <= 1] = 1.2
etastart = theta2eta(pp.init, .link, earg=.earg)
}
}), list( .link=link, .earg=earg, .init.p=init.p ))),
@@ -896,14 +897,14 @@ dzeta = function(x, p, log = FALSE)
ans[pp<=1] = NA
ans
}, list( .link=link, .earg=earg ))),
- last=eval(substitute(expression({
+ last = eval(substitute(expression({
misc$link = c(pp= .link)
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)
- if(residuals) stop("loglikelihood residuals not implemented yet") else {
+ if (residuals) stop("loglikelihood residuals not implemented yet") else {
sum(w * dzeta(x=y, p=pp, log=TRUE))
}
}, list( .link=link, .earg=earg ))),
@@ -927,18 +928,18 @@ dzeta = function(x, p, log = FALSE)
gharmonic = function(n, s=1, lognexponent=0) {
- if(!is.Numeric(n, integ=TRUE, posit=TRUE))
+ if (!is.Numeric(n, integ=TRUE, posit=TRUE))
stop("bad input for argument 'n'")
- if(!is.Numeric(lognexponent, allow=1))
+ if (!is.Numeric(lognexponent, allow=1))
stop("bad input for argument 'lognexponent'")
- if(length(n) == 1 && length(s) == 1) {
- if(lognexponent != 0) sum(log(1:n)^lognexponent * (1:n)^(-s)) else
+ if (length(n) == 1 && length(s) == 1) {
+ if (lognexponent != 0) sum(log(1:n)^lognexponent * (1:n)^(-s)) else
sum((1:n)^(-s))
} else {
LEN = max(length(n), length(s))
n = rep(n, len=LEN)
ans = s = rep(s, len=LEN)
- if(lognexponent != 0) {
+ if (lognexponent != 0) {
for(ii in 1:LEN)
ans[ii] = sum(log(1:n[ii])^lognexponent * (1:n[ii])^(-s[ii]))
} else
@@ -950,23 +951,23 @@ gharmonic = function(n, s=1, lognexponent=0) {
dzipf = function(x, N, s, log=FALSE)
{
- if(!is.logical(log.arg <- log))
+ if (!is.logical(log.arg <- log))
stop("bad input for argument 'log'")
rm(log)
- if(!is.Numeric(x))
+ if (!is.Numeric(x))
stop("bad input for argument 'x'")
- if(!is.Numeric(N, integ=TRUE, posit=TRUE))
+ if (!is.Numeric(N, integ=TRUE, posit=TRUE))
stop("bad input for argument 'N'")
- if(!is.Numeric(s, posit=TRUE))
+ if (!is.Numeric(s, posit=TRUE))
stop("bad input for argument 's'")
nn = max(length(x), length(N), length(s))
x = rep(x, len=nn); N = rep(N, len=nn); s = rep(s, len=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) {
+ if (any(!zero))
+ if (log.arg) {
ans[!zero] = (-s[!zero]) * log(x[!zero]) -
log(gharmonic(N[!zero], s[!zero]))
} else {
@@ -978,11 +979,11 @@ dzipf = function(x, N, s, log=FALSE)
pzipf = function(q, N, s) {
- if(!is.Numeric(q))
+ if (!is.Numeric(q))
stop("bad input for argument 'q'")
- if(!is.Numeric(N, integ=TRUE, posit=TRUE))
+ if (!is.Numeric(N, integ=TRUE, posit=TRUE))
stop("bad input for argument 'N'")
- if(!is.Numeric(s, posit=TRUE))
+ if (!is.Numeric(s, posit=TRUE))
stop("bad input for argument 's'")
nn = max(length(q), length(N), length(s))
@@ -992,7 +993,7 @@ pzipf = function(q, N, s) {
floorq = floor(q)
ans = 0 * floorq
ans[oq | q >= N] = 1
- if(any(!zeroOR1))
+ if (any(!zeroOR1))
ans[!zeroOR1] = gharmonic(floorq[!zeroOR1], s[!zeroOR1]) /
gharmonic(N[!zeroOR1], s[!zeroOR1])
ans
@@ -1001,49 +1002,49 @@ pzipf = function(q, N, s) {
zipf = function(N=NULL, link="loge", earg=list(), init.s=NULL)
{
- if(length(N) &&
+ if (length(N) &&
(!is.Numeric(N, positi=TRUE, integ=TRUE, allow=1) || N <= 1))
stop("bad input for argument 'N'")
enteredN = length(N)
- if(length(init.s) && !is.Numeric(init.s, positi=TRUE))
+ if (length(init.s) && !is.Numeric(init.s, positi=TRUE))
stop("argument 'init.s' must be > 0")
- if(mode(link) != "character" && mode(link) != "name")
+ if (mode(link) != "character" && mode(link) != "name")
link = as.character(substitute(link))
- if(!is.list(earg)) earg = list()
+ if (!is.list(earg)) earg = list()
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=""), ""),
- "\n\n",
- "Link: ",
- namesof("s", link, earg=earg),
- "\n\n",
- "Mean: gharmonic(N,s-1) / gharmonic(N,s)"),
+ blurb = c("Zipf distribution f(y;s) = y^(-s) / sum((1:N)^(-s)),",
+ " s>0, y=1,2,...,N", ifelse(enteredN, paste("=",N,sep=""), ""),
+ "\n\n",
+ "Link: ",
+ namesof("s", link, earg=earg),
+ "\n\n",
+ "Mean: gharmonic(N,s-1) / gharmonic(N,s)"),
initialize=eval(substitute(expression({
- if(ncol(cbind(y)) != 1)
+ if (ncol(cbind(y)) != 1)
stop("response must be a vector or a one-column matrix")
y = as.numeric(y)
- if(any(y != round(y )))
+ if (any(y != round(y )))
stop("y must be integer-valued")
predictors.names = namesof("s", .link, earg= .earg, tag=FALSE)
NN = .N
- if(!is.Numeric(NN, allow=1, posit=TRUE, integ=TRUE))
+ if (!is.Numeric(NN, allow=1, posit=TRUE, integ=TRUE))
NN = max(y)
- if(max(y) > NN)
+ if (max(y) > NN)
stop("maximum of the response is greater than argument 'N'")
- if(any(y < 1))
+ if (any(y < 1))
stop("all response values must be in 1,2,3,...,N(=", NN,")")
extra$N = NN
- if(!length(etastart)) {
+ if (!length(etastart)) {
llfun = function(ss, y, N, w) {
sum(w * dzipf(x=y, N=extra$N, s=ss, log=TRUE))
}
- ss.init = if(length( .init.s )) .init.s else
+ ss.init = if (length( .init.s )) .init.s else
getInitVals(gvals=seq(0.1, 3.0, len=19), llfun=llfun,
y=y, N=extra$N, w=w)
ss.init = rep(ss.init, length=length(y))
- if( .link == "loglog") ss.init[ss.init <= 1] = 1.2
+ if ( .link == "loglog") ss.init[ss.init <= 1] = 1.2
etastart = theta2eta(ss.init, .link, earg= .earg)
}
}), list( .link=link, .earg=earg, .init.s=init.s, .N=N ))),
@@ -1051,7 +1052,7 @@ pzipf = function(q, N, s) {
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({
+ last = eval(substitute(expression({
misc$expected = FALSE
misc$link = c(s= .link)
misc$earg = list(s= .earg )
@@ -1060,7 +1061,7 @@ pzipf = function(q, N, s) {
loglikelihood=eval(substitute(
function(mu,y,w,residuals= FALSE,eta, extra=NULL) {
ss = eta2theta(eta, .link, earg= .earg)
- if(residuals) stop("loglikelihood residuals not implemented yet") else {
+ if (residuals) stop("loglikelihood residuals not implemented yet") else {
sum(w * dzipf(x=y, N=extra$N, s=ss, log=TRUE))
}
}, list( .link=link, .earg=earg ))),
@@ -1094,32 +1095,32 @@ cauchy.control <- function(save.weight=TRUE, ...)
iprobs = seq(0.2, 0.8, by=0.2),
method.init=1, nsimEIM=NULL, zero=2)
{
- if(mode(llocation) != "character" && mode(llocation) != "name")
+ if (mode(llocation) != "character" && mode(llocation) != "name")
llocation = as.character(substitute(llocation))
- if(mode(lscale) != "character" && mode(lscale) != "name")
+ if (mode(lscale) != "character" && mode(lscale) != "name")
lscale = as.character(substitute(lscale))
- if(!is.Numeric(method.init, allow=1, integ=TRUE, posit=TRUE) ||
+ if (!is.Numeric(method.init, allow=1, integ=TRUE, posit=TRUE) ||
method.init > 3)
stop("'method.init' must be 1 or 2 or 3")
- if(!is.list(elocation)) elocation = list()
- if(!is.list(escale)) escale = list()
- if(length(zero) && !is.Numeric(zero, integer=TRUE, posit=TRUE))
+ if (!is.list(elocation)) elocation = list()
+ if (!is.list(escale)) escale = list()
+ if (length(zero) && !is.Numeric(zero, integer=TRUE, posit=TRUE))
stop("bad input for argument 'zero'")
- if(length(nsimEIM) &&
+ if (length(nsimEIM) &&
(!is.Numeric(nsimEIM, allow=1, integ=TRUE) || nsimEIM <= 50))
stop("'nsimEIM' should be an integer greater than 50")
- if(length(iscale) && !is.Numeric(iscale, posit=TRUE))
+ if (length(iscale) && !is.Numeric(iscale, posit=TRUE))
stop("bad input for argument 'iscale'")
- if(!is.Numeric(iprobs, posit=TRUE) || max(iprobs) >= 1)
+ if (!is.Numeric(iprobs, posit=TRUE) || max(iprobs) >= 1)
stop("bad input for argument 'iprobs'")
new("vglmff",
- 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",
- "Mean: NA\n",
- "Variance: NA"),
+ 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",
+ "Mean: NA\n",
+ "Variance: NA"),
constraints=eval(substitute(expression({
constraints = cm.zero.vgam(constraints, x, .zero, M)
}), list( .zero=zero ))),
@@ -1127,20 +1128,20 @@ cauchy.control <- function(save.weight=TRUE, ...)
predictors.names = c(
namesof("location", .llocation, earg=.elocation, tag=FALSE),
namesof("scale", .lscale, earg=.escale, tag=FALSE))
- if(ncol(cbind(y)) != 1)
+ if (ncol(cbind(y)) != 1)
stop("response must be a vector or a one-column matrix")
- if(!length(etastart)) {
- loc.init = if(length(.ilocation)) .ilocation else {
- if( .method.init == 2) median(rep(y,w)) else
- if( .method.init == 3) y else {
+ if (!length(etastart)) {
+ loc.init = if (length(.ilocation)) .ilocation else {
+ if ( .method.init == 2) median(rep(y,w)) else
+ if ( .method.init == 3) y else {
cauchy2.Loglikfun = function(loc, y, x, w, extraargs) {
iprobs = .iprobs
qy = quantile(rep(y,w), probs=iprobs)
ztry = tan(pi*(iprobs-0.5))
btry = (qy - loc) / ztry
scal = median(btry, na.rm = TRUE)
- if(scal <= 0) scal = 0.1
+ if (scal <= 0) scal = 0.1
sum(w * dcauchy(x=y, loc=loc, scale=scal, log=TRUE))
}
loc.grid = c(quantile(y, probs=seq(0.1, 0.9, by=0.05)))
@@ -1153,18 +1154,18 @@ cauchy.control <- function(save.weight=TRUE, ...)
loc.init = rep(c(loc.init), len=n)
- sca.init = if(length(.iscale)) .iscale else {
+ sca.init = if (length(.iscale)) .iscale else {
iprobs = .iprobs
qy = quantile(rep(y,w), probs=iprobs)
ztry = tan(pi*(iprobs-0.5))
btry = (qy - loc.init[1]) / ztry
sca.init = median(btry, na.rm = TRUE)
- if(sca.init <= 0) sca.init = 0.01
+ if (sca.init <= 0) sca.init = 0.01
sca.init
}
sca.init = rep(c(sca.init), len=n)
- if(.llocation == "loge") loc.init = abs(loc.init)+0.01
+ if (.llocation == "loge") loc.init = abs(loc.init)+0.01
etastart = cbind(theta2eta(loc.init, .llocation, earg=.elocation),
theta2eta(sca.init, .lscale, earg=.escale))
}
@@ -1175,7 +1176,7 @@ cauchy.control <- function(save.weight=TRUE, ...)
eta2theta(eta[,1], .llocation, earg= .elocation)
}, list( .llocation=llocation,
.elocation=elocation ))),
- last=eval(substitute(expression({
+ last = eval(substitute(expression({
misc$expected = TRUE
misc$link = c("location"= .llocation, "scale"=.lscale)
misc$earg = list(location= .elocation, scale= .escale)
@@ -1187,7 +1188,7 @@ cauchy.control <- function(save.weight=TRUE, ...)
function(mu,y,w,residuals= FALSE,eta, extra=NULL) {
location = eta2theta(eta[,1], .llocation, earg=.elocation)
myscale = eta2theta(eta[,2], .lscale, earg=.escale)
- if(residuals) stop("loglikelihood residuals not implemented yet") else {
+ if (residuals) stop("loglikelihood residuals not implemented yet") else {
sum(w * dcauchy(x=y, loc=location, sc=myscale, log=TRUE))
}
}, list( .escale=escale, .lscale=lscale,
@@ -1209,7 +1210,7 @@ cauchy.control <- function(save.weight=TRUE, ...)
run.varcov = 0
ind1 = iam(NA, NA, M=M, both=TRUE, diag=TRUE)
dthetas.detas = cbind(dlocation.deta, dscale.deta)
- if(length( .nsimEIM )) {
+ if (length( .nsimEIM )) {
for(ii in 1:( .nsimEIM )) {
ysim = rcauchy(n, loc=location, scale=myscale)
Z = (ysim-location) / myscale
@@ -1220,7 +1221,7 @@ cauchy.control <- function(save.weight=TRUE, ...)
run.varcov = ((ii-1) * run.varcov +
temp3[,ind1$row.index]*temp3[,ind1$col.index]) / ii
}
- wz = if(intercept.only)
+ wz = if (intercept.only)
matrix(colMeans(run.varcov),
n, ncol(run.varcov), byrow=TRUE) else run.varcov
@@ -1247,31 +1248,31 @@ cauchy.control <- function(save.weight=TRUE, ...)
elocation=list(),
ilocation=NULL, method.init=1)
{
- if(mode(llocation) != "character" && mode(llocation) != "name")
+ if (mode(llocation) != "character" && mode(llocation) != "name")
llocation = as.character(substitute(llocation))
- if(!is.Numeric(scale.arg, posit=TRUE)) stop("bad input for 'scale.arg'")
- if(!is.Numeric(method.init, allow=1, integ=TRUE, posit=TRUE) ||
+ if (!is.Numeric(scale.arg, posit=TRUE)) stop("bad input for 'scale.arg'")
+ if (!is.Numeric(method.init, allow=1, integ=TRUE, posit=TRUE) ||
method.init > 3)
stop("'method.init' must be 1 or 2 or 3")
- if(!is.list(elocation)) elocation = list()
+ if (!is.list(elocation)) elocation = list()
new("vglmff",
- blurb=c("One-parameter Cauchy distribution ",
- "(location unknown, scale known)\n\n",
- "Link: ",
- namesof("location", llocation, earg=elocation), "\n\n",
- "Mean: NA\n",
- "Variance: NA"),
+ blurb = c("One-parameter Cauchy distribution ",
+ "(location unknown, scale known)\n\n",
+ "Link: ",
+ namesof("location", llocation, earg=elocation), "\n\n",
+ "Mean: NA\n",
+ "Variance: NA"),
initialize=eval(substitute(expression({
predictors.names = namesof("location", .llocation,
earg=.elocation, tag=FALSE)
- if(ncol(cbind(y)) != 1)
+ if (ncol(cbind(y)) != 1)
stop("response must be a vector or a one-column matrix")
- if(!length(etastart)) {
- loc.init = if(length(.ilocation)) .ilocation else {
- if( .method.init == 2) median(rep(y,w)) else
- if( .method.init == 3) y else {
+ if (!length(etastart)) {
+ loc.init = if (length(.ilocation)) .ilocation else {
+ if ( .method.init == 2) median(rep(y,w)) else
+ if ( .method.init == 3) y else {
cauchy1.Loglikfun = function(loc, y, x, w, extraargs) {
scal = extraargs
sum(w * dcauchy(x=y, loc=loc, scale=scal, log=TRUE))
@@ -1284,7 +1285,7 @@ cauchy.control <- function(save.weight=TRUE, ...)
}
}
loc.init = rep(loc.init, len=n)
- if(.llocation == "loge") loc.init = abs(loc.init)+0.01
+ if (.llocation == "loge") loc.init = abs(loc.init)+0.01
etastart = theta2eta(loc.init, .llocation, earg=.elocation)
}
}), list( .scale.arg=scale.arg, .ilocation=ilocation,
@@ -1294,7 +1295,7 @@ cauchy.control <- function(save.weight=TRUE, ...)
eta2theta(eta, .llocation, earg= .elocation)
}, list( .llocation=llocation,
.elocation=elocation ))),
- last=eval(substitute(expression({
+ last = eval(substitute(expression({
misc$expected = TRUE
misc$link = c("location"= .llocation)
misc$earg = list(location= .elocation )
@@ -1304,7 +1305,7 @@ cauchy.control <- function(save.weight=TRUE, ...)
loglikelihood=eval(substitute(
function(mu,y,w,residuals= FALSE,eta, extra=NULL) {
location = eta2theta(eta, .llocation, earg=.elocation)
- if(residuals) stop("loglikelihood residuals not implemented yet") else {
+ if (residuals) stop("loglikelihood residuals not implemented yet") else {
sum(w * dcauchy(x=y, loc=location, scale= .scale.arg, log=TRUE))
}
}, list( .scale.arg=scale.arg, .elocation=elocation,
@@ -1334,17 +1335,17 @@ cauchy.control <- function(save.weight=TRUE, ...)
elocation=list(),
scale.arg=1, method.init=1)
{
- if(mode(llocation) != "character" && mode(llocation) != "name")
+ if (mode(llocation) != "character" && mode(llocation) != "name")
llocation = as.character(substitute(llocation))
- if(!is.Numeric(scale.arg, allow=1, posit=TRUE))
+ if (!is.Numeric(scale.arg, allow=1, posit=TRUE))
stop("'scale.arg' must be a single positive number")
- if(!is.Numeric(method.init, allow=1, integ=TRUE, posit=TRUE) ||
+ if (!is.Numeric(method.init, allow=1, integ=TRUE, posit=TRUE) ||
method.init > 2)
stop("'method.init' must be 1 or 2")
- if(!is.list(elocation)) elocation = list()
+ if (!is.list(elocation)) elocation = list()
new("vglmff",
- blurb=c("One-parameter logistic distribution ",
+ blurb = c("One-parameter logistic distribution ",
"(location unknown, scale known)\n\n",
"Link: ",
namesof("location", llocation, earg=elocation), "\n\n",
@@ -1353,10 +1354,10 @@ cauchy.control <- function(save.weight=TRUE, ...)
initialize=eval(substitute(expression({
predictors.names = namesof("location", .llocation,
earg= .elocation, tag=FALSE)
- if(!length(etastart)) {
- location.init = if( .method.init == 1) y else median(rep(y, w))
+ if (!length(etastart)) {
+ location.init = if ( .method.init == 1) y else median(rep(y, w))
location.init = rep(location.init, len=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( .method.init=method.init, .llocation=llocation,
@@ -1365,7 +1366,7 @@ cauchy.control <- function(save.weight=TRUE, ...)
eta2theta(eta, .llocation, earg= .elocation)
}, list( .llocation=llocation,
.elocation=elocation ))),
- last=eval(substitute(expression({
+ last = eval(substitute(expression({
misc$expected = TRUE
misc$link = c(location= .llocation)
misc$earg = list(location= .elocation )
@@ -1376,7 +1377,7 @@ cauchy.control <- function(save.weight=TRUE, ...)
function(mu,y,w,residuals= FALSE,eta, extra=NULL) {
location = eta2theta(eta, .llocation, earg= .elocation)
zedd = (y-location)/.scale.arg
- if(residuals) stop("loglikelihood residuals not implemented yet") else {
+ if (residuals) stop("loglikelihood residuals not implemented yet") else {
sum(w * dlogis(x=y, location = location,
scale = .scale.arg, log = TRUE))
}
@@ -1403,33 +1404,33 @@ cauchy.control <- function(save.weight=TRUE, ...)
erlang = function(shape.arg, link="loge", earg=list(), method.init=1)
{
- if(!is.Numeric(shape.arg, allow=1, integer=TRUE, positi=TRUE))
+ if (!is.Numeric(shape.arg, allow=1, integer=TRUE, positi=TRUE))
stop("'shape' must be a positive integer")
- if(!is.Numeric(method.init, allow=1, integer=TRUE, positi=TRUE) ||
+ if (!is.Numeric(method.init, allow=1, integer=TRUE, positi=TRUE) ||
method.init > 2)
stop("'method.init' must be 1 or 2")
- if(mode(link) != "character" && mode(link) != "name")
+ if (mode(link) != "character" && mode(link) != "name")
link = as.character(substitute(link))
- if(!is.list(earg)) earg = list()
+ if (!is.list(earg)) earg = list()
new("vglmff",
- blurb=c("Erlang distribution\n\n",
+ blurb = c("Erlang distribution\n\n",
"Link: ", namesof("scale", link, earg=earg), "\n", "\n",
"Mean: shape * scale", "\n",
"Variance: shape * scale^2"),
initialize=eval(substitute(expression({
- if(ncol(y <- as.matrix(y)) > 1)
+ if (ncol(y <- as.matrix(y)) > 1)
stop("erlang cannot handle matrix responses yet")
- if(any(y < 0))
+ if (any(y < 0))
stop("all y values must be >= 0")
predictors.names = namesof("scale", .link, earg=.earg, tag=FALSE)
- if(!length(etastart)) {
- if(.method.init==1)
+ if (!length(etastart)) {
+ if (.method.init==1)
sc.init = y / .shape.arg
- if(.method.init==2) {
+ if (.method.init==2) {
sc.init = median(y) / .shape.arg
sc.init = rep(sc.init, length=n)
}
@@ -1441,7 +1442,7 @@ cauchy.control <- function(save.weight=TRUE, ...)
sc = eta2theta(eta, .link, earg=.earg)
.shape.arg * sc
}, list( .link=link, .earg=earg, .shape.arg=shape.arg ))),
- last=eval(substitute(expression({
+ last = eval(substitute(expression({
misc$expected = TRUE
misc$link = c(scale= .link)
misc$earg = list(scale= .earg )
@@ -1450,7 +1451,7 @@ cauchy.control <- function(save.weight=TRUE, ...)
loglikelihood=eval(substitute(
function(mu,y,w,residuals= FALSE,eta, extra=NULL) {
sc = eta2theta(eta, .link, earg=.earg)
- if(residuals) stop("loglikelihood residuals not implemented yet") else {
+ if (residuals) stop("loglikelihood residuals not implemented yet") else {
sum(w * ((.shape.arg - 1) * log(y) - y / sc - .shape.arg * log(sc) -
lgamma( .shape.arg )))
}
@@ -1474,14 +1475,14 @@ cauchy.control <- function(save.weight=TRUE, ...)
dbort = function(x, Qsize=1, a=0.5, log=FALSE) {
- if(!is.logical(log.arg <- log))
+ if (!is.logical(log.arg <- log))
stop("bad input for argument 'log'")
rm(log)
- if(!is.Numeric(x)) stop("bad input for argument 'x'")
- if(!is.Numeric(Qsize, allow=1, integ=TRUE, posit=TRUE))
+ if (!is.Numeric(x)) stop("bad input for argument 'x'")
+ if (!is.Numeric(Qsize, allow=1, integ=TRUE, posit=TRUE))
stop("bad input for argument 'Qsize'")
- if(!is.Numeric(a, posit=TRUE) || max(a) >= 1)
+ if (!is.Numeric(a, posit=TRUE) || max(a) >= 1)
stop("bad input for argument 'a'")
N = max(length(x), length(Qsize), length(a))
x = rep(x, len=N); Qsize = rep(Qsize, len=N); a = rep(a, len=N);
@@ -1491,7 +1492,7 @@ dbort = function(x, Qsize=1, a=0.5, log=FALSE) {
ans[xok] = lgamma(1 + Qsize[xok]) - lgamma(x[xok] + 1 - Qsize[xok]) +
(x[xok] - 1 - Qsize[xok]) * log(x[xok]) +
(x[xok] - Qsize[xok]) * log(a[xok]) - a[xok] * x[xok]
- if(!log.arg) {
+ if (!log.arg) {
ans[xok] = exp(ans[xok])
}
ans
@@ -1499,11 +1500,11 @@ dbort = function(x, Qsize=1, a=0.5, log=FALSE) {
rbort = function(n, Qsize=1, a=0.5) {
- if(!is.Numeric(n, integ=TRUE, posit=TRUE, allow=1))
+ if (!is.Numeric(n, integ=TRUE, posit=TRUE, allow=1))
stop("bad input for argument 'n'")
- if(!is.Numeric(Qsize, allow=1, integ=TRUE, posit=TRUE))
+ if (!is.Numeric(Qsize, allow=1, integ=TRUE, posit=TRUE))
stop("bad input for argument 'Qsize'")
- if(!is.Numeric(a, posit=TRUE) || max(a) >= 1)
+ if (!is.Numeric(a, posit=TRUE) || max(a) >= 1)
stop("bad input for argument 'a'")
N = n
qsize = rep(Qsize, len=N); a = rep(a, len=N)
@@ -1522,33 +1523,33 @@ rbort = function(n, Qsize=1, a=0.5) {
borel.tanner = function(Qsize=1, link="logit", earg=list(), method.init=1)
{
- if(!is.Numeric(Qsize, allow=1, integ=TRUE, posit=TRUE))
+ if (!is.Numeric(Qsize, allow=1, integ=TRUE, posit=TRUE))
stop("bad input for argument 'Qsize'")
- if(mode(link) != "character" && mode(link) != "name")
+ if (mode(link) != "character" && mode(link) != "name")
link = as.character(substitute(link))
- if(!is.list(earg)) earg = list()
- if(!is.Numeric(method.init, allow=1, integ=TRUE, posit=TRUE) ||
+ if (!is.list(earg)) earg = list()
+ if (!is.Numeric(method.init, allow=1, integ=TRUE, posit=TRUE) ||
method.init > 4)
stop("'method.init' must be 1 or 2, 3 or 4")
new("vglmff",
- blurb=c("Borel-Tanner distribution\n\n",
+ blurb = c("Borel-Tanner distribution\n\n",
"Link: ",
namesof("a", link, earg=earg), "\n\n",
"Mean: Qsize/(1-a)",
"\n",
"Variance: Qsize*a / (1-a)^3"),
initialize=eval(substitute(expression({
- if(ncol(cbind(y)) != 1)
+ if (ncol(cbind(y)) != 1)
stop("response must be a vector or a one-column matrix")
- if(any(y < .Qsize))
+ if (any(y < .Qsize))
stop("all y values must be >= ", .Qsize)
- if(any(y != round(y)))
+ if (any(y != round(y)))
warning("response should be integer-valued")
predictors.names = namesof("a", .link, earg=.earg, tag=FALSE)
- if(!length(etastart)) {
+ if (!length(etastart)) {
a.init = switch(as.character( .method.init ),
"1"= 1 - .Qsize / (y+1/8),
"2"= rep(1 - .Qsize / weighted.mean(y,w), len=n),
@@ -1562,7 +1563,7 @@ rbort = function(n, Qsize=1, a=0.5) {
a = eta2theta(eta, .link, earg=.earg)
.Qsize / (1 - a)
}, list( .link=link, .earg=earg, .Qsize=Qsize ))),
- last=eval(substitute(expression({
+ last = eval(substitute(expression({
misc$expected = TRUE
misc$link = c(a= .link)
misc$earg = list(a= .earg )
@@ -1571,7 +1572,7 @@ rbort = function(n, Qsize=1, a=0.5) {
loglikelihood=eval(substitute(
function(mu,y,w,residuals= FALSE,eta, extra=NULL) {
aa = eta2theta(eta, .link, earg=.earg)
- if(residuals) stop("loglikelihood residuals not implemented yet") else {
+ if (residuals) stop("loglikelihood residuals not implemented yet") else {
sum(w * dbort(x=y, Qsize= .Qsize, a=aa, log=TRUE))
}
}, list( .link=link, .earg=earg, .Qsize=Qsize ))),
@@ -1592,12 +1593,12 @@ rbort = function(n, Qsize=1, a=0.5) {
dfelix = function(x, a=0.25, log = FALSE) {
- if(!is.logical(log.arg <- log))
+ if (!is.logical(log.arg <- log))
stop("bad input for argument 'log'")
rm(log)
- if(!is.Numeric(x)) stop("bad input for argument 'x'")
- if(!is.Numeric(a, posit=TRUE)) stop("bad input for argument 'a'")
+ if (!is.Numeric(x)) stop("bad input for argument 'x'")
+ if (!is.Numeric(a, posit=TRUE)) stop("bad input for argument 'a'")
N = max(length(x), length(a))
x = rep(x, len=N); a = rep(a, len=N);
@@ -1605,7 +1606,7 @@ dfelix = function(x, a=0.25, log = FALSE) {
ans = rep(if(log.arg) log(0) else 0, len=N) # loglikelihood
ans[xok] = ((x[xok]-3)/2) * log(x[xok]) + ((x[xok]-1)/2) * log(a[xok]) -
lgamma(x[xok]/2 + 0.5) - a[xok] * x[xok]
- if(!log.arg) {
+ if (!log.arg) {
ans[xok] = exp(ans[xok])
}
ans
@@ -1617,27 +1618,27 @@ dfelix = function(x, a=0.25, log = FALSE) {
earg=if(link=="elogit") list(min=0, max=0.5) else list(),
method.init=1)
{
- if(mode(link) != "character" && mode(link) != "name")
+ if (mode(link) != "character" && mode(link) != "name")
link = as.character(substitute(link))
- if(!is.list(earg)) earg = list()
- if(!is.Numeric(method.init, allow=1, integ=TRUE, posit=TRUE) ||
+ if (!is.list(earg)) earg = list()
+ if (!is.Numeric(method.init, allow=1, integ=TRUE, posit=TRUE) ||
method.init > 4)
stop("'method.init' must be 1 or 2, 3 or 4")
new("vglmff",
- blurb=c("Felix distribution\n\n",
+ blurb = c("Felix distribution\n\n",
"Link: ",
namesof("a", link, earg=earg), "\n\n",
"Mean: 1/(1-2*a)"),
initialize=eval(substitute(expression({
- if(ncol(cbind(y)) != 1)
+ if (ncol(cbind(y)) != 1)
stop("response must be a vector or a one-column matrix")
- if(any(y < 1) || any((y+1)/2 != round((y+1)/2)))
+ if (any(y < 1) || any((y+1)/2 != round((y+1)/2)))
warning("response should be positive, odd and integer-valued")
predictors.names = namesof("a", .link, earg=.earg, tag=FALSE)
- if(!length(etastart)) {
+ if (!length(etastart)) {
wymean = weighted.mean(y,w)
a.init = switch(as.character( .method.init ),
"1"= (y-1+1/8) / (2*(y+1/8)+1/8),
@@ -1652,7 +1653,7 @@ dfelix = function(x, a=0.25, log = FALSE) {
a = eta2theta(eta, .link, earg=.earg)
1 / (1 - 2*a)
}, list( .link=link, .earg=earg ))),
- last=eval(substitute(expression({
+ last = eval(substitute(expression({
misc$expected = TRUE
misc$link = c(a= .link)
misc$earg = list(a= .earg )
@@ -1660,7 +1661,7 @@ dfelix = function(x, a=0.25, log = FALSE) {
loglikelihood=eval(substitute(
function(mu,y,w,residuals= FALSE,eta, extra=NULL) {
aa = eta2theta(eta, .link, earg=.earg)
- if(residuals) stop("loglikelihood residuals not implemented yet") else {
+ if (residuals) stop("loglikelihood residuals not implemented yet") else {
sum(w * dfelix(x=y, a=aa, log = TRUE))
}
}, list( .link=link, .earg=earg ))),
@@ -1679,16 +1680,16 @@ dfelix = function(x, a=0.25, log = FALSE) {
}
dsnorm = function(x, location=0, scale=1, shape=0, log=FALSE) {
- if(!is.logical(log.arg <- log))
+ if (!is.logical(log.arg <- log))
stop("bad input for argument 'log'")
rm(log)
- if(!is.Numeric(scale, posit=TRUE))
+ if (!is.Numeric(scale, posit=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) {
+ if (log.arg) {
loglik
} else {
exp(loglik)
@@ -1698,11 +1699,11 @@ dsnorm = function(x, location=0, scale=1, shape=0, log=FALSE) {
rsnorm = function(n, location=0, scale=1, shape=0) {
- if(!is.Numeric(n, posit=TRUE, integ=TRUE, allow=1))
+ if (!is.Numeric(n, posit=TRUE, integ=TRUE, allow=1))
stop("bad input for argument 'n'")
- if(!is.Numeric(scale, posit=TRUE))
+ if (!is.Numeric(scale, posit=TRUE))
stop("bad input for argument 'scale'")
- if(!is.Numeric(shape)) stop("bad input for argument 'shape'")
+ if (!is.Numeric(shape)) stop("bad input for argument 'shape'")
rho = shape / sqrt(1 + shape^2)
u0 = rnorm(n)
v = rnorm(n)
@@ -1714,26 +1715,26 @@ rsnorm = function(n, location=0, scale=1, shape=0) {
skewnormal1 = function(lshape="identity", earg = list(), ishape=NULL,
nsimEIM=NULL)
{
- if(mode(lshape) != "character" && mode(lshape) != "name")
+ if (mode(lshape) != "character" && mode(lshape) != "name")
lshape = as.character(substitute(lshape))
- if(!is.list(earg)) earg = list()
- if(length(nsimEIM) &&
+ if (!is.list(earg)) earg = list()
+ if (length(nsimEIM) &&
(!is.Numeric(nsimEIM, allow=1, integ=TRUE) || nsimEIM <= 10))
stop("'nsimEIM' should be an integer greater than 10")
new("vglmff",
- blurb=c("1-parameter Skew-normal distribution\n\n",
+ blurb = c("1-parameter Skew-normal distribution\n\n",
"Link: ",
namesof("shape", lshape, earg=earg), "\n",
"Mean: shape * sqrt(2 / (pi * (1+shape^2 )))\n",
"Variance: 1-mu^2"),
initialize=eval(substitute(expression({
y = cbind(y)
- if(ncol(y) != 1)
+ if (ncol(y) != 1)
stop("response must be a vector or a one-column matrix")
predictors.names = namesof("shape", .lshape, earg=.earg, tag=FALSE)
- if(!length(etastart)) {
- init.shape = if(length( .ishape)) rep( .ishape, len=n) else {
+ if (!length(etastart)) {
+ init.shape = if (length( .ishape)) rep( .ishape, len=n) else {
temp = y
index = abs(y) < sqrt(2/pi)-0.01
temp[!index] = y[!index]
@@ -1747,7 +1748,7 @@ rsnorm = function(n, location=0, scale=1, shape=0) {
alpha = eta2theta(eta, .lshape, earg=.earg)
alpha * sqrt(2/(pi * (1+alpha^2 )))
}, list( .earg=earg, .lshape=lshape ))),
- last=eval(substitute(expression({
+ last = eval(substitute(expression({
misc$link = c(shape= .lshape)
misc$earg = list(shape= .earg )
misc$nsimEIM = .nsimEIM
@@ -1760,7 +1761,7 @@ rsnorm = function(n, location=0, scale=1, shape=0) {
loglikelihood=eval(substitute(
function(mu, y, w, residuals = FALSE, eta, extra=NULL) {
alpha = eta2theta(eta, .lshape, earg=.earg)
- if(residuals) stop("loglikelihood residuals not implemented yet") else {
+ if (residuals) stop("loglikelihood residuals not implemented yet") else {
sum(w * dsnorm(x=y, location=0, scale=1, shape=alpha, log=TRUE))
}
}, list( .earg=earg, .lshape=lshape ))),
@@ -1775,7 +1776,7 @@ rsnorm = function(n, location=0, scale=1, shape=0) {
w * dl.dshape * dshape.deta
}), list( .earg=earg, .lshape=lshape ))),
weight=eval(substitute(expression({
- if( length( .nsimEIM )) {
+ if ( length( .nsimEIM )) {
run.mean = 0
for(ii in 1:(.nsimEIM)) {
ysim = rsnorm(n, location = 0, scale = 1, shape = alpha)
@@ -1786,7 +1787,7 @@ rsnorm = function(n, location=0, scale=1, shape=0) {
rm(ysim)
run.mean = ((ii-1) * run.mean + d2l.dshape2) / ii
}
- if(intercept.only)
+ if (intercept.only)
run.mean = mean(run.mean)
wz = -w * (dshape.deta^2) * run.mean
} else {
@@ -1809,31 +1810,31 @@ rsnorm = function(n, location=0, scale=1, shape=0) {
ephi=list(),
imu=NULL, iphi=NULL, method.init=1, zero=NULL)
{
- if(!is.Numeric(A, allow=1) || !is.Numeric(B, allow=1) || A >= B)
+ if (!is.Numeric(A, allow=1) || !is.Numeric(B, allow=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")
+ if (mode(lmu) != "character" && mode(lmu) != "name")
lmu = as.character(substitute(lmu))
- if(mode(lphi) != "character" && mode(lphi) != "name")
+ if (mode(lphi) != "character" && mode(lphi) != "name")
lphi = as.character(substitute(lphi))
- if(length(zero) && !is.Numeric(zero, integer=TRUE, posit=TRUE))
+ if (length(zero) && !is.Numeric(zero, integer=TRUE, posit=TRUE))
stop("bad input for argument 'zero'")
- if(length(imu) && (!is.Numeric(imu, posit=TRUE) ||
+ if (length(imu) && (!is.Numeric(imu, posit=TRUE) ||
any(imu <= A) || any(imu >= B)))
stop("bad input for argument 'imu'")
- if(length(iphi) && !is.Numeric(iphi, posit=TRUE))
+ if (length(iphi) && !is.Numeric(iphi, posit=TRUE))
stop("bad input for argument 'iphi'")
- if(!is.Numeric(method.init, allow=1, integ=TRUE, posit=TRUE) ||
+ if (!is.Numeric(method.init, allow=1, integ=TRUE, posit=TRUE) ||
method.init > 2)
stop("'method.init' must be 1 or 2")
- if(!is.list(emu)) emu = list()
- if(!is.list(ephi)) ephi = list()
+ if (!is.list(emu)) emu = list()
+ if (!is.list(ephi)) ephi = list()
new("vglmff",
- 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)",
+ 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,
"-y)^(((1-mu1)*phi)-1) / \n(beta(mu1*phi,(1-mu1)*phi) * (",
@@ -1848,18 +1849,18 @@ rsnorm = function(n, location=0, scale=1, shape=0) {
constraints = cm.zero.vgam(constraints, x, .zero, M)
}), list( .zero=zero ))),
initialize=eval(substitute(expression({
- if(min(y) <= .A || max(y) >= .B)
+ if (min(y) <= .A || max(y) >= .B)
stop("data not within (A, B)")
- if(ncol(cbind(y)) != 1)
+ if (ncol(cbind(y)) != 1)
stop("response must be a vector or a one-column matrix")
predictors.names = c(namesof("mu", .lmu, .emu, short=TRUE),
namesof("phi", .lphi, .ephi, short=TRUE))
- if(!length(etastart)) {
- mu.init = if(is.Numeric(.imu)) .imu else
+ if (!length(etastart)) {
+ mu.init = if (is.Numeric(.imu)) .imu else
{if(.method.init==1) weighted.mean(y,w) else
median(rep(y,w))}
mu1.init = (mu.init - .A) / (.B - .A) # In (0,1)
- phi.init = if(is.Numeric(.iphi)) .iphi else
+ phi.init = if (is.Numeric(.iphi)) .iphi else
max(0.01, -1 + (.B-.A)^2 * mu1.init*(1-mu1.init)/var(y))
etastart = matrix(0, n, 2)
etastart[,1] = theta2eta(mu.init, .lmu, earg=.emu )
@@ -1871,7 +1872,7 @@ rsnorm = function(n, location=0, scale=1, shape=0) {
mu = eta2theta(eta[,1], .lmu, .emu )
mu
}, list( .lmu=lmu, .emu=emu, .A=A, .B=B))),
- last=eval(substitute(expression({
+ last = eval(substitute(expression({
misc$link = c(mu = .lmu, phi = .lphi)
misc$limits = c(.A, .B)
misc$earg = list(mu= .emu, phi= .ephi)
@@ -1881,9 +1882,9 @@ rsnorm = function(n, location=0, scale=1, shape=0) {
loglikelihood=eval(substitute(
function(mu, y, w, residuals= FALSE, eta, extra=NULL){
mu = eta2theta(eta[,1], .lmu, .emu )
- m1u = if( .stdbeta ) mu else (mu - .A) / (.B - .A)
+ m1u = if ( .stdbeta ) mu else (mu - .A) / (.B - .A)
phi = eta2theta(eta[,2], .lphi, .ephi )
- if(residuals) stop("loglikelihood residuals not implemented yet") else {
+ if (residuals) stop("loglikelihood residuals not implemented yet") else {
shape1 = phi * m1u
shape2 = (1 - m1u) * phi
zedd = (y - .A) / ( .B - .A)
@@ -1896,13 +1897,13 @@ rsnorm = function(n, location=0, scale=1, shape=0) {
deriv=eval(substitute(expression({
mu = eta2theta(eta[,1], .lmu, .emu )
phi = eta2theta(eta[,2], .lphi, .ephi )
- m1u = if( .stdbeta ) mu else (mu - .A) / (.B - .A)
+ m1u = if ( .stdbeta ) mu else (mu - .A) / (.B - .A)
dmu.deta = dtheta.deta(mu, .lmu, .emu )
dmu1.dmu = 1 / (.B - .A)
dphi.deta = dtheta.deta(phi, .lphi, .ephi )
temp1 = m1u*phi
temp2 = (1-m1u)*phi
- if( .stdbeta ) {
+ if ( .stdbeta ) {
dl.dmu1 = phi*(digamma(temp2) - digamma(temp1) + log(y) - log1p(-y))
dl.dphi = digamma(phi) - mu*digamma(temp1) - (1-mu)*digamma(temp2) +
mu*log(y) + (1-mu)*log1p(-y)
@@ -1933,79 +1934,78 @@ rsnorm = function(n, location=0, scale=1, shape=0) {
- beta.ab = function(lshape1="loge", lshape2="loge",
- eshape1=list(), eshape2=list(),
- i1=NULL, i2=NULL, trim=0.05,
- A=0, B=1, parallel=FALSE, zero=NULL)
+ beta.ab = function(lshape1 = "loge", lshape2 = "loge",
+ eshape1 = list(), eshape2 = list(),
+ i1 = NULL, i2 = NULL, trim = 0.05,
+ A = 0, B = 1, parallel = FALSE, zero = NULL)
{
- if(mode(lshape1) != "character" && mode(lshape1) != "name")
+ if (mode(lshape1) != "character" && mode(lshape1) != "name")
lshape1 = as.character(substitute(lshape1))
- if(mode(lshape2) != "character" && mode(lshape2) != "name")
+ if (mode(lshape2) != "character" && mode(lshape2) != "name")
lshape2 = as.character(substitute(lshape2))
- if(length(zero) && !is.Numeric(zero, integer=TRUE, posit=TRUE))
+ if (length(zero) && !is.Numeric(zero, integer=TRUE, posit=TRUE))
stop("bad input for argument 'zero'")
- if(length( i1 ) && !is.Numeric( i1, posit=TRUE))
+ if (length( i1 ) && !is.Numeric( i1, posit=TRUE))
stop("bad input for argument 'i1'")
- if(length( i2 ) && !is.Numeric( i2, posit=TRUE))
+ if (length( i2 ) && !is.Numeric( i2, posit=TRUE))
stop("bad input for argument 'i2'")
- if(!is.Numeric(A, allow=1) || !is.Numeric(B, allow=1) || A >= B)
+ if (!is.Numeric(A, allow=1) || !is.Numeric(B, allow=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(eshape1)) eshape1 = list()
- if(!is.list(eshape2)) eshape2 = list()
+ stdbeta = (A == 0 && B == 1) # stdbeta == T iff standard beta distribution
+ if (!is.list(eshape1)) eshape1 = list()
+ if (!is.list(eshape2)) eshape2 = list()
new("vglmff",
- blurb=c("Two-parameter Beta distribution ",
- "(shape parameters parameterization)\n",
- if(stdbeta)
- paste("y^(shape1-1) * (1-y)^(shape2-1) / B(shape1,shape2),",
- "0<=y<=1, shape1>0, shape2>0\n\n")
- else
- paste("(y-",A,")^(shape1-1) * (",B,
- "-y)^(shape2-1) / [B(shape1,shape2) * (",
- B, "-", A, ")^(shape1+shape2-1)], ",
- A,"<=y<=",B," shape1>0, shape2>0\n\n", sep=""),
- "Links: ",
- namesof("shape1", lshape1, earg=eshape1), ", ",
- namesof("shape2", lshape2, earg=eshape2)),
+ blurb = c("Two-parameter Beta distribution ",
+ "(shape parameters parameterization)\n",
+ if (stdbeta)
+ paste("y^(shape1-1) * (1-y)^(shape2-1) / B(shape1,shape2),",
+ "0<=y<=1, shape1>0, shape2>0\n\n") else
+ paste("(y-",A,")^(shape1-1) * (",B,
+ "-y)^(shape2-1) / [B(shape1,shape2) * (",
+ B, "-", A, ")^(shape1+shape2-1)], ",
+ A,"<=y<=",B," shape1>0, shape2>0\n\n", sep=""),
+ "Links: ",
+ namesof("shape1", lshape1, earg=eshape1), ", ",
+ namesof("shape2", lshape2, earg=eshape2)),
constraints=eval(substitute(expression({
constraints = cm.vgam(matrix(1,M,1), x, .parallel, constraints, int= TRUE)
constraints = cm.zero.vgam(constraints, x, .zero, M)
}), list( .parallel=parallel, .zero=zero ))),
initialize=eval(substitute(expression({
- if(min(y) <= .A || max(y) >= .B)
+ if (min(y) <= .A || max(y) >= .B)
stop("data not within (A, B)")
- if(ncol(cbind(y)) != 1)
+ if (ncol(cbind(y)) != 1)
stop("response must be a vector or a one-column matrix")
predictors.names =
c(namesof("shape1", .lshape1, earg= .eshape1, short=TRUE),
namesof("shape2", .lshape2, earg= .eshape2, short=TRUE))
- if(is.Numeric( .i1 ) && is.Numeric( .i2 )) {
- etastart = matrix(0, n, 2)
- etastart[,1] = theta2eta( .i1, .lshape1, earg= .eshape1 )
- etastart[,2] = theta2eta( .i2, .lshape2, earg= .eshape2 )
- }
- if(!length(etastart)) {
- mu1d = mean(y, trim=.trim)
- uu = (mu1d-.A) / (.B - .A)
+
+ if (!length(etastart)) {
+ 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
- qinit = pinit * (1-uu) / uu
+ pinit = max(0.01, uu^2 * (1 - uu) * DD / var(y) - uu)
+ qinit = max(0.01, pinit * (1 - uu) / uu)
etastart = matrix(0, n, 2)
etastart[,1] = theta2eta( pinit, .lshape1, earg= .eshape1 )
etastart[,2] = theta2eta( qinit, .lshape2, earg= .eshape2 )
}
- }), list( .lshape1=lshape1, .lshape2=lshape2,
- .i1=i1, .i2=i2, .trim=trim, .A=A, .B=B,
- .eshape1=eshape1, .eshape2=eshape2 ))),
+ if (is.Numeric( .i1 ))
+ etastart[,1] = theta2eta( .i1, .lshape1, earg= .eshape1 )
+ if (is.Numeric( .i2 ))
+ etastart[,2] = theta2eta( .i2, .lshape2, earg= .eshape2 )
+ }), list( .lshape1 = lshape1, .lshape2 = lshape2,
+ .i1 = i1, .i2 = i2, .trim = trim, .A = A, .B = B,
+ .eshape1 = eshape1, .eshape2 = eshape2 ))),
inverse=eval(substitute(function(eta, extra=NULL) {
shapes = cbind(eta2theta(eta[,1], .lshape1, earg= .eshape1 ),
eta2theta(eta[,2], .lshape2, earg= .eshape2 ))
.A + (.B-.A) * shapes[,1] / (shapes[,1] + shapes[,2])
}, list( .lshape1=lshape1, .lshape2=lshape2, .A=A, .B=B,
.eshape1=eshape1, .eshape2=eshape2 ))),
- last=eval(substitute(expression({
+ last = eval(substitute(expression({
misc$link = c(shape1 = .lshape1, shape2 = .lshape2)
misc$limits = c(.A, .B)
misc$earg = list(shape1= .eshape1, shape2= .eshape2)
@@ -2015,7 +2015,7 @@ rsnorm = function(n, location=0, scale=1, shape=0) {
function(mu, y, w, residuals= FALSE, eta, extra=NULL){
shapes = cbind(eta2theta(eta[,1], .lshape1, earg= .eshape1 ),
eta2theta(eta[,2], .lshape2, earg= .eshape2 ))
- if(residuals) stop("loglikelihood residuals not implemented yet") else {
+ if (residuals) stop("loglikelihood residuals not implemented yet") else {
zedd = (y - .A) / ( .B - .A)
sum(w * (dbeta(x=zedd, shape1=shapes[,1], shape2=shapes[,2],
log=TRUE) - log( abs( .B - .A ))))
@@ -2056,35 +2056,35 @@ rsnorm = function(n, location=0, scale=1, shape=0) {
- if(mode(link) != "character" && mode(link) != "name")
+ if (mode(link) != "character" && mode(link) != "name")
link = as.character(substitute(link))
- if(!is.list(earg)) earg = list()
+ if (!is.list(earg)) earg = list()
new("vglmff",
- blurb=c("Four-parameter Beta distribution\n",
+ blurb = c("Four-parameter Beta distribution\n",
"(y-A)^(shape1-1) * (B-y)^(shape2-1), A < y < B \n\n",
"Links: ",
namesof("shape1", link, earg=earg), ", ",
namesof("shape2", link, earg=earg), ", ",
" A, B"),
initialize=eval(substitute(expression({
- if(!is.vector(y) || (is.matrix(y) && ncol(y) != 1))
+ if (!is.vector(y) || (is.matrix(y) && ncol(y) != 1))
stop("y must be a vector or a one-column matrix")
- if(length(.iA) && any(y < .iA))
- stop("initial A value out of range")
- if(length(.iB) && any(y > .iB))
- stop("initial B value out of range")
+ if (length(.iA) && any(y < .iA))
+ stop("initial 'A' value out of range")
+ if (length(.iB) && any(y > .iB))
+ stop("initial 'B' value out of range")
predictors.names = c(
namesof("shape1", .link, earg=.earg, short=TRUE),
namesof("shape2", .link, earg=.earg, short=TRUE), "A", "B")
my.range = diff(range(y))
- if(!length(etastart)) {
+ if (!length(etastart)) {
etastart = cbind(shape1= rep(.i1, len=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 ))),
inverse=eval(substitute(function(eta, extra=NULL) {
@@ -2093,7 +2093,7 @@ rsnorm = function(n, location=0, scale=1, shape=0) {
.B = eta[,4]
.A + (.B-.A) * shapes[,1] / (shapes[,1] + shapes[,2])
}, list( .link=link, .earg=earg ))),
- last=eval(substitute(expression({
+ last = eval(substitute(expression({
misc$link = c(shape1 = .link, shape2 = .link,
A="identity", B="identity")
misc$earg = list(shape1 = .earg, shape2 = .earg,
@@ -2105,7 +2105,7 @@ rsnorm = function(n, location=0, scale=1, shape=0) {
.A = eta[,3]
.B = eta[,4]
temp = lbeta(shapes[,1], shapes[,2])
- if(residuals) stop("loglikelihood residuals not implemented yet") else
+ if (residuals) stop("loglikelihood residuals not implemented yet") else
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 ))),
@@ -2163,13 +2163,13 @@ rsnorm = function(n, location=0, scale=1, shape=0) {
simple.exponential = function()
{
new("vglmff",
- blurb=c("Simple Exponential distribution\n",
+ blurb = c("Simple Exponential distribution\n",
"Link: log(rate)\n"),
deviance= function(mu, y, w, residuals = FALSE, eta, extra=NULL) {
devy = -log(y) - 1
devmu = -log(mu) - y/mu
devi = 2 * (devy - devmu)
- if(residuals) sign(y - mu) * sqrt(abs(devi) * w) else sum(w * devi)
+ if (residuals) sign(y - mu) * sqrt(abs(devi) * w) else sum(w * devi)
},
initialize=expression({
predictors.names = "log(rate)"
@@ -2195,48 +2195,48 @@ rsnorm = function(n, location=0, scale=1, shape=0) {
exponential = function(link="loge", earg=list(), location=0, expected=TRUE) {
- if(!is.Numeric(location, allow=1))
+ if (!is.Numeric(location, allow=1))
stop("bad input for argument 'location'")
- if(mode(link) != "character" && mode(link) != "name")
+ if (mode(link) != "character" && mode(link) != "name")
link = as.character(substitute(link))
- if(!is.list(earg)) earg = list()
- if(!is.logical(expected) || length(expected) != 1)
+ if (!is.list(earg)) earg = list()
+ if (!is.logical(expected) || length(expected) != 1)
stop("bad input for argument 'expected'")
new("vglmff",
- blurb=c("Exponential distribution\n\n",
+ blurb = c("Exponential distribution\n\n",
"Link: ", namesof("rate", link, tag= TRUE), "\n",
"Mean: ", "mu = ",
- if(location == 0) "1/rate" else
+ if (location == 0) "1/rate" else
paste(location, "+ 1/rate"), "\n",
"Variance: ",
- if(location==0) "Exponential: mu^2" else
+ if (location==0) "Exponential: mu^2" else
paste("(mu-", location, ")^2", sep="")),
deviance=eval(substitute(
function(mu,y,w,residuals= FALSE,eta,extra=NULL) {
devy = -log(y - .location) - 1
devmu = -log(mu - .location) - (y - .location)/(mu - .location)
devi = 2 * (devy - devmu)
- if(residuals)
+ if (residuals)
sign(y - mu) * sqrt(abs(devi) * w) else
sum(w * devi)
}, list( .location=location, .earg=earg ))),
initialize=eval(substitute(expression({
- if(ncol(cbind(y)) != 1)
+ if (ncol(cbind(y)) != 1)
stop("response must be a vector or a one-column matrix")
extra$loc = .location # This is passed into, e.g., link, deriv etc.
- if(any(y <= extra$loc))
+ if (any(y <= extra$loc))
stop("all responses must be greater than ", extra$loc)
predictors.names = namesof("rate", .link, tag=FALSE)
mu = y + (y == extra$loc) / 8
- if(!length(etastart))
+ if (!length(etastart))
etastart = theta2eta(1/(mu-extra$loc), .link, earg=.earg)
}), list( .location=location, .link=link, .earg=earg ))),
inverse=eval(substitute(function(eta, extra=NULL)
extra$loc + 1 / eta2theta(eta, .link, earg=.earg),
list( .link=link, .earg=earg ))),
- last=eval(substitute(expression({
+ last = eval(substitute(expression({
misc$location = extra$loc
misc$link = c(rate = .link)
misc$earg = list(rate = .earg)
@@ -2255,7 +2255,7 @@ rsnorm = function(n, location=0, scale=1, shape=0) {
weight=eval(substitute(expression({
d2l.drate2 = - ((mu-extra$loc)^2)
wz = -(drate.deta^2) * d2l.drate2
- if(! .expected) {
+ if (! .expected) {
# Use the observed info matrix rather than the expected
d2rate.deta2 = d2theta.deta2(rate, .link, earg=.earg)
wz = wz - dl.drate * d2rate.deta2
@@ -2269,30 +2269,30 @@ rsnorm = function(n, location=0, scale=1, shape=0) {
gamma1 = function(link="loge", earg=list())
{
- if(mode(link) != "character" && mode(link) != "name")
+ if (mode(link) != "character" && mode(link) != "name")
link = as.character(substitute(link))
- if(!is.list(earg)) earg = list()
+ if (!is.list(earg)) earg = list()
new("vglmff",
- blurb=c("1-parameter Gamma distribution\n",
+ blurb = c("1-parameter Gamma distribution\n",
"Link: ",
namesof("shape", link, earg=earg, tag= TRUE), "\n",
"Mean: mu (=shape)\n",
"Variance: mu (=shape)"),
initialize=eval(substitute(expression({
- if(any(y <= 0))
+ if (any(y <= 0))
stop("all responses must be positive")
- M = if(is.matrix(y)) ncol(y) else 1
- temp.names = if(M == 1) "shape" else paste("shape", 1:M, sep="")
+ M = if (is.matrix(y)) ncol(y) else 1
+ temp.names = if (M == 1) "shape" else paste("shape", 1:M, sep="")
predictors.names = namesof(temp.names, .link, earg=.earg, short=TRUE)
- if(!length(etastart))
+ if (!length(etastart))
etastart = cbind(theta2eta(y+1/8, .link, earg=.earg ))
}), list( .link=link, .earg=earg ))),
inverse=eval(substitute(function(eta, extra=NULL)
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="")
+ last = eval(substitute(expression({
+ temp.names = if (M == 1) "shape" else paste("shape", 1:M, sep="")
misc$link = rep( .link, length=M)
names(misc$link) = temp.names
misc$earg = vector("list", M)
@@ -2304,7 +2304,7 @@ rsnorm = function(n, location=0, scale=1, shape=0) {
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 implemented yet") else {
+ if (residuals) stop("loglikelihood residuals not implemented yet") else {
sum(w * dgamma(x=y, shape=mu, scale=1, log=TRUE))
},
vfamily=c("gamma1"),
@@ -2326,23 +2326,23 @@ rsnorm = function(n, location=0, scale=1, shape=0) {
erate=list(), eshape=list(),
irate=NULL, ishape=NULL, expected=TRUE, zero=2)
{
- if(mode(lrate) != "character" && mode(lrate) != "name")
+ if (mode(lrate) != "character" && mode(lrate) != "name")
lrate = as.character(substitute(lrate))
- if(mode(lshape) != "character" && mode(lshape) != "name")
+ if (mode(lshape) != "character" && mode(lshape) != "name")
lshape = as.character(substitute(lshape))
- if(length( irate) && !is.Numeric(irate, posit=TRUE))
+ if (length( irate) && !is.Numeric(irate, posit=TRUE))
stop("bad input for argument 'irate'")
- if(length( ishape) && !is.Numeric(ishape, posit=TRUE))
+ if (length( ishape) && !is.Numeric(ishape, posit=TRUE))
stop("bad input for argument 'ishape'")
- if(length(zero) && !is.Numeric(zero, integer=TRUE, posit=TRUE))
+ if (length(zero) && !is.Numeric(zero, integer=TRUE, posit=TRUE))
stop("bad input for argument 'zero'")
- if(!is.logical(expected) || length(expected) != 1)
+ if (!is.logical(expected) || length(expected) != 1)
stop("bad input for argument 'expected'")
- if(!is.list(erate)) erate = list()
- if(!is.list(eshape)) eshape = list()
+ if (!is.list(erate)) erate = list()
+ if (!is.list(eshape)) eshape = list()
new("vglmff",
- blurb=c("2-parameter Gamma distribution\n",
+ blurb = c("2-parameter Gamma distribution\n",
"Links: ",
namesof("rate", lrate, earg=erate), ", ",
namesof("shape", lshape, earg=eshape), "\n",
@@ -2353,21 +2353,21 @@ rsnorm = function(n, location=0, scale=1, shape=0) {
}), list( .zero=zero ))),
initialize=eval(substitute(expression({
# Error check
- if(ncol(cbind(y)) != 1)
+ if (ncol(cbind(y)) != 1)
stop("response must be a vector or a one-column matrix")
- if(any(y <= 0))
+ if (any(y <= 0))
stop("all responses must be positive")
predictors.names = c(namesof("rate", .lrate, earg=.erate, tag=FALSE),
namesof("shape", .lshape, earg=.eshape, tag=FALSE))
- if(!length(etastart)) {
+ if (!length(etastart)) {
mymu = y + 0.167 * (y == 0)
junk = lsfit(x, y, wt = w, intercept = FALSE)
var.y.est = sum(w * junk$resid^2) / (nrow(x) - length(junk$coef))
- init.shape = if(length( .ishape)) .ishape else mymu^2 / var.y.est
- init.rate = if(length( .irate)) .irate else init.shape / mymu
+ init.shape = if (length( .ishape)) .ishape else mymu^2 / var.y.est
+ init.rate = if (length( .irate)) .irate else init.shape / mymu
init.rate = rep(init.rate, len=n)
init.shape = rep(init.shape, len=n)
- if( .lshape == "loglog")
+ if ( .lshape == "loglog")
init.shape[init.shape <= 1] = 3.1 #Hopefully value is big enough
etastart = cbind(theta2eta(init.rate, .lrate, earg=.erate),
theta2eta(init.shape, .lshape, earg=.eshape))
@@ -2379,7 +2379,7 @@ rsnorm = function(n, location=0, scale=1, shape=0) {
earg=.erate)
}, list( .lrate=lrate, .lshape=lshape,
.erate=erate, .eshape=eshape ))),
- last=eval(substitute(expression({
+ last = eval(substitute(expression({
misc$link = c(rate= .lrate, shape= .lshape)
misc$earg = list(rate= .erate, shape= .eshape)
}), list( .lrate=lrate, .lshape=lshape,
@@ -2388,7 +2388,7 @@ rsnorm = function(n, location=0, scale=1, shape=0) {
function(mu, y, w, residuals= FALSE,eta, extra=NULL) {
rate = eta2theta(eta[,1], .lrate, earg=.erate)
shape = eta2theta(eta[,2], .lshape, earg=.eshape)
- if(residuals) stop("loglikelihood residuals not implemented yet") else {
+ if (residuals) stop("loglikelihood residuals not implemented yet") else {
sum(w * dgamma(x=y, shape=shape, rate=rate, log=TRUE))
}
}, list( .lrate=lrate, .lshape=lshape,
@@ -2412,7 +2412,7 @@ rsnorm = function(n, location=0, scale=1, shape=0) {
wz[,iam(1,1,M)] = -d2l.drate2 * dratedeta^2
wz[,iam(2,2,M)] = -d2l.dshape2 * dshape.deta^2
wz[,iam(1,2,M)] = -d2l.drateshape * dratedeta * dshape.deta
- if(! .expected) {
+ if (! .expected) {
d2ratedeta2 = d2theta.deta2(rate, .lrate, earg=.erate)
d2shapedeta2 = d2theta.deta2(shape, .lshape, earg=.eshape)
wz[,iam(1,1,M)] = wz[,iam(1,1,M)] - dl.drate * d2ratedeta2
@@ -2430,23 +2430,23 @@ rsnorm = function(n, location=0, scale=1, shape=0) {
method.init=1,
deviance.arg=FALSE, ishape=NULL, zero=-2)
{
- if(mode(lmu) != "character" && mode(lmu) != "name")
+ if (mode(lmu) != "character" && mode(lmu) != "name")
lmu = as.character(substitute(lmu))
- if(mode(lshape) != "character" && mode(lshape) != "name")
+ if (mode(lshape) != "character" && mode(lshape) != "name")
lshape = as.character(substitute(lshape))
- if(length(zero) && !is.Numeric(zero, integer=TRUE))
+ if (length(zero) && !is.Numeric(zero, integer=TRUE))
stop("bad input for argument 'zero'")
- if(length( ishape) && !is.Numeric(ishape, posit=TRUE))
+ if (length( ishape) && !is.Numeric(ishape, posit=TRUE))
stop("bad input for argument 'ishape'")
- if(!is.Numeric(method.init, allow=1, integ=TRUE, posit=TRUE) ||
+ if (!is.Numeric(method.init, allow=1, integ=TRUE, posit=TRUE) ||
method.init > 2)
stop("'method.init' must be 1 or 2")
- if(!is.list(emu)) emu = list()
- if(!is.list(eshape)) eshape = list()
+ if (!is.list(emu)) emu = list()
+ if (!is.list(eshape)) eshape = list()
ans =
new("vglmff",
- blurb=c("2-parameter Gamma distribution",
+ blurb = c("2-parameter Gamma distribution",
" (McCullagh and Nelder 1989 parameterization)\n",
"Links: ",
namesof("mu", lmu, earg=emu), ", ",
@@ -2455,22 +2455,22 @@ rsnorm = function(n, location=0, scale=1, shape=0) {
"Variance: (mu^2)/shape"),
constraints=eval(substitute(expression({
temp752 = .zero
- if(length(temp752) && all(temp752 == -2))
+ if (length(temp752) && all(temp752 == -2))
temp752 = 2*(1:ncol(y))
constraints = cm.zero.vgam(constraints, x, temp752, M)
}), list( .zero=zero ))),
initialize=eval(substitute(expression({
assign("CQO.FastAlgorithm", ( .lmu == "loge" && .lshape == "loge"),
envir = VGAMenv)
- if(any(function.name == c("cqo","cao")) &&
+ if (any(function.name == c("cqo","cao")) &&
is.Numeric( .zero, allow=1) && .zero != -2)
stop("argument zero=-2 is required")
y = as.matrix(y)
M = 2 * ncol(y)
NOS = ncoly = ncol(y) # Number of species
- temp1.names = if(NOS==1) "mu" else paste("mu", 1:NOS, sep="")
- temp2.names = if(NOS==1) "shape" else paste("shape", 1:NOS, sep="")
+ temp1.names = if (NOS==1) "mu" else paste("mu", 1:NOS, sep="")
+ temp2.names = if (NOS==1) "shape" else paste("shape", 1:NOS, sep="")
predictors.names =
c(namesof(temp1.names, .lmu, earg=.emu, tag=FALSE),
namesof(temp2.names, .lshape, earg=.eshape, tag=FALSE))
@@ -2478,12 +2478,12 @@ rsnorm = function(n, location=0, scale=1, shape=0) {
# Error check
- if(any(y <= 0))
+ if (any(y <= 0))
stop("all responses must be positive") # see @loglikelihood
- if(!length(etastart)) {
+ if (!length(etastart)) {
init.shape = matrix(1.0, n, NOS)
mymu = y # + 0.167 * (y == 0) # method.init == 1 (the default)
- if( .method.init == 2) {
+ if ( .method.init == 2) {
for(ii in 1:ncol(y)) {
mymu[,ii] = weighted.mean(y[,ii], w=w)
}
@@ -2491,9 +2491,9 @@ rsnorm = function(n, location=0, scale=1, shape=0) {
for(spp in 1:NOS) {
junk = lsfit(x, y[,spp], wt = w, intercept = FALSE)
var.y.est = sum(w * junk$resid^2) / (n - length(junk$coef))
- init.shape[,spp] = if(length( .ishape)) .ishape else
+ init.shape[,spp] = if (length( .ishape)) .ishape else
mymu[,spp]^2 / var.y.est
- if( .lshape == "loglog") init.shape[init.shape[,spp] <=
+ if ( .lshape == "loglog") init.shape[init.shape[,spp] <=
1,spp] = 3.1 # Hopefully value is big enough
}
etastart = cbind(theta2eta(mymu, .lmu, earg=.emu ),
@@ -2507,12 +2507,12 @@ rsnorm = function(n, location=0, scale=1, shape=0) {
NOS = ncol(eta) / 2
eta2theta(eta[,2*(1:NOS)-1,drop=FALSE], .lmu, earg=.emu )
}, list( .lmu=lmu, .emu=emu ))),
- last=eval(substitute(expression({
- if(exists("CQO.FastAlgorithm", envir = VGAMenv))
+ last = eval(substitute(expression({
+ if (exists("CQO.FastAlgorithm", envir = VGAMenv))
rm("CQO.FastAlgorithm", envir = VGAMenv)
tmp34 = c(rep( .lmu, length=NOS), rep( .lshape, length=NOS))
names(tmp34) = c(if(NOS==1) "mu" else paste("mu", 1:NOS, sep=""),
- if(NOS==1) "shape" else paste("shape", 1:NOS, sep=""))
+ if (NOS==1) "shape" else paste("shape", 1:NOS, sep=""))
tmp34 = tmp34[interleave.VGAM(M, M=2)]
misc$link = tmp34 # Already named
misc$earg = vector("list", M)
@@ -2534,7 +2534,7 @@ rsnorm = function(n, location=0, scale=1, shape=0) {
NOS = ncol(eta) / 2
mymu = mu # eta2theta(eta[,2*(1:NOS)-1], .lmu, earg=.emu )
shapemat = eta2theta(eta[,2*(1:NOS),drop=FALSE], .lshape, earg=.eshape )
- if(residuals) stop("loglikelihood residuals not implemented yet") else {
+ if (residuals) stop("loglikelihood residuals not implemented yet") else {
sum(w * dgamma(x=y, shape=c(shapemat), scale=c(mymu/shapemat),
log=TRUE))
}
@@ -2564,18 +2564,18 @@ rsnorm = function(n, location=0, scale=1, shape=0) {
w * wz
}), list( .lmu=lmu ))))
- if(deviance.arg) ans at deviance=eval(substitute(
+ if (deviance.arg) ans at deviance=eval(substitute(
function(mu,y,w,residuals= FALSE,eta,extra=NULL) {
NOS = ncol(eta) / 2
temp300 = eta[,2*(1:NOS),drop=FALSE]
- if( .lshape == "loge") {
+ if ( .lshape == "loge") {
bigval = 28
temp300[temp300 > bigval] = bigval
temp300[temp300 < -bigval] = -bigval
} else stop("can only handle the 'loge' link")
shape = eta2theta(temp300, .lshape, earg=.eshape )
devi = -2 * (log(y/mu) - y/mu + 1)
- if(residuals) {
+ if (residuals) {
warning("not 100% sure about these deviance residuals!")
sign(y - mu) * sqrt(abs(devi) * w)
} else
@@ -2585,44 +2585,52 @@ rsnorm = function(n, location=0, scale=1, shape=0) {
}
- geometric =function(link="logit", earg=list(), expected=TRUE)
+
+ geometric =function(link="logit", earg=list(), expected=TRUE,
+ method.init= 1)
{
- if(!is.logical(expected) || length(expected) != 1)
+ if (!is.logical(expected) || length(expected) != 1)
stop("bad input for argument 'expected'")
- if(mode(link) != "character" && mode(link) != "name")
+ if (mode(link) != "character" && mode(link) != "name")
link = as.character(substitute(link))
- if(!is.list(earg)) earg = list()
+ if (!is.list(earg)) earg = list()
+ if (!is.Numeric(method.init, allow=1, integ=TRUE, posit=TRUE) ||
+ method.init > 3)
+ stop("'method.init' must be 1 or 2 or 3")
new("vglmff",
- blurb=c("Geometric distribution (P[Y=y] = prob*(1-prob)^y, y=0,1,2,...)\n",
+ blurb = c("Geometric distribution (P[Y=y] = prob*(1-prob)^y, y=0,1,2,...)\n",
"Link: ",
namesof("prob", link, earg=earg), "\n",
"Mean: mu = (1-prob)/prob\n",
"Variance: mu*(1+mu) = (1-prob)/prob^2"),
initialize=eval(substitute(expression({
- if(ncol(cbind(y)) != 1)
+ if (ncol(cbind(y)) != 1)
stop("response must be a vector or a 1-column matrix")
- if(any(y < 0)) stop("all responses must be >= 0")
- if(any(y!=round(y ))) stop("response should be integer-valued")
+ if (any(y < 0)) stop("all responses must be >= 0")
+ if (any(y!=round(y ))) stop("response should be integer-valued")
predictors.names = namesof("prob", .link, earg=.earg, tag=FALSE)
- if(!length(etastart)) {
- prob.init = 1 / (1 + y + 1/16)
+ if (!length(etastart)) {
+ prob.init = if ( .method.init == 3) 1 / (1 + y + 1/16) else
+ if ( .method.init == 1) 1 / (1 + median(rep(y,w)) + 1/16) else
+ 1 / (1 + weighted.mean(y,w) + 1/16)
etastart = theta2eta(prob.init, .link, earg= .earg)
}
- }), list( .link=link, .earg=earg ))),
+ }), list( .link=link, .earg=earg, .method.init=method.init ))),
inverse=eval(substitute(function(eta, extra=NULL) {
prob = eta2theta(eta, .link, earg= .earg)
(1-prob)/prob
}, list( .link=link, .earg=earg ))),
- last=eval(substitute(expression({
+ last = eval(substitute(expression({
misc$link = c(prob= .link)
misc$earg = list(prob= .earg )
misc$expected = .expected
- }), list( .link=link, .earg=earg, .expected=expected ))),
+ misc$method.init = .method.init
+ }), list( .link=link, .earg=earg, .expected=expected, .method.init=method.init ))),
loglikelihood=eval(substitute(
function(mu, y, w, residuals= FALSE,eta, extra=NULL) {
prob = eta2theta(eta, .link, earg= .earg)
- if(residuals) stop("loglikelihood residuals not implemented yet") else {
+ if (residuals) stop("loglikelihood residuals not implemented yet") else {
sum(w * dgeom(x=y, prob=prob, log=TRUE))
}
}, list( .link=link, .earg=earg ))),
@@ -2634,29 +2642,29 @@ rsnorm = function(n, location=0, scale=1, shape=0) {
w * cbind(dl.dprob * dprobdeta)
}), list( .link=link, .earg=earg, .expected=expected ))),
weight=eval(substitute(expression({
- ed2l.dprob2 = if( .expected ) 1 / (prob^2 * (1-prob)) else
+ ed2l.dprob2 = if ( .expected ) 1 / (prob^2 * (1-prob)) else
y / (1-prob)^2 + 1 / prob^2
wz = ed2l.dprob2 * dprobdeta^2
- if( !( .expected )) wz = wz - dl.dprob * d2theta.deta2(prob, .link, earg= .earg)
+ if ( !( .expected )) wz = wz - dl.dprob * d2theta.deta2(prob, .link, earg= .earg)
w * wz
}), list( .link=link, .earg=earg, .expected=expected ))))
}
dbetageom = function(x, shape1, shape2, log=FALSE) {
- if(!is.logical(log.arg <- log))
+ if (!is.logical(log.arg <- log))
stop("bad input for argument 'log'")
rm(log)
- if(!is.Numeric(x)) stop("bad input for argument 'x'")
- if(!is.Numeric(shape1, pos=TRUE)) stop("bad input for argument 'shape1'")
- if(!is.Numeric(shape2, pos=TRUE)) stop("bad input for argument 'shape2'")
+ if (!is.Numeric(x)) stop("bad input for argument 'x'")
+ if (!is.Numeric(shape1, pos=TRUE)) stop("bad input for argument 'shape1'")
+ if (!is.Numeric(shape2, pos=TRUE)) stop("bad input for argument 'shape2'")
N = max(length(x), length(shape1), length(shape2))
x = rep(x, len=N); shape1 = rep(shape1, len=N); shape2 = rep(shape2, len=N)
loglik = lbeta(1+shape1, shape2+abs(x)) - lbeta(shape1, shape2)
xok = (x == round(x) & x >= 0)
loglik[!xok] = log(0)
- if(log.arg) {
+ if (log.arg) {
loglik
} else {
exp(loglik)
@@ -2665,35 +2673,35 @@ dbetageom = function(x, shape1, shape2, log=FALSE) {
pbetageom = function(q, shape1, shape2, log.p=FALSE) {
- if(!is.Numeric(q)) stop("bad input for argument 'q'")
- if(!is.Numeric(shape1, pos=TRUE)) stop("bad input for argument 'shape1'")
- if(!is.Numeric(shape2, pos=TRUE)) stop("bad input for argument 'shape2'")
+ if (!is.Numeric(q)) stop("bad input for argument 'q'")
+ if (!is.Numeric(shape1, pos=TRUE)) stop("bad input for argument 'shape1'")
+ if (!is.Numeric(shape2, pos=TRUE)) stop("bad input for argument 'shape2'")
N = max(length(q), length(shape1), length(shape2))
q = rep(q, len=N); shape1 = rep(shape1, len=N); shape2 = rep(shape2, len=N)
ans = q * 0 # Retains names(q)
- if(max(abs(shape1-shape1[1])) < 1.0e-08 &&
+ if (max(abs(shape1-shape1[1])) < 1.0e-08 &&
max(abs(shape2-shape2[1])) < 1.0e-08) {
qstar = floor(q)
- temp = if(max(qstar) >= 0) dbetageom(x=0:max(qstar),
+ temp = if (max(qstar) >= 0) dbetageom(x=0:max(qstar),
shape1=shape1[1], shape2=shape2[1]) else 0*qstar
unq = unique(qstar)
for(i in unq) {
index = qstar == i
- ans[index] = if(i >= 0) sum(temp[1:(1+i)]) else 0
+ ans[index] = if (i >= 0) sum(temp[1:(1+i)]) else 0
}
} else
for(ii in 1:N) {
qstar = floor(q[ii])
- ans[ii] = if(qstar >= 0) sum(dbetageom(x=0:qstar,
+ ans[ii] = if (qstar >= 0) sum(dbetageom(x=0:qstar,
shape1=shape1[ii], shape2=shape2[ii])) else 0
}
- if(log.p) log(ans) else ans
+ if (log.p) log(ans) else ans
}
rbetageom = function(n, shape1, shape2) {
- if(!is.Numeric(n, integ=TRUE,allow=1)) stop("bad input for argument 'n'")
- if(!is.Numeric(shape1, pos=TRUE)) stop("bad input for argument 'shape1'")
- if(!is.Numeric(shape2, pos=TRUE)) stop("bad input for argument 'shape2'")
+ if (!is.Numeric(n, integ=TRUE,allow=1)) stop("bad input for argument 'n'")
+ if (!is.Numeric(shape1, pos=TRUE)) stop("bad input for argument 'shape1'")
+ if (!is.Numeric(shape2, pos=TRUE)) stop("bad input for argument 'shape2'")
rgeom(n=n, prob = rbeta(n=n, shape1=shape1, shape2=shape2))
}
@@ -2703,22 +2711,22 @@ rbetageom = function(n, shape1, shape2) {
tobit = function(Lower = 0, Upper = Inf, lmu="identity",
lsd="loge", emu=list(), esd=list(), imethod=1, zero=2)
{
- if(mode(lmu) != "character" && mode(lmu) != "name")
+ if (mode(lmu) != "character" && mode(lmu) != "name")
lmu = as.character(substitute(lmu))
- if(mode(lsd) != "character" && mode(lsd) != "name")
+ if (mode(lsd) != "character" && mode(lsd) != "name")
lsd = as.character(substitute(lsd))
- if(!is.Numeric(imethod, allow=1, integer=TRUE, positi=TRUE) || imethod > 2)
+ if (!is.Numeric(imethod, allow=1, integer=TRUE, positi=TRUE) || imethod > 2)
stop("imethod must be 1 or 2")
- if(length(Lower) != 1 || length(Upper) != 1 ||
+ if (length(Lower) != 1 || length(Upper) != 1 ||
!is.numeric(Lower) || !is.numeric(Upper) || Lower >= Upper)
stop("Lower and Upper must have length 1 and be numeric with Lower < Upper")
- if(length(zero) && !is.Numeric(zero, integer=TRUE, posit=TRUE))
+ if (length(zero) && !is.Numeric(zero, integer=TRUE, posit=TRUE))
stop("bad input for argument 'zero'")
- if(!is.list(emu)) emu = list()
- if(!is.list(esd)) esd = list()
+ if (!is.list(emu)) emu = list()
+ if (!is.list(esd)) esd = list()
new("vglmff",
- blurb=c("Tobit model\n\n",
+ blurb = c("Tobit model\n\n",
"Links: ", namesof("mu", lmu, earg=emu, tag= TRUE), "; ",
namesof("sd", lsd, earg=esd, tag= TRUE), "\n",
"Conditional variance: sd^2"),
@@ -2727,36 +2735,36 @@ rbetageom = function(n, shape1, shape2) {
}), list( .zero=zero ))),
initialize=eval(substitute(expression({
y = cbind(y)
- if(ncol(y)!=1)stop("the response must be a vector or a 1-column matrix")
+ if (ncol(y)!=1)stop("the response must be a vector or a 1-column matrix")
extra$censoredL = (y <= .Lower)
extra$censoredU = (y >= .Upper)
- if(min(y) < .Lower) {
+ if (min(y) < .Lower) {
warning("replacing response values less than the value ",
.Lower, " by ", .Lower)
y[y < .Lower] = .Lower
}
- if(max(y) > .Upper) {
+ if (max(y) > .Upper) {
warning("replacing response values greater than the value ",
.Upper, " by ", .Upper)
y[y > .Upper] = .Upper
}
predictors.names = c(namesof("mu", .lmu, earg=.emu, tag=FALSE),
namesof("sd", .lsd, earg=.esd, tag=FALSE))
- if(!length(etastart)) {
+ if (!length(etastart)) {
anyc = extra$censoredL | extra$censoredU
- i11 = if( .imethod == 1) anyc else FALSE # can be all data
+ i11 = if ( .imethod == 1) anyc else FALSE # can be all data
junk = lm.wfit(x=cbind(x[!i11,]), y=y[!i11], w=w[!i11])
sd.y.est = sqrt( sum(w[!i11] * junk$resid^2) / junk$df.residual )
etastart = cbind(mu=y, rep(theta2eta(sd.y.est, .lsd, earg= .esd),
length=n))
- if(any(anyc)) etastart[anyc,1] = x[anyc,,drop=FALSE] %*% junk$coeff
+ if (any(anyc)) etastart[anyc,1] = x[anyc,,drop=FALSE] %*% junk$coeff
}
}), list( .Lower=Lower, .Upper=Upper, .lmu=lmu, .lsd=lsd,
.emu=emu, .esd=esd, .imethod=imethod ))),
inverse=eval(substitute( function(eta, extra=NULL) {
eta2theta(eta[,1], .lmu, earg= .emu)
}, list( .lmu=lmu, .emu=emu ))),
- last=eval(substitute(expression({
+ last = eval(substitute(expression({
misc$link = c("mu"= .lmu, "sd"= .lsd)
misc$earg = list("mu"= .emu, "sd"= .esd)
misc$expected = TRUE
@@ -2775,7 +2783,7 @@ rbetageom = function(n, shape1, shape2) {
ell1 = -log(sd[cen0]) - 0.5 * ((y[cen0] - mum[cen0])/sd[cen0])^2
ell2 = log1p(-pnorm((mum[cenL] - .Lower)/sd[cenL]))
ell3 = log1p(-pnorm(( .Upper - mum[cenU])/sd[cenU]))
- if(residuals) stop("loglikelihood residuals not implemented yet") else
+ if (residuals) stop("loglikelihood residuals not implemented yet") else
sum(w[cen0] * ell1) + sum(w[cenL] * ell2) + sum(w[cenU] * ell3)
}, list( .lmu=lmu, .lsd=lsd,
.emu=emu, .esd=esd,
@@ -2791,7 +2799,7 @@ rbetageom = function(n, shape1, shape2) {
dl.dsd = (((y-mum)/sd)^2 - 1) / sd
dmu.deta = dtheta.deta(mum, .lmu, earg= .emu)
dsd.deta = dtheta.deta(sd, .lsd, earg= .esd)
- if(any(cenL)) {
+ if (any(cenL)) {
mumL = mum - .Lower
temp21L = mumL[cenL] / sd[cenL]
PhiL = pnorm(temp21L)
@@ -2801,7 +2809,7 @@ rbetageom = function(n, shape1, shape2) {
dl.dsd[cenL] = mumL[cenL] * fred21 / sd[cenL]^2
rm(fred21)
}
- if(any(cenU)) {
+ if (any(cenU)) {
mumU = .Upper - mum
temp21U = mumU[cenU] / sd[cenU]
PhiU = pnorm(temp21U)
@@ -2865,19 +2873,18 @@ rbetageom = function(n, shape1, shape2) {
normal1 = function(lmean="identity", lsd="loge",
emean=list(), esd=list(), zero=NULL)
{
- print("20090416; in normal1()")
- if(mode(lmean) != "character" && mode(lmean) != "name")
+ if (mode(lmean) != "character" && mode(lmean) != "name")
lmean = as.character(substitute(lmean))
- if(mode(lsd) != "character" && mode(lsd) != "name")
+ if (mode(lsd) != "character" && mode(lsd) != "name")
lsd = as.character(substitute(lsd))
- if(length(zero) && !is.Numeric(zero, integer=TRUE, posit=TRUE))
+ if (length(zero) && !is.Numeric(zero, integer=TRUE, posit=TRUE))
stop("bad input for argument 'zero'")
- if(!is.list(emean)) emean = list()
- if(!is.list(esd)) esd = list()
+ if (!is.list(emean)) emean = list()
+ if (!is.list(esd)) esd = list()
new("vglmff",
- blurb=c("Univariate normal distribution\n\n",
+ blurb = c("Univariate normal distribution\n\n",
"Links: ",
namesof("mean", lmean, earg=emean, tag= TRUE), "; ",
namesof("sd", lsd, earg=esd, tag= TRUE),
@@ -2889,12 +2896,12 @@ rbetageom = function(n, shape1, shape2) {
initialize=eval(substitute(expression({
predictors.names = c(namesof("mean", .lmean, earg=.emean, tag=FALSE),
namesof("sd", .lsd, earg=.esd, tag=FALSE))
- if(ncol(y <- cbind(y)) != 1)
+ if (ncol(y <- cbind(y)) != 1)
stop("response must be a vector or a one-column matrix")
- if(!length(etastart)) {
+ if (!length(etastart)) {
junk = lm.wfit(x=x, y=y, w=w)
sd.y.est = sqrt( sum(w * junk$resid^2) / junk$df.residual )
- mean.init = if( .lmean == "loge") pmax(1/1024, y) else y
+ mean.init = if ( .lmean == "loge") pmax(1/1024, y) else y
etastart = cbind(theta2eta(mean.init, .lmean, earg= .emean),
theta2eta(sd.y.est, .lsd, earg= .esd))
}
@@ -2902,7 +2909,7 @@ rbetageom = function(n, shape1, shape2) {
inverse=eval(substitute(function(eta, extra=NULL) {
eta2theta(eta[,1], .lmean, earg= .emean)
}, list( .lmean=lmean, .emean=emean, .esd=esd ))),
- last=eval(substitute(expression({
+ last = eval(substitute(expression({
misc$link = c("mu"= .lmean, "sd"= .lsd)
misc$earg = list("mu"= .emean, "sd"= .esd)
misc$expected = TRUE
@@ -2910,7 +2917,7 @@ rbetageom = function(n, shape1, shape2) {
loglikelihood=eval(substitute(
function(mu,y,w,residuals= FALSE,eta, extra=NULL) {
sd = eta2theta(eta[,2], .lsd, earg= .esd)
- if(residuals) stop("loglikelihood residuals not implemented yet") else {
+ if (residuals) stop("loglikelihood residuals not implemented yet") else {
sum(w * dnorm(y, m=mu, sd=sd, log=TRUE))
}
}, list( .lsd=lsd, .emean=emean, .esd=esd ))),
@@ -2941,29 +2948,29 @@ rbetageom = function(n, shape1, shape2) {
lognormal = function(lmeanlog="identity", lsdlog="loge",
emeanlog=list(), esdlog=list(), zero=NULL)
{
- if(mode(lmeanlog) != "character" && mode(lmeanlog) != "name")
+ if (mode(lmeanlog) != "character" && mode(lmeanlog) != "name")
lmeanlog = as.character(substitute(lmeanlog))
- if(mode(lsdlog) != "character" && mode(lsdlog) != "name")
+ if (mode(lsdlog) != "character" && mode(lsdlog) != "name")
lsdlog = as.character(substitute(lsdlog))
- if(length(zero) && (!is.Numeric(zero, integer=TRUE, posit=TRUE) ||
+ if (length(zero) && (!is.Numeric(zero, integer=TRUE, posit=TRUE) ||
zero > 2)) stop("bad input for argument argument 'zero'")
- if(!is.list(emeanlog)) emeanlog = list()
- if(!is.list(esdlog)) esdlog = list()
+ if (!is.list(emeanlog)) emeanlog = list()
+ if (!is.list(esdlog)) esdlog = list()
new("vglmff",
- blurb=c("Two-parameter (univariate) lognormal distribution\n\n",
+ blurb = c("Two-parameter (univariate) lognormal distribution\n\n",
"Links: ", namesof("meanlog", lmeanlog, earg=emeanlog, tag= TRUE), ", ",
namesof("sdlog", lsdlog, earg=esdlog, tag= 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)
+ if (ncol(cbind(y)) != 1)
stop("response must be a vector or a one-column matrix")
- if(min(y) <= 0) stop("response must be positive")
+ if (min(y) <= 0) stop("response must be positive")
predictors.names = c(namesof("meanlog", .lmeanlog, earg=.emeanlog, tag=FALSE),
namesof("sdlog", .lsdlog, earg=.esdlog, tag=FALSE))
- if(!length(etastart)) {
+ if (!length(etastart)) {
junk = lm.wfit(x=x, y=log(y), w=w)
sdlog.y.est = sqrt( sum(w * junk$resid^2) / junk$df.residual )
etastart = cbind(
@@ -2978,7 +2985,7 @@ rbetageom = function(n, shape1, shape2) {
exp(mulog + 0.5 * sdlog^2)
}, list( .lmeanlog = lmeanlog, .lsdlog=lsdlog,
.emeanlog = emeanlog, .esdlog=esdlog ))),
- last=eval(substitute(expression({
+ last = eval(substitute(expression({
misc$link = c("meanlog"= .lmeanlog, "sdlog"= .lsdlog)
misc$earg = list("meanlog"= .emeanlog, "sdlog"= .esdlog)
misc$expected = TRUE
@@ -2988,7 +2995,7 @@ rbetageom = function(n, shape1, shape2) {
function(mu,y,w,residuals= FALSE,eta, extra=NULL) {
mulog = eta2theta(eta[,1], .lmeanlog, earg= .emeanlog)
sdlog = eta2theta(eta[,2], .lsdlog, earg= .esdlog)
- if(residuals) stop("loglikelihood residuals not implemented yet") else {
+ if (residuals) stop("loglikelihood residuals not implemented yet") else {
sum(w * dlnorm(y, meanlog=mulog, sdlog=sdlog, log=TRUE))
}
}, list( .lmeanlog = lmeanlog, .lsdlog=lsdlog,
@@ -3027,20 +3034,20 @@ rbetageom = function(n, shape1, shape2) {
powers.try = (-3):3,
delta=NULL, zero=NULL)
{
- if(length(delta) && !is.Numeric(delta, positive=TRUE))
+ if (length(delta) && !is.Numeric(delta, positive=TRUE))
stop("bad input for argument argument 'delta'")
- if(mode(lmeanlog) != "character" && mode(lmeanlog) != "name")
+ if (mode(lmeanlog) != "character" && mode(lmeanlog) != "name")
lmeanlog = as.character(substitute(lmeanlog))
- if(mode(lsdlog) != "character" && mode(lsdlog) != "name")
+ if (mode(lsdlog) != "character" && mode(lsdlog) != "name")
lsdlog = as.character(substitute(lsdlog))
- if(length(zero) && (!is.Numeric(zero, integer=TRUE, posit=TRUE) ||
+ if (length(zero) && (!is.Numeric(zero, integer=TRUE, posit=TRUE) ||
zero > 3))
stop("bad input for argument argument 'zero'")
- if(!is.list(emeanlog)) emeanlog = list()
- if(!is.list(esdlog)) esdlog = list()
+ if (!is.list(emeanlog)) emeanlog = list()
+ if (!is.list(esdlog)) esdlog = list()
new("vglmff",
- blurb=c("Three-parameter (univariate) lognormal distribution\n\n",
+ blurb = c("Three-parameter (univariate) lognormal distribution\n\n",
"Links: ",
namesof("meanlog", lmeanlog, earg=emeanlog, tag= TRUE),
"; ", namesof("sdlog", lsdlog, earg=esdlog, tag= TRUE),
@@ -3049,15 +3056,15 @@ rbetageom = function(n, shape1, shape2) {
constraints = cm.zero.vgam(constraints, x, .zero, M)
}), list( .zero=zero ))),
initialize=eval(substitute(expression({
- if(ncol(cbind(y)) != 1)
+ if (ncol(cbind(y)) != 1)
stop("response must be a vector or a one-column matrix")
predictors.names =
c(namesof("meanlog", .lmeanlog, earg=.emeanlog, tag=FALSE),
namesof("sdlog", .lsdlog, earg=.esdlog, tag=FALSE), "lambda")
- if(!length(etastart)) {
+ if (!length(etastart)) {
miny = min(y)
- if(length( .delta)) {
+ if (length( .delta)) {
lambda.init = rep(miny- .delta, length=n)
} else {
pvalue.vec = NULL
@@ -3086,7 +3093,7 @@ rbetageom = function(n, shape1, shape2) {
lambda + exp(mymu + 0.5 * sdlog^2)
}, list( .lmeanlog=lmeanlog, .lsdlog=lsdlog,
.emeanlog = emeanlog, .esdlog=esdlog ))),
- last=eval(substitute(expression({
+ last = eval(substitute(expression({
misc$link = c("meanlog"= .lmeanlog,"sdlog"= .lsdlog,"lambda"="identity")
misc$earg = list("meanlog"= .emeanlog, "sdlog"= .esdlog,
"lambda"=list())
@@ -3098,9 +3105,9 @@ rbetageom = function(n, shape1, shape2) {
mymu = eta2theta(eta[,1], .lmeanlog, earg= .emeanlog)
sdlog = eta2theta(eta[,2], .lsdlog, earg= .esdlog)
lambda = eta2theta(eta[,3], "identity", earg=list())
- if(any(y < lambda))
+ if (any(y < lambda))
warning("bad 'y'")
- if(residuals) stop("loglikelihood residuals not implemented yet") else {
+ if (residuals) stop("loglikelihood residuals not implemented yet") else {
sum(w*dlnorm(y-lambda, meanlog=mymu, sdlog=sdlog, log=TRUE))
}
}, list( .lmeanlog=lmeanlog, .lsdlog=lsdlog,
@@ -3110,7 +3117,7 @@ rbetageom = function(n, shape1, shape2) {
mymu = eta2theta(eta[,1], .lmeanlog, earg= .emeanlog)
sdlog = eta2theta(eta[,2], .lsdlog, earg= .esdlog)
lambda = eta2theta(eta[,3], "identity", earg=list())
- if(any(y < lambda))
+ if (any(y < lambda))
warning("bad 'y'")
dl.dmymu = (log(y-lambda)-mymu) / sdlog^2
dl.dsdlog = -1/sdlog + (log(y-lambda)-mymu)^2 / sdlog^3
@@ -3158,33 +3165,33 @@ negbinomial.control <- function(save.weight=TRUE, ...)
- if(length(ik) && !is.Numeric(ik, posit=TRUE))
+ if (length(ik) && !is.Numeric(ik, posit=TRUE))
stop("bad input for argument 'ik'")
- if(!is.Numeric(cutoff, allow=1) || cutoff<0.8 || cutoff>=1)
+ if (!is.Numeric(cutoff, allow=1) || cutoff<0.8 || cutoff>=1)
stop("range error in the argument 'cutoff'")
- if(!is.Numeric(Maxiter, integ=TRUE, allow=1) || Maxiter < 100)
+ if (!is.Numeric(Maxiter, integ=TRUE, allow=1) || Maxiter < 100)
stop("bad input for argument 'Maxiter'")
- if(!is.Numeric(method.init, allow=1, integ=TRUE, posit=TRUE) ||
+ if (!is.Numeric(method.init, allow=1, integ=TRUE, posit=TRUE) ||
method.init > 3) stop("argument 'method.init' must be 1 or 2 or 3")
- if(!is.Numeric(shrinkage.init, allow=1) || shrinkage.init < 0 ||
+ if (!is.Numeric(shrinkage.init, allow=1) || shrinkage.init < 0 ||
shrinkage.init > 1) stop("bad input for argument 'shrinkage.init'")
- if(!is.null(nsimEIM)) {
- if(!is.Numeric(nsimEIM, allow=1, integ=TRUE))
+ if (!is.null(nsimEIM)) {
+ if (!is.Numeric(nsimEIM, allow=1, integ=TRUE))
stop("bad input for argument 'nsimEIM'")
- if(nsimEIM <= 10)
+ if (nsimEIM <= 10)
warning("'nsimEIM' should be an integer greater than 10, say")
}
- if(mode(lmu) != "character" && mode(lmu) != "name")
+ if (mode(lmu) != "character" && mode(lmu) != "name")
lmu = as.character(substitute(lmu))
- if(mode(lk) != "character" && mode(lk) != "name")
+ if (mode(lk) != "character" && mode(lk) != "name")
lk = as.character(substitute(lk))
- if(!is.list(emu)) emu = list()
- if(!is.list(ek)) ek = list()
+ if (!is.list(emu)) emu = list()
+ if (!is.list(ek)) ek = list()
ans =
new("vglmff",
- blurb=c("Negative-binomial distribution\n\n",
+ blurb = c("Negative-binomial distribution\n\n",
"Links: ",
namesof("mu", lmu, earg=emu), ", ",
namesof("k", lk, earg=ek), "\n",
@@ -3192,20 +3199,20 @@ negbinomial.control <- function(save.weight=TRUE, ...)
"Variance: mu * (1 + mu/k)"),
constraints=eval(substitute(expression({
temp752 = .zero
- if(length(temp752) && all(temp752 == -2))
+ if (length(temp752) && all(temp752 == -2))
temp752 = 2*(1:ncol(y))
constraints = cm.zero.vgam(constraints, x, temp752, M)
}), list( .zero=zero ))),
initialize=eval(substitute(expression({
assign("CQO.FastAlgorithm",
( .lmu == "loge") && ( .lk == "loge"), envir = VGAMenv)
- if(any(function.name == c("cqo","cao")) &&
+ if (any(function.name == c("cqo","cao")) &&
is.Numeric( .zero, allow=1) && .zero != -2)
stop("argument zero=-2 is required")
- if(any(y<0))
+ if (any(y<0))
stop("negative values not allowed for the negbinomial family")
- if(any(round(y) != y))
+ if (any(round(y) != y))
stop("integer-values only allowed for the negbinomial family")
y = as.matrix(y)
M = 2 * ncol(y)
@@ -3216,16 +3223,16 @@ negbinomial.control <- function(save.weight=TRUE, ...)
tag=FALSE))
predictors.names = predictors.names[interleave.VGAM(M, M=2)]
- if(is.null( .nsimEIM)) {
+ if (is.null( .nsimEIM)) {
save.weight <- control$save.weight <- FALSE
}
- if(!length(etastart)) {
+ if (!length(etastart)) {
mu.init = y
for(iii in 1:ncol(y)) {
- use.this = if( .method.init == 1) {
+ use.this = if ( .method.init == 1) {
weighted.mean(y[,iii], w) + 1/16
- } else if( .method.init == 3) {
+ } else if ( .method.init == 3) {
c(quantile(y[,iii], probs = 0.75) + 1/16)
} else {
median(y[,iii]) + 1/16
@@ -3236,7 +3243,7 @@ negbinomial.control <- function(save.weight=TRUE, ...)
(1- .sinit)*allowfun(y[,iii] - use.this, maxtol=medabsres)
}
- if( is.Numeric( .k.init )) {
+ if ( is.Numeric( .k.init )) {
kay.init = matrix( .k.init, nr=n, nc=NOS, byrow=TRUE)
} else {
negbinomial.Loglikfun = function(kmat, y, x, w, extraargs) {
@@ -3264,12 +3271,12 @@ negbinomial.control <- function(save.weight=TRUE, ...)
NOS = ncol(eta) / 2
eta2theta(eta[,2*(1:NOS)-1,drop=FALSE], .lmu, earg= .emu)
}, list( .lmu=lmu, .emu=emu, .ek=ek ))),
- last=eval(substitute(expression({
- if(exists("CQO.FastAlgorithm", envir = VGAMenv))
+ last = eval(substitute(expression({
+ if (exists("CQO.FastAlgorithm", envir = VGAMenv))
rm("CQO.FastAlgorithm", envir = VGAMenv)
temp0303 = c(rep( .lmu, length=NOS), rep( .lk, length=NOS))
names(temp0303) = c(if(NOS==1) "mu" else paste("mu", 1:NOS, sep=""),
- if(NOS==1) "k" else paste("k", 1:NOS, sep=""))
+ if (NOS==1) "k" else paste("k", 1:NOS, sep=""))
temp0303 = temp0303[interleave.VGAM(M, M=2)]
misc$link = temp0303 # Already named
misc$earg = vector("list", M)
@@ -3294,14 +3301,14 @@ negbinomial.control <- function(save.weight=TRUE, ...)
function(mu,y,w,residuals= FALSE,eta, extra=NULL) {
NOS = ncol(eta) / 2
temp300 = eta[,2*(1:NOS),drop=FALSE]
- if( .lk == "loge") {
+ if ( .lk == "loge") {
bigval = 28
temp300 = ifelse(temp300 > bigval, bigval, temp300)
temp300 = ifelse(temp300 < -bigval, -bigval, temp300)
}
kmat = eta2theta(temp300, .lk, earg= .ek)
- if(residuals) stop("loglikelihood residuals not implemented yet") else
+ if (residuals) stop("loglikelihood residuals not implemented yet") else
sum(w * dnbinom(x=y, mu=mu, size=kmat, log=TRUE))
}, list( .lk=lk, .emu=emu, .ek=ek ))),
vfamily=c("negbinomial"),
@@ -3324,13 +3331,13 @@ negbinomial.control <- function(save.weight=TRUE, ...)
}), list( .lmu=lmu, .lk=lk, .emu=emu, .ek=ek ))),
weight=eval(substitute(expression({
wz = matrix(as.numeric(NA), n, M) # wz is 'diagonal'
- if(is.null( .nsimEIM)) {
+ if (is.null( .nsimEIM)) {
fred2 = dotFortran(name="enbin9", ans=double(n*NOS),
as.double(kmat), as.double(mu), as.double( .cutoff ),
as.integer(n), ok=as.integer(1), as.integer(NOS),
sumpdf=double(1), as.double(.Machine$double.eps),
as.integer( .Maxiter ))
- if(fred2$ok != 1)
+ if (fred2$ok != 1)
stop("error in Fortran subroutine exnbin9")
dim(fred2$ans) = c(n, NOS)
ed2l.dk2 = -fred2$ans - 1/kmat + 1/(kmat+mu)
@@ -3340,13 +3347,13 @@ negbinomial.control <- function(save.weight=TRUE, ...)
ind1 = iam(NA, NA, M=M, both=TRUE, diag=TRUE)
for(ii in 1:( .nsimEIM )) {
ysim = rnbinom(n=n*NOS, mu=c(mu), size=c(kmat))
- if(NOS > 1) dim(ysim) = c(n, NOS)
+ if (NOS > 1) dim(ysim) = c(n, NOS)
dl.dk = digamma(ysim+kmat) - digamma(kmat) -
(ysim+kmat)/(mu+kmat) + 1 + log(kmat/(kmat+mu))
run.varcov = run.varcov + dl.dk^2
}
run.varcov = cbind(run.varcov / .nsimEIM)
- wz[,2*(1:NOS)] = if(intercept.only)
+ wz[,2*(1:NOS)] = if (intercept.only)
matrix(colMeans(run.varcov),
n, ncol(run.varcov), byrow=TRUE) else run.varcov
@@ -3357,18 +3364,18 @@ negbinomial.control <- function(save.weight=TRUE, ...)
w * wz
}), list( .cutoff=cutoff, .Maxiter=Maxiter, .nsimEIM=nsimEIM ))))
- if(deviance.arg) ans at deviance=eval(substitute(
+ if (deviance.arg) ans at deviance=eval(substitute(
function(mu,y,w,residuals= FALSE,eta,extra=NULL) {
NOS = ncol(eta) / 2
temp300 = eta[,2*(1:NOS),drop=FALSE]
- if( .lk == "loge") {
+ if ( .lk == "loge") {
bigval = 28
temp300[temp300 > bigval] = bigval
temp300[temp300 < -bigval] = -bigval
} else stop("can only handle the 'loge' link")
k = eta2theta(temp300, .lk, earg= .ek)
devi = 2 * (y*log(ifelse(y<1, 1, y)/mu) + (y+k)*log((mu+k)/(k+y )))
- if(residuals)
+ if (residuals)
sign(y - mu) * sqrt(abs(devi) * w) else
sum(w * devi)
}, list( .lk=lk, .emu=emu, .ek=ek )))
@@ -3386,20 +3393,20 @@ negbinomial.control <- function(save.weight=TRUE, ...)
- if(!is.Numeric(cutoff, allow=1) || cutoff<0.8 || cutoff>=1)
+ if (!is.Numeric(cutoff, allow=1) || cutoff<0.8 || cutoff>=1)
stop("range error in the argument cutoff")
- if(length(zero) && !is.Numeric(zero, integer=TRUE, posit=TRUE))
+ if (length(zero) && !is.Numeric(zero, integer=TRUE, posit=TRUE))
stop("bad input for argument 'zero'")
- if(mode(link.alpha) != "character" && mode(link.alpha) != "name")
+ if (mode(link.alpha) != "character" && mode(link.alpha) != "name")
link.alpha = as.character(substitute(link.alpha))
- if(mode(link.k) != "character" && mode(link.k) != "name")
+ if (mode(link.k) != "character" && mode(link.k) != "name")
link.k = as.character(substitute(link.k))
- if(!is.list(ealpha)) ealpha = list()
- if(!is.list(ek)) ek = list()
+ if (!is.list(ealpha)) ealpha = list()
+ if (!is.list(ek)) ek = list()
new("vglmff",
- blurb=c("Negative-binomial distribution\n\n",
+ blurb = c("Negative-binomial distribution\n\n",
"Links: ",
namesof("alpha", link.alpha, earg=ealpha), ", ",
namesof("k", link.k, earg=ek),
@@ -3411,13 +3418,13 @@ negbinomial.control <- function(save.weight=TRUE, ...)
constraints = cm.zero.vgam(constraints, x, .zero, M)
}), list( .zero=zero ))),
initialize=eval(substitute(expression({
- if(ncol(cbind(y)) != 1)
+ if (ncol(cbind(y)) != 1)
stop("response must be a vector or a one-column matrix")
predictors.names =
c(namesof("alpha", .link.alpha, earg=.ealpha, tag=FALSE),
namesof("k", .link.k, earg=.ek, tag=FALSE))
- if(!length(etastart)) {
+ if (!length(etastart)) {
etastart = cbind(
theta2eta((y + 1/8) / .k.init, .link.alpha, earg= .ealpha),
theta2eta( .k.init, .link.k, earg= .ek))
@@ -3430,7 +3437,7 @@ negbinomial.control <- function(save.weight=TRUE, ...)
alpha * k
}, list( .link.alpha=link.alpha, .link.k=link.k,
.ealpha=ealpha, .ek=ek ))),
- last=eval(substitute(expression({
+ last = eval(substitute(expression({
misc$link = c(alpha= .link.alpha, k= .link.k)
misc$earg = list(alpha= .ealpha, k= .ek )
}), list( .link.alpha=link.alpha, .link.k=link.k,
@@ -3439,7 +3446,7 @@ negbinomial.control <- function(save.weight=TRUE, ...)
function(mu,y,w,residuals= FALSE,eta, extra=NULL) {
alpha = eta2theta(eta[,1], .link.alpha, earg= .ealpha)
kvec = eta2theta(eta[,2], .link.k, earg= .ek)
- if(residuals) stop("loglikelihood residuals not implemented yet") else {
+ if (residuals) stop("loglikelihood residuals not implemented yet") else {
sum(w * dnbinom(x=y, mu=kvec*alpha, size=kvec, log=TRUE))
}
}, list( .link.alpha=link.alpha, .link.k=link.k,
@@ -3467,7 +3474,7 @@ negbinomial.control <- function(save.weight=TRUE, ...)
as.double( .cutoff ),
as.integer(n), ok=as.integer(1), as.integer(1),
sumpdf=double(1), macheps=as.double(.Machine$double.eps))
- if(fred$ok != 1)
+ if (fred$ok != 1)
stop("error in Fortran subroutine enbin8")
ed2l.dk2 = -fred$ans
@@ -3482,7 +3489,7 @@ negbinomial.control <- function(save.weight=TRUE, ...)
-if(FALSE)
+ if (FALSE)
nbmud = function(lmu = c("loge","identity","reciprocal"),
k.init = 1,
zero = -2,
@@ -3502,7 +3509,7 @@ nbmud = function(lmu = c("loge","identity","reciprocal"),
-if(FALSE)
+ if (FALSE)
neg.binomial = function(link.p="logit", link.k="loge",
ep=list(), ek=list(),
zero=2,
@@ -3512,20 +3519,20 @@ if(FALSE)
- if(!is.Numeric(cutoff, allow=1) || cutoff<0.8 || cutoff>=1)
+ if (!is.Numeric(cutoff, allow=1) || cutoff<0.8 || cutoff>=1)
stop("range error in the argument cutoff")
- if(mode(link.p) != "character" && mode(link.p) != "name")
+ if (mode(link.p) != "character" && mode(link.p) != "name")
link.p = as.character(substitute(link.p))
- if(link.p=="canonical")
+ if (link.p=="canonical")
link.p = "logc"
- if(mode(link.k) != "character" && mode(link.k) != "name")
+ if (mode(link.k) != "character" && mode(link.k) != "name")
link.k = as.character(substitute(link.k))
- if(!is.list(ep)) ep = list()
- if(!is.list(ek)) ek = list()
+ if (!is.list(ep)) ep = list()
+ if (!is.list(ek)) ek = list()
new("vglmff",
- blurb=c("Negative-binomial distribution\n\n",
+ blurb = c("Negative-binomial distribution\n\n",
"Links: ",
namesof("p", link.p, earg=ep), ", ",
namesof("k", link.k, earg=ek), "; mu=k*(1-p)/p",
@@ -3535,12 +3542,12 @@ if(FALSE)
constraints = cm.zero.vgam(constraints, x, .zero, M)
}), list( .zero=zero ))),
initialize=eval(substitute(expression({
- if(ncol(cbind(y)) != 1)
+ if (ncol(cbind(y)) != 1)
stop("response must be a vector or a one-column matrix")
y = as.numeric(y)
- if(any(y < 0))
+ if (any(y < 0))
stop("response must be non-negative")
- if(max(abs(y - round(y )))>0.00001)
+ if (max(abs(y - round(y )))>0.00001)
stop("response must be integer-valued")
predictors.names =
@@ -3553,7 +3560,7 @@ if(FALSE)
var.y.est = summary(junk)$sigma^2
mu.adj = fitted(junk)
- if(FALSE) {
+ if (FALSE) {
mu = rep(weighted.mean(y, w=w), len=length(y))
mu = rep(median(rep(y+0.167, times=w)), len=length(y))
@@ -3566,12 +3573,12 @@ if(FALSE)
k[k <= 0] = quantile(k[k>0], prob=0.02)
}
- if(length( .ik )) {
+ if (length( .ik )) {
mu = median(rep(y, times=w))
k = rep( .ik , len=length(y))
}
- if(!length(etastart)) {
+ if (!length(etastart)) {
prob = k / (k + mu)
etastart = cbind(theta2eta(prob, .link.p, earg= .ep),
theta2eta(k, .link.k, earg= .ek))
@@ -3584,7 +3591,7 @@ if(FALSE)
k * (1 - prob) / prob
}, list( .link.p=link.p, .link.k=link.k,
.ep=ep, .ek=ek ))),
- last=eval(substitute(expression({
+ last = eval(substitute(expression({
misc$link = c(p= .link.p, k= .link.k )
misc$earg = list(p= .ep, k= .ek )
}), list( .link.p=link.p, .link.k=link.k,
@@ -3593,7 +3600,7 @@ if(FALSE)
function(mu,y,w,residuals= FALSE,eta, extra=NULL) {
prob = eta2theta(eta[,1], .link.p, earg= .ep)
k = eta2theta(eta[,2], .link.k, earg= .ek)
- if(residuals) stop("loglikelihood residuals not implemented yet") else
+ if (residuals) stop("loglikelihood residuals not implemented yet") else
sum(w * (y * log1p(-prob) + k * log(prob) + lgamma(y+k) -
lgamma(k) - lgamma(y+1 )))
}, list( .link.p=link.p, .link.k=link.k,
@@ -3622,7 +3629,7 @@ if(FALSE)
as.double( .cutoff ),
as.integer(n), ok=as.integer(1), as.integer(1),
sumpdf=double(1))
- if(fred$ok != 1)
+ if (fred$ok != 1)
stop("error in Fortran subroutine exnbin")
ed2l.dk2 = fred$ans
@@ -3638,25 +3645,25 @@ if(FALSE)
-if(FALSE)
+ if (FALSE)
neg.binomial.k = function(k, link="logit", earg=list(), expected=TRUE, ...)
{
- if(!is.Numeric(k, allow=1, posit=TRUE))
+ if (!is.Numeric(k, allow=1, posit=TRUE))
stop("bad input for argument argument 'k'")
- if(mode(link) != "character" && mode(link) != "name")
+ if (mode(link) != "character" && mode(link) != "name")
link = as.character(substitute(link))
- if(!is.list(earg)) earg = list()
+ if (!is.list(earg)) earg = list()
new("vglmff",
- blurb=c("Negative-binomial distribution with k known and p unknown\n",
+ blurb = c("Negative-binomial distribution with k known and p unknown\n",
"(k=", k, ") ",
- if(k==1) "Geometric\n\n" else "\n\n",
+ if (k==1) "Geometric\n\n" else "\n\n",
"Links: ",
namesof("p", link, earg=earg), "; p=",k,"/(",k,"+mu)",
"\n",
"Variance: ",
- if(k==1) "Geometric: mu(1+mu)" else
+ if (k==1) "Geometric: mu(1+mu)" else
paste("mu(1 + mu/",k,")", sep="")),
deviance=eval(substitute(
function(mu,y,w,residuals= FALSE,eta,extra=NULL) {
@@ -3666,7 +3673,7 @@ if(FALSE)
devy[nz] = devy[nz] + y[nz] * log(y[nz] / ( .k + y[nz]))
devmu = y * log1p(-prob) + .k * log(prob)
devi = 2 * (devy - devmu)
- if(residuals)
+ if (residuals)
sign(y - mu) * sqrt(abs(devi) * w) else
sum(w * devi)
}, list( .link=link, .earg=earg, .k=k ))),
@@ -3674,7 +3681,7 @@ if(FALSE)
predictors.names = namesof("p", .link, earg=.ep, tag=FALSE)
mu = y + 0.167 * (y == 0)
- if(!length(etastart)) {
+ if (!length(etastart)) {
prob = .k / ( .k + mu)
etastart = theta2eta(prob, .link, earg= .earg)
}
@@ -3683,14 +3690,14 @@ if(FALSE)
prob = eta2theta(eta, .link, earg= .earg)
.k * (1 - prob) / prob
}, list( .link=link, .earg=earg, .k=k ))),
- last=eval(substitute(expression({
+ last = eval(substitute(expression({
misc$link = c(p = .link)
misc$k = .k
}), list( .link=link, .earg=earg, .k=k ))),
loglikelihood=eval(substitute(
function(mu,y,w,residuals= FALSE,eta, extra=NULL) {
prob = eta2theta(eta, .link, earg= .earg)
- if(residuals) stop("loglikelihood residuals not implemented yet") else
+ if (residuals) stop("loglikelihood residuals not implemented yet") else
sum(w * (y * log1p(-prob) + .k * log(prob) + lgamma(y+ .k) -
lgamma( .k ) - lgamma(y+1 )))
}, list( .link=link, .earg=earg, .k=k ))),
@@ -3702,7 +3709,7 @@ if(FALSE)
}), list( .link=link, .earg=earg, .k=k ))),
weight=eval(substitute(expression({
wz = dp.deta^2 * (y/(1 - prob)^2 + .k/prob^2)
- if(! .expected) {
+ if (! .expected) {
d2pdeta2 = d2theta.deta2(prob, .link, earg= .earg)
wz = wz - d2pdeta2 * ( .k/prob - y/(1-prob))
}
@@ -3717,7 +3724,7 @@ if(FALSE)
simple.poisson = function()
{
new("vglmff",
- blurb=c("Poisson distribution\n\n",
+ blurb = c("Poisson distribution\n\n",
"Link: log(lambda)",
"\n",
"Variance: lambda"),
@@ -3725,20 +3732,20 @@ if(FALSE)
nz = y > 0
devi = - (y - mu)
devi[nz] = devi[nz] + y[nz] * log(y[nz]/mu[nz])
- if(residuals) sign(y - mu) * sqrt(2 * abs(devi) * w) else
+ if (residuals) sign(y - mu) * sqrt(2 * abs(devi) * w) else
2 * sum(w * devi)
},
initialize=expression({
- if(ncol(cbind(y)) != 1)
+ if (ncol(cbind(y)) != 1)
stop("response must be a vector or a one-column matrix")
predictors.names = "log(lambda)"
mu = y + 0.167 * (y == 0)
- if(!length(etastart))
+ if (!length(etastart))
etastart = log(mu)
}),
inverse=function(eta, extra=NULL)
exp(eta),
- last=expression({
+ last = expression({
misc$link = c(lambda = "loge")
misc$earg = list(lambda = list())
}),
@@ -3760,31 +3767,31 @@ if(FALSE)
studentt = function(link.df="loglog", earg=list(),
- idf=NULL, nsimEIM=100)
+ idf=NULL, nsimEIM=300)
{
- if(mode(link.df) != "character" && mode(link.df) != "name")
+ if (mode(link.df) != "character" && mode(link.df) != "name")
link.df = as.character(substitute(link.df))
- if(!is.list(earg)) earg = list()
- if(!is.Numeric(nsimEIM, allow=1, integ=TRUE) || nsimEIM <= 10)
+ if (!is.list(earg)) earg = list()
+ if (!is.Numeric(nsimEIM, allow=1, integ=TRUE) || nsimEIM <= 10)
stop("'nsimEIM' should be an integer greater than 10")
- if(length(idf) && !is.Numeric(idf) && any(idf <= 1))
+ if (length(idf) && !is.Numeric(idf) && any(idf <= 1))
stop("'idf' should be > 1")
new("vglmff",
- blurb=c("Student t-distribution\n\n",
+ blurb = c("Student t-distribution\n\n",
"Link: ",
namesof("df", link.df, earg=earg),
"\n",
"Variance: df/(df-2) if df > 2\n"),
initialize=eval(substitute(expression({
- if(ncol(cbind(y)) != 1)
+ if (ncol(cbind(y)) != 1)
stop("response must be a vector or a one-column matrix")
predictors.names = namesof("df", .link.df, earg=.earg, tag=FALSE)
- if(!length(etastart)) {
- init.df = if(length( .idf )) .idf else
+ if (!length(etastart)) {
+ init.df = if (length( .idf )) .idf else
(2*var(y)/(var(y)-1)) # Should incorporate weights
- if(!is.Numeric(init.df) || init.df <= 1)
+ if (!is.Numeric(init.df) || init.df <= 1)
init.df = 4
etastart = rep(theta2eta(init.df, .link.df, earg= .earg),
len=length(y))
@@ -3794,7 +3801,7 @@ if(FALSE)
df = eta2theta(eta, .link.df, earg= .earg)
ifelse(df > 1, 0, NA)
}, list( .link.df=link.df, .earg=earg ))),
- last=eval(substitute(expression({
+ last = eval(substitute(expression({
misc$link = c(df = .plink )
misc$earg = list(df = .earg )
misc$simEIM = TRUE
@@ -3803,7 +3810,7 @@ if(FALSE)
loglikelihood=eval(substitute(
function(mu,y,w,residuals=FALSE,eta,extra=NULL) {
df = eta2theta(eta, .link.df, earg= .earg)
- if(residuals) stop("loglikelihood residuals not implemented yet") else {
+ if (residuals) stop("loglikelihood residuals not implemented yet") else {
sum(w * dt(x=y, df=df, log=TRUE))
}
}, list( .link.df=link.df, .earg=earg ))),
@@ -3830,7 +3837,7 @@ if(FALSE)
rm(ysim)
run.mean = ((ii-1) * run.mean + d2l.ddf2) / ii
}
- if(intercept.only)
+ if (intercept.only)
run.mean = mean(run.mean)
wz = -w * ddf.deta^2 * run.mean
wz
@@ -3840,19 +3847,19 @@ if(FALSE)
chisq = function(link = "loge", earg=list())
{
- if(mode(link) != "character" && mode(link) != "name")
+ if (mode(link) != "character" && mode(link) != "name")
link = as.character(substitute(link))
- if(!is.list(earg)) earg = list()
+ if (!is.list(earg)) earg = list()
new("vglmff",
- blurb=c("Chi-squared distribution\n\n",
+ blurb = c("Chi-squared distribution\n\n",
"Link: ",
namesof("df", link, earg=earg)),
inverse =eval(substitute(function(eta,extra=NULL) {
eta2theta(eta, .link, earg= .earg)
}, list( .link = link, .earg=earg ))),
initialize =eval(substitute(expression({
- if(ncol(cbind(y)) != 1)
+ if (ncol(cbind(y)) != 1)
stop("response must be a vector or a one-column matrix")
predictors.names = namesof("df", .link, earg=.earg, tag = FALSE)
mu = y + 0.167 * (y == 0)
@@ -3867,7 +3874,7 @@ if(FALSE)
loglikelihood =eval(substitute(
function(mu,y,w,residuals= FALSE,eta,extra=NULL) {
df = eta2theta(eta, .link, earg= .earg)
- if(residuals) stop("loglikelihood residuals not implemented yet") else
+ if (residuals) stop("loglikelihood residuals not implemented yet") else
sum(w * dchisq(x=y, df=df, ncp = 0, log = TRUE))
}, list( .link = link, .earg=earg ))),
vfamily="chisq",
@@ -3894,15 +3901,15 @@ if(FALSE)
emu=list(), esigma=list(), imu=NULL, isigma=NULL)
{
- if(mode(lmu) != "character" && mode(lmu) != "name")
+ if (mode(lmu) != "character" && mode(lmu) != "name")
lmu = as.character(substitute(lmu))
- if(mode(lsigma) != "character" && mode(lsigma) != "name")
+ if (mode(lsigma) != "character" && mode(lsigma) != "name")
lsigma = as.character(substitute(lsigma))
- if(!is.list(emu)) emu = list()
- if(!is.list(esigma)) esigma = list()
+ if (!is.list(emu)) emu = list()
+ if (!is.list(esigma)) esigma = list()
new("vglmff",
- blurb=c("Univariate Simplex distribution \n",
+ blurb = c("Univariate Simplex distribution \n",
"f(y) = [2*pi*sigma^2*(y*(1-y))^3]^(-0.5) * \n",
" exp[-0.5*(y-mu)^2 / (y*(1-y)*mu^2*(1-mu)^2)/sigma^2], ",
" 0 < y < 1,\n",
@@ -3913,13 +3920,13 @@ if(FALSE)
"Variance: sigma^2"),
initialize=eval(substitute(expression({
y = as.numeric(y)
- if(any(y <= 0 | y >= 1))
+ if (any(y <= 0 | y >= 1))
stop("all y values must be in (0,1)")
predictors.names = c(namesof("mu", .lmu, earg=.emu, tag=FALSE),
namesof("sigma", .lsigma, earg=.esigma, tag=FALSE))
- if(!length(etastart)) {
+ if (!length(etastart)) {
mu.init = rep(if(length( .imu)) .imu else
median(y), length=n)
sigma.init = rep(if(length( .isigma)) .isigma else
@@ -3934,7 +3941,7 @@ if(FALSE)
eta2theta(eta[,1], .lmu, earg= .emu)
}, list( .lmu=lmu,
.emu=emu, .esigma=esigma ))),
- last=eval(substitute(expression({
+ last = eval(substitute(expression({
misc$d3 = d3 # because save.weights=F
misc$link = c(mu= .lmu, sigma= .lsigma)
misc$earg = list(mu= .emu, sigma= .esigma)
@@ -3943,14 +3950,14 @@ if(FALSE)
.emu=emu, .esigma=esigma ))),
loglikelihood=eval(substitute(function(mu,y,w,residuals= FALSE,eta, extra=NULL) {
sigma = eta2theta(eta[,2], .lsigma, earg= .esigma)
- if(residuals) stop("loglikelihood residuals not implemented yet") else
+ if (residuals) stop("loglikelihood residuals not implemented yet") else
sum(w * (-0.5*log(2*pi*sigma^2*(y*(1-y))^3) -
(0.5/sigma^2)*(y-mu)^2 / (y*(1-y)*mu^2*(1-mu)^2 )))
}, list( .lsigma=lsigma,
.emu=emu, .esigma=esigma ))),
vfamily=c("simplex"),
deriv=eval(substitute(expression({
- if(iter==1) {
+ if (iter==1) {
d3 = deriv3(~ w * (-0.5*log(2*pi*sigma^2*(y*(1-y))^3) -
(0.5/sigma^2)*(y-mu)^2 / (y*(1-y)*mu^2*(1-mu)^2)),
c("mu", "sigma"), hessian= TRUE)
@@ -3976,14 +3983,14 @@ if(FALSE)
wz[,iam(2,2,M)] = -d2l.dthetas2[,2,2] * dtheta.detas[,2]^2
wz[,iam(1,2,M)] = -d2l.dthetas2[,1,2] * dtheta.detas[,1] *
dtheta.detas[,2]
- if(!.expected) {
+ if (!.expected) {
d2mudeta2 = d2theta.deta2(mu, .lmu, earg= .emu)
d2sigmadeta2 = d2theta.deta2(sigma, .lsigma, earg= .esigma)
wz[,iam(1,1,M)] = wz[,iam(1,1,M)] - dl.dthetas[,1] * d2mudeta2
wz[,iam(2,2,M)] = wz[,iam(2,2,M)] - dl.dthetas[,2] * d2sigmadeta2
}
- if(intercept.only) {
+ if (intercept.only) {
sumw = sum(w)
for(ii in 1:ncol(wz))
wz[,ii] = sum(wz[,ii]) / sumw
@@ -4003,17 +4010,17 @@ if(FALSE)
emu=list(), elambda=list(), imu=NULL, ilambda=1)
{
- if(mode(lmu) != "character" && mode(lmu) != "name")
+ if (mode(lmu) != "character" && mode(lmu) != "name")
lmu = as.character(substitute(lmu))
- if(mode(llambda) != "character" && mode(llambda) != "name")
+ if (mode(llambda) != "character" && mode(llambda) != "name")
llambda = as.character(substitute(llambda))
- if(!is.Numeric(ilambda, posit=TRUE))
+ if (!is.Numeric(ilambda, posit=TRUE))
stop("bad input for 'ilambda'")
- if(!is.list(emu)) emu = list()
- if(!is.list(elambda)) elambda = list()
+ if (!is.list(emu)) emu = list()
+ if (!is.list(elambda)) elambda = list()
new("vglmff",
- blurb=c("Reciprocal inverse Gaussian distribution \n",
+ blurb = c("Reciprocal inverse Gaussian distribution \n",
"f(y) = [lambda/(2*pi*y)]^(0.5) * \n",
" exp[-0.5*(lambda/y) * (y-mu)^2], ",
" 0 < y,\n",
@@ -4022,15 +4029,15 @@ if(FALSE)
namesof("lambda", llambda, earg=elambda), "\n\n",
"Mean: mu"),
initialize=eval(substitute(expression({
- if(ncol(cbind(y)) != 1)
+ if (ncol(cbind(y)) != 1)
stop("response must be a vector or a one-column matrix")
y = as.numeric(y)
- if(any(y <= 0))
+ if (any(y <= 0))
stop("all y values must be > 0")
predictors.names =
c(namesof("mu", .lmu, earg=.emu, tag=FALSE),
namesof("lambda", .llambda, earg=.elambda, tag=FALSE))
- if(!length(etastart)) {
+ if (!length(etastart)) {
mu.init = rep(if(length( .imu)) .imu else
median(y), length=n)
lambda.init = rep(if(length( .ilambda )) .ilambda else
@@ -4045,7 +4052,7 @@ if(FALSE)
eta2theta(eta[,1], .lmu, earg= .emu)
}, list( .lmu=lmu,
.emu=emu, .elambda=elambda ))),
- last=eval(substitute(expression({
+ last = eval(substitute(expression({
misc$d3 = d3 # because save.weights=FALSE
misc$link = c(mu= .lmu, lambda= .llambda)
misc$earg = list(mu= .emu, lambda= .elambda)
@@ -4055,13 +4062,13 @@ if(FALSE)
loglikelihood=eval(substitute(
function(mu,y,w,residuals= FALSE,eta, extra=NULL) {
lambda = eta2theta(eta[,2], .llambda, earg= .elambda)
- if(residuals) stop("loglikelihood residuals not implemented yet") else
+ if (residuals) stop("loglikelihood residuals not implemented yet") else
sum(w * (-0.5*log(y) + 0.5*log(lambda) - (0.5*lambda/y) * (y-mu)^2))
}, list( .llambda=llambda,
.emu=emu, .elambda=elambda ))),
vfamily=c("rig"),
deriv=eval(substitute(expression({
- if(iter==1) {
+ if (iter==1) {
d3 = deriv3(~ w *
(-0.5*log(y) + 0.5*log(lambda) - (0.5*lambda/y) * (y-mu)^2),
c("mu", "lambda"), hessian= TRUE)
@@ -4087,14 +4094,14 @@ if(FALSE)
wz[,iam(2,2,M)] = -d2l.dthetas2[,2,2] * dtheta.detas[,2]^2
wz[,iam(1,2,M)] = -d2l.dthetas2[,1,2] * dtheta.detas[,1] *
dtheta.detas[,2]
- if(!.expected) {
+ if (!.expected) {
d2mudeta2 = d2theta.deta2(mu, .lmu, earg= .emu)
d2lambda = d2theta.deta2(lambda, .llambda, earg= .elambda)
wz[,iam(1,1,M)] = wz[,iam(1,1,M)] - dl.dthetas[,1] * d2mudeta2
wz[,iam(2,2,M)] = wz[,iam(2,2,M)] - dl.dthetas[,2] * d2lambda
}
- if(intercept.only) {
+ if (intercept.only) {
sumw = sum(w)
for(ii in 1:ncol(wz))
wz[,ii] = sum(wz[,ii]) / sumw
@@ -4115,22 +4122,22 @@ if(FALSE)
init.theta=NULL)
{
- if(mode(link.theta) != "character" && mode(link.theta) != "name")
+ if (mode(link.theta) != "character" && mode(link.theta) != "name")
link.theta = as.character(substitute(link.theta))
- if(!is.list(earg)) earg = list()
+ if (!is.list(earg)) earg = list()
new("vglmff",
- blurb=c("Hyperbolic Secant distribution \n",
+ blurb = c("Hyperbolic Secant distribution \n",
"f(y) = exp(theta*y + log(cos(theta ))) / (2*cosh(pi*y/2))\n",
" for all y,\n",
"Link: ",
namesof("theta", link.theta, earg=earg), "\n\n",
"Mean: tan(theta)"),
initialize=eval(substitute(expression({
- if(ncol(cbind(y)) != 1)
+ if (ncol(cbind(y)) != 1)
stop("response must be a vector or a one-column matrix")
predictors.names = namesof("theta", .link.theta, earg=.earg, tag=FALSE)
- if(!length(etastart)) {
+ 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)
@@ -4141,14 +4148,14 @@ if(FALSE)
theta = eta2theta(eta, .link.theta, earg= .earg)
tan(theta)
}, list( .link.theta=link.theta, .earg=earg ))),
- last=eval(substitute(expression({
+ last = eval(substitute(expression({
misc$link = c(theta= .link.theta )
misc$earg = list(theta= .earg )
misc$expected = TRUE
}), list( .link.theta=link.theta, .earg=earg ))),
loglikelihood=eval(substitute(function(mu,y,w,residuals= FALSE,eta, extra=NULL) {
theta = eta2theta(eta, .link.theta, earg= .earg)
- if(residuals) stop("loglikelihood residuals not implemented yet") else
+ 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"),
@@ -4172,12 +4179,12 @@ if(FALSE)
init.theta=NULL)
{
- if(mode(link.theta) != "character" && mode(link.theta) != "name")
+ if (mode(link.theta) != "character" && mode(link.theta) != "name")
link.theta = as.character(substitute(link.theta))
- if(!is.list(earg)) earg = list()
+ if (!is.list(earg)) earg = list()
new("vglmff",
- blurb=c("Hyperbolic Secant distribution \n",
+ blurb = c("Hyperbolic Secant distribution \n",
"f(y) = (cos(theta)/pi) * y^(-0.5+theta/pi) * \n",
" (1-y)^(-0.5-theta/pi), ",
" 0 < y < 1,\n",
@@ -4186,13 +4193,13 @@ if(FALSE)
"Mean: 0.5 + theta/pi", "\n",
"Variance: (pi^2 - 4*theta^2) / (8*pi^2)"),
initialize=eval(substitute(expression({
- if(ncol(cbind(y)) != 1)
+ if (ncol(cbind(y)) != 1)
stop("response must be a vector or a one-column matrix")
y = as.numeric(y)
- if(any(y <= 0 | y >= 1))
+ if (any(y <= 0 | y >= 1))
stop("all y values must be in (0,1)")
predictors.names = namesof("theta", .link.theta, earg=.earg, tag=FALSE)
- if(!length(etastart)) {
+ if (!length(etastart)) {
theta.init = rep(if(length( .init.theta)) .init.theta else
median(y), length=n)
@@ -4204,14 +4211,14 @@ if(FALSE)
theta = eta2theta(eta, .link.theta, earg= .earg)
0.5 + theta/pi
}, list( .link.theta=link.theta, .earg=earg ))),
- last=eval(substitute(expression({
+ last = eval(substitute(expression({
misc$link = c(theta= .link.theta)
misc$earg = list(theta= .earg )
misc$expected = TRUE
}), list( .link.theta=link.theta, .earg=earg ))),
loglikelihood=eval(substitute(function(mu,y,w,residuals= FALSE,eta, extra=NULL) {
theta = eta2theta(eta, .link.theta, earg= .earg)
- if(residuals) stop("loglikelihood residuals not implemented yet") else
+ if (residuals) stop("loglikelihood residuals not implemented yet") else
sum(w * (log(cos(theta)) + (-0.5+theta/pi)*log(y) +
(-0.5-theta/pi)*log1p(-y )))
}, list( .link.theta=link.theta, .earg=earg ))),
@@ -4236,17 +4243,17 @@ if(FALSE)
{
- if(mode(lmu) != "character" && mode(lmu) != "name")
+ if (mode(lmu) != "character" && mode(lmu) != "name")
lmu = as.character(substitute(lmu))
- if(mode(llambda) != "character" && mode(llambda) != "name")
+ if (mode(llambda) != "character" && mode(llambda) != "name")
llambda = as.character(substitute(llambda))
- if(is.Numeric(ilambda) && any(ilambda <= -1))
+ if (is.Numeric(ilambda) && any(ilambda <= -1))
stop("ilambda must be > -1")
- if(!is.list(emu)) emu = list()
- if(!is.list(elambda)) elambda = list()
+ if (!is.list(emu)) emu = list()
+ if (!is.list(elambda)) elambda = list()
new("vglmff",
- blurb=c("Leipnik's distribution \n",
+ blurb = c("Leipnik's distribution \n",
"f(y) = (y(1-y))^(-1/2) * [1 + (y-mu)^2 / (y*(1-y))]^(-lambda/2) /\n",
" Beta[(lambda+1)/2, 1/2], ",
" 0 < y < 1, lambda > -1\n",
@@ -4256,15 +4263,15 @@ if(FALSE)
"Mean: mu\n",
"Variance: mu*(1-mu)"),
initialize=eval(substitute(expression({
- if(ncol(cbind(y)) != 1)
+ if (ncol(cbind(y)) != 1)
stop("response must be a vector or a one-column matrix")
y = as.numeric(y)
- if(any(y <= 0 | y >= 1))
+ if (any(y <= 0 | y >= 1))
stop("all y values must be in (0,1)")
predictors.names =
c(namesof("mu", .lmu, earg=.emu, tag=FALSE),
namesof("lambda", .llambda, earg=.elambda, tag=FALSE))
- if(!length(etastart)) {
+ if (!length(etastart)) {
mu.init = rep(if(length( .imu)) .imu else
(y), length=n)
lambda.init = rep(if(length( .ilambda)) .ilambda else
@@ -4278,7 +4285,7 @@ if(FALSE)
eta2theta(eta[,1], .lmu, earg= .emu)
}, list( .lmu=lmu,
.emu=emu, .elambda=elambda ))),
- last=eval(substitute(expression({
+ last = eval(substitute(expression({
misc$link = c(mu= .lmu, lambda= .llambda)
misc$earg = list(mu= .emu, lambda= .elambda)
misc$pooled.weight = pooled.weight
@@ -4288,7 +4295,7 @@ if(FALSE)
loglikelihood=eval(substitute(
function(mu,y,w,residuals= FALSE,eta, extra=NULL) {
lambda = eta2theta(eta[,2], .llambda, earg= .elambda)
- if(residuals) stop("loglikelihood residuals not implemented yet") else
+ if (residuals) stop("loglikelihood residuals not implemented yet") else
sum(w * (-0.5*log(y*(1-y)) - 0.5 * lambda *
log1p((y-mu)^2 / (y*(1-y ))) - lgamma((lambda+1)/2) +
lgamma(1+ lambda/2 )))
@@ -4308,7 +4315,7 @@ if(FALSE)
}), list( .lmu=lmu, .llambda=llambda,
.emu=emu, .elambda=elambda ))),
weight=eval(substitute(expression({
- if(is.R()) {
+ if (is.R()) {
denominator = y*(1-y) + (y-mu)^2
d2l.dthetas2 = array(NA, c(n,2,2))
d2l.dthetas2[,1,1] = w * lambda*(-y*(1-y)+(y-mu)^2)/denominator^2
@@ -4325,14 +4332,14 @@ if(FALSE)
wz[,iam(2,2,M)] = -d2l.dthetas2[,2,2] * dtheta.detas[,2]^2
wz[,iam(1,2,M)] = -d2l.dthetas2[,1,2] * dtheta.detas[,1] *
dtheta.detas[,2]
- if(!.expected) {
+ if (!.expected) {
d2mudeta2 = d2theta.deta2(mu, .lmu, earg= .emu)
d2lambda = d2theta.deta2(lambda, .llambda, earg= .elambda)
wz[,iam(1,1,M)] = wz[,iam(1,1,M)] - dl.dthetas[,1] * d2mudeta2
wz[,iam(2,2,M)] = wz[,iam(2,2,M)] - dl.dthetas[,2] * d2lambda
}
- if(intercept.only) {
+ if (intercept.only) {
sumw = sum(w)
for(ii in 1:ncol(wz))
wz[,ii] = sum(wz[,ii]) / sumw
@@ -4358,17 +4365,17 @@ if(FALSE)
zero=NULL)
{
- if(mode(lrho) != "character" && mode(lrho) != "name")
+ if (mode(lrho) != "character" && mode(lrho) != "name")
lrho = as.character(substitute(lrho))
- if(mode(llambda) != "character" && mode(llambda) != "name")
+ if (mode(llambda) != "character" && mode(llambda) != "name")
llambda = as.character(substitute(llambda))
- if(length(zero) && !is.Numeric(zero, integer=TRUE, posit=TRUE))
+ if (length(zero) && !is.Numeric(zero, integer=TRUE, posit=TRUE))
stop("bad input for argument 'zero'")
- if(!is.list(erho)) erho = list()
- if(!is.list(elambda)) elambda = list()
+ if (!is.list(erho)) erho = list()
+ if (!is.list(elambda)) elambda = list()
new("vglmff",
- blurb=c("Inverse binomial distribution\n\n",
+ blurb = c("Inverse binomial distribution\n\n",
"Links: ",
namesof("rho", lrho, earg=erho), ", ",
namesof("lambda", llambda, earg=elambda), "\n",
@@ -4378,12 +4385,12 @@ if(FALSE)
constraints = cm.zero.vgam(constraints, x, .zero, M)
}), list( .zero=zero ))),
initialize=eval(substitute(expression({
- if(ncol(cbind(y)) != 1)
+ if (ncol(cbind(y)) != 1)
stop("response must be a vector or a one-column matrix")
predictors.names =
c(namesof("rho", .lrho, earg=.erho, tag=FALSE),
namesof("lambda", .llambda, earg=.elambda, tag=FALSE))
- if(!length(etastart)) {
+ if (!length(etastart)) {
covarn = sd(y)^2 / weighted.mean(y, w)
temp1 = 0.5 + (1 + sqrt(1+8*covarn)) / (8*covarn)
temp2 = 0.5 + (1 - sqrt(1+8*covarn)) / (8*covarn)
@@ -4405,7 +4412,7 @@ if(FALSE)
ifelse(rho > 0.5, lambda*(1-rho)/(2*rho-1), NA)
}, list( .llambda=llambda, .lrho=lrho,
.elambda=elambda, .erho=erho ))),
- last=eval(substitute(expression({
+ last = eval(substitute(expression({
misc$link = c(rho= .lrho, lambda= .llambda)
misc$earg = list(rho= .erho, lambda= .elambda)
misc$pooled.weight = pooled.weight
@@ -4415,7 +4422,7 @@ if(FALSE)
function(mu, y, w, residuals= FALSE,eta, extra=NULL) {
rho = eta2theta(eta[,1], .lrho, earg= .erho)
lambda = eta2theta(eta[,2], .llambda, earg= .elambda)
- if(residuals) stop("loglikelihood residuals not implemented yet") else
+ if (residuals) stop("loglikelihood residuals not implemented yet") else
sum(w*(log(lambda) - lgamma(2*y+lambda) - lgamma(y+1) -
lgamma(y+lambda+1) + y*log(rho) + y*log1p(-rho) +
lambda*log(rho)))
@@ -4446,7 +4453,7 @@ if(FALSE)
d2lambda.deta2 = d2theta.deta2(lambda, .llambda, earg= .elambda)
wz = w * wz
- if(intercept.only) {
+ if (intercept.only) {
pooled.weight = TRUE
wz[,iam(2,2,M)] = sum(wz[,iam(2,2,M)]) / sum(w)
@@ -4470,22 +4477,22 @@ if(FALSE)
{
- if(mode(llambda) != "character" && mode(llambda) != "name")
+ if (mode(llambda) != "character" && mode(llambda) != "name")
llambda = as.character(substitute(llambda))
- if(mode(ltheta) != "character" && mode(ltheta) != "name")
+ if (mode(ltheta) != "character" && mode(ltheta) != "name")
ltheta = as.character(substitute(ltheta))
- if(length(zero) && !is.Numeric(zero, integer=TRUE, posit=TRUE))
+ if (length(zero) && !is.Numeric(zero, integer=TRUE, posit=TRUE))
stop("bad input for argument 'zero'")
- if(!is.list(elambda)) elambda = list()
- if(!is.list(etheta)) etheta = list()
- if(!is.Numeric(method.init, allow=1, integ=TRUE, posit=TRUE) ||
+ if (!is.list(elambda)) elambda = list()
+ if (!is.list(etheta)) etheta = list()
+ if (!is.Numeric(method.init, allow=1, integ=TRUE, posit=TRUE) ||
method.init > 2)
stop("'method.init' must be 1 or 2")
- if(!is.logical(use.approx) || length(use.approx) != 1)
+ if (!is.logical(use.approx) || length(use.approx) != 1)
stop("'use.approx' must be logical value")
new("vglmff",
- blurb=c("Generalized Poisson distribution\n\n",
+ blurb = c("Generalized Poisson distribution\n\n",
"Links: ",
namesof("lambda", llambda, earg=elambda), ", ",
namesof("theta", ltheta, earg=etheta), "\n",
@@ -4495,27 +4502,27 @@ if(FALSE)
constraints = cm.zero.vgam(constraints, x, .zero, M)
}), list( .zero=zero ))),
initialize=eval(substitute(expression({
- if(ncol(cbind(y)) != 1)
+ if (ncol(cbind(y)) != 1)
stop("response must be a vector or a one-column matrix")
predictors.names =
c(namesof("lambda", .llambda, earg=.elambda, tag=FALSE),
namesof("theta", .ltheta, earg=.etheta, tag=FALSE))
- init.lambda = if( .method.init == 1)
+ init.lambda = if ( .method.init == 1)
1 - sqrt(weighted.mean(y,w) / var(y)) else 0.5
- init.theta = if( .method.init == 1)
+ init.theta = if ( .method.init == 1)
sqrt((0.01+weighted.mean(y,w)^3)/var(y)) else
median(y)*(1-init.lambda)
- if(init.theta <= 0)
+ if (init.theta <= 0)
init.theta = 0.1
- cutpt = if(init.lambda < 0) {
+ cutpt = if (init.lambda < 0) {
mmm = max(trunc(-init.theta / init.lambda), 4)
max(-1, -init.theta /mmm)
} else -1
- if(init.lambda <= cutpt)
+ if (init.lambda <= cutpt)
init.lambda = cutpt + 0.1
- if(init.lambda >= 1)
+ if (init.lambda >= 1)
init.lambda = 0.9
- if(!length(etastart)) {
+ if (!length(etastart)) {
lambda = rep(if(length( .ilambda)) .ilambda else
init.lambda, length=n)
theta = rep(if(length( .itheta)) .itheta else init.theta, length=n)
@@ -4532,10 +4539,10 @@ if(FALSE)
theta/(1-lambda)
}, list( .ltheta=ltheta, .llambda=llambda,
.etheta=etheta, .elambda=elambda ))),
- last=eval(substitute(expression({
+ last = eval(substitute(expression({
misc$link = c(lambda=.llambda, theta=.ltheta)
misc$earg = list(lambda=.elambda, theta=.etheta)
- if(! .use.approx )
+ if (! .use.approx )
misc$pooled.weight = pooled.weight
}), list( .ltheta=ltheta, .llambda=llambda,
.use.approx = use.approx,
@@ -4545,7 +4552,7 @@ if(FALSE)
lambda = eta2theta(eta[,1], .llambda, earg= .elambda)
theta = eta2theta(eta[,2], .ltheta, earg= .etheta)
index = (y == 0)
- if(residuals) stop("loglikelihood residuals not implemented yet") else
+ if (residuals) stop("loglikelihood residuals not implemented yet") else
sum(w[index]*(-theta[index])) +
sum(w[!index] * (-y[!index]*lambda[!index]-theta[!index] +
(y[!index]-1)*log(theta[!index]+y[!index]*lambda[!index]) +
@@ -4565,7 +4572,7 @@ if(FALSE)
.etheta=etheta, .elambda=elambda ))),
weight=eval(substitute(expression({
wz = matrix(as.numeric(NA), n, dimm(M)) #3=dimm(M)
- if( .use.approx ) {
+ if ( .use.approx ) {
BBB = (theta+2)*(theta+2*lambda-theta*lambda)-(theta^2)*(1-lambda)
d2l.dlambda2 = 2 * theta * (theta+2) / ((1-lambda) * BBB)
d2l.dtheta2 = 2 * (1 + lambda * (2/theta - 1)) / BBB
@@ -4588,7 +4595,7 @@ if(FALSE)
wz[,iam(2,2,M)] = wz[,iam(2,2,M)] - dl.dtheta * d2THETA.deta2
wz = w * wz
- if(intercept.only) {
+ if (intercept.only) {
sumw = sum(w)
for(ii in 1:ncol(wz))
wz[,ii] = sum(wz[,ii]) / sumw
@@ -4609,36 +4616,36 @@ if(FALSE)
dlgamma = function(x, location=0, scale=1, k=1, log=FALSE) {
- if(!is.logical(log.arg <- log))
+ if (!is.logical(log.arg <- log))
stop("bad input for argument 'log'")
rm(log)
- if(!is.Numeric(scale, posit=TRUE)) stop("bad input for argument 'scale'")
- if(!is.Numeric(k, posit=TRUE)) stop("bad input for argument 'k'")
+ if (!is.Numeric(scale, posit=TRUE)) stop("bad input for argument 'scale'")
+ if (!is.Numeric(k, posit=TRUE)) stop("bad input for argument 'k'")
z = (x-location) / scale
- if(log.arg) {
+ if (log.arg) {
k * z - exp(z) - log(scale) - lgamma(k)
} else {
exp(k * z - exp(z)) / (scale * gamma(k))
}
}
plgamma = function(q, location=0, scale=1, k=1) {
- if(!is.Numeric(scale, posit=TRUE)) stop("bad input for argument 'scale'")
- if(!is.Numeric(k, posit=TRUE)) stop("bad input for argument 'k'")
+ if (!is.Numeric(scale, posit=TRUE)) stop("bad input for argument 'scale'")
+ if (!is.Numeric(k, posit=TRUE)) stop("bad input for argument 'k'")
z = (q-location)/scale
pgamma(exp(z), k)
}
qlgamma = function(p, location=0, scale=1, k=1) {
- if(!is.Numeric(scale, posit=TRUE)) stop("bad input for argument 'scale'")
- if(!is.Numeric(k, posit=TRUE)) stop("bad input for argument 'k'")
+ if (!is.Numeric(scale, posit=TRUE)) stop("bad input for argument 'scale'")
+ if (!is.Numeric(k, posit=TRUE)) stop("bad input for argument 'k'")
q = qgamma(p, k)
location + scale * log(q)
}
rlgamma = function(n, location=0, scale=1, k=1) {
- if(!is.Numeric(n, posit=TRUE, integ=TRUE, allow=1))
+ if (!is.Numeric(n, posit=TRUE, integ=TRUE, allow=1))
stop("bad input for argument 'n'")
- if(!is.Numeric(scale, posit=TRUE)) stop("bad input for argument 'scale'")
- if(!is.Numeric(k, posit=TRUE)) stop("bad input for argument 'k'")
+ if (!is.Numeric(scale, posit=TRUE)) stop("bad input for argument 'scale'")
+ if (!is.Numeric(k, posit=TRUE)) stop("bad input for argument 'k'")
y = rgamma(n, k)
location + scale * log(y)
}
@@ -4647,23 +4654,23 @@ rlgamma = function(n, location=0, scale=1, k=1) {
lgammaff = function(link="loge", earg=list(), init.k=NULL)
{
- if(mode(link) != "character" && mode(link) != "name")
+ if (mode(link) != "character" && mode(link) != "name")
link = as.character(substitute(link))
- if(!is.list(earg)) earg = list()
+ if (!is.list(earg)) earg = list()
new("vglmff",
- blurb=c("Log-gamma distribution f(y) = exp(ky - e^y)/gamma(k)), k>0\n\n",
+ blurb = c("Log-gamma distribution f(y) = exp(ky - e^y)/gamma(k)), k>0\n\n",
"Link: ",
namesof("k", link, earg=earg), "\n", "\n",
"Mean: digamma(k)", "\n"),
initialize=eval(substitute(expression({
- if(ncol(cbind(y)) != 1)
+ if (ncol(cbind(y)) != 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, len=length(y)) else {
+ if (!length(etastart)) {
+ k.init = if (length( .init.k)) rep( .init.k, len=length(y)) else {
medy = median(y)
- if(medy < 2) 5 else if(medy < 4) 20 else exp(0.7 * medy)
+ if (medy < 2) 5 else if (medy < 4) 20 else exp(0.7 * medy)
}
etastart = theta2eta(k.init, .link, earg= .earg)
}
@@ -4672,7 +4679,7 @@ rlgamma = function(n, location=0, scale=1, k=1) {
k = eta2theta(eta, .link, earg= .earg)
digamma(k)
}, list( .link=link, .earg=earg ))),
- last=eval(substitute(expression({
+ last = eval(substitute(expression({
misc$link = c(k= .link )
misc$earg = list(k= .earg )
misc$expected = TRUE
@@ -4680,7 +4687,7 @@ rlgamma = function(n, location=0, scale=1, k=1) {
loglikelihood=eval(substitute(
function(mu,y,w,residuals= FALSE,eta, extra=NULL) {
kk = eta2theta(eta, .link, earg= .earg)
- if(residuals) stop("loglikelihood residuals not implemented yet") else {
+ if (residuals) stop("loglikelihood residuals not implemented yet") else {
sum(w * dlgamma(x=y, location=0, scale=1, k=kk, log=TRUE))
}
}, list( .link=link, .earg=earg ))),
@@ -4703,22 +4710,22 @@ rlgamma = function(n, location=0, scale=1, k=1) {
elocation=list(), escale=list(), eshape=list(),
ilocation=NULL, iscale=NULL, ishape=1, zero=NULL)
{
- if(mode(llocation) != "character" && mode(llocation) != "name")
+ if (mode(llocation) != "character" && mode(llocation) != "name")
llocation = as.character(substitute(llocation))
- if(mode(lscale) != "character" && mode(lscale) != "name")
+ if (mode(lscale) != "character" && mode(lscale) != "name")
lscale = as.character(substitute(lscale))
- if(mode(lshape) != "character" && mode(lshape) != "name")
+ if (mode(lshape) != "character" && mode(lshape) != "name")
lshape = as.character(substitute(lshape))
- if(length(zero) && !is.Numeric(zero, integer=TRUE, posit=TRUE))
+ if (length(zero) && !is.Numeric(zero, integer=TRUE, posit=TRUE))
stop("bad input for argument 'zero'")
- if(length(iscale) && !is.Numeric(iscale, posit=TRUE))
+ if (length(iscale) && !is.Numeric(iscale, posit=TRUE))
stop("bad input for argument 'iscale'")
- if(!is.list(elocation)) elocation = list()
- if(!is.list(escale)) escale = list()
- if(!is.list(eshape)) eshape = list()
+ if (!is.list(elocation)) elocation = list()
+ if (!is.list(escale)) escale = list()
+ if (!is.list(eshape)) eshape = list()
new("vglmff",
- blurb=c("Log-gamma distribution",
+ blurb = c("Log-gamma distribution",
" f(y) = exp(k(y-a)/b - e^((y-a)/b))/(b*gamma(k)), ",
"location=a, scale=b>0, shape=k>0\n\n",
"Links: ",
@@ -4730,20 +4737,20 @@ rlgamma = function(n, location=0, scale=1, k=1) {
constraints = cm.zero.vgam(constraints, x, .zero, M)
}), list( .zero=zero ))),
initialize=eval(substitute(expression({
- if(ncol(cbind(y)) != 1)
+ if (ncol(cbind(y)) != 1)
stop("response must be a vector or a one-column matrix")
predictors.names =
c(namesof("location", .llocation, earg=.elocation, tag=FALSE),
namesof("scale", .lscale, earg=.escale, tag=FALSE),
namesof("shape", .lshape, earg=.eshape, tag=FALSE))
- if(!length(etastart)) {
- k.init = if(length( .ishape)) rep( .ishape, len=length(y)) else {
+ if (!length(etastart)) {
+ k.init = if (length( .ishape)) rep( .ishape, len=length(y)) else {
rep(exp(median(y)), len=length(y))
}
- scale.init = if(length( .iscale)) rep( .iscale, len=length(y)) else {
+ scale.init = if (length( .iscale)) rep( .iscale, len=length(y)) else {
rep(sqrt(var(y) / trigamma(k.init)), len=length(y))
}
- loc.init = if(length( .iloc)) rep( .iloc, len=length(y)) else {
+ loc.init = if (length( .iloc)) rep( .iloc, len=length(y)) else {
rep(median(y) - scale.init * digamma(k.init), len=length(y))
}
etastart = cbind(theta2eta(loc.init, .llocation, earg= .elocation),
@@ -4759,7 +4766,7 @@ rlgamma = function(n, location=0, scale=1, k=1) {
digamma(eta2theta(eta[,3], .lshape, earg= .eshape))
}, list( .llocation=llocation, .lscale=lscale, .lshape=lshape,
.elocation=elocation, .escale=escale, .eshape=eshape ))),
- last=eval(substitute(expression({
+ last = eval(substitute(expression({
misc$link = c(location= .llocation, scale= .lscale, shape= .lshape)
misc$earg = list(location= .elocation, scale= .escale, shape= .eshape)
}), list( .llocation=llocation, .lscale=lscale, .lshape=lshape,
@@ -4769,7 +4776,7 @@ rlgamma = function(n, location=0, scale=1, k=1) {
aa = eta2theta(eta[,1], .llocation, earg= .elocation)
bb = eta2theta(eta[,2], .lscale, earg= .escale)
kk = eta2theta(eta[,3], .lshape, earg= .eshape)
- if(residuals) stop("loglikelihood residuals not implemented yet") else {
+ if (residuals) stop("loglikelihood residuals not implemented yet") else {
sum(w * dlgamma(x=y, location=aa, scale=bb, k=kk, log=TRUE))
}
}, list( .llocation=llocation, .lscale=lscale, .lshape=lshape,
@@ -4813,22 +4820,22 @@ rlgamma = function(n, location=0, scale=1, k=1) {
elocation=list(), escale=list(), eshape=list(),
ilocation=NULL, iscale=NULL, ishape=NULL, zero=NULL)
{
- if(mode(llocation) != "character" && mode(llocation) != "name")
+ if (mode(llocation) != "character" && mode(llocation) != "name")
llocation = as.character(substitute(llocation))
- if(mode(lscale) != "character" && mode(lscale) != "name")
+ if (mode(lscale) != "character" && mode(lscale) != "name")
lscale = as.character(substitute(lscale))
- if(mode(lshape) != "character" && mode(lshape) != "name")
+ if (mode(lshape) != "character" && mode(lshape) != "name")
lshape = as.character(substitute(lshape))
- if(length(zero) && !is.Numeric(zero, integer=TRUE, posit=TRUE))
+ if (length(zero) && !is.Numeric(zero, integer=TRUE, posit=TRUE))
stop("bad input for argument 'zero'")
- if(length(iscale) && !is.Numeric(iscale, posit=TRUE))
+ if (length(iscale) && !is.Numeric(iscale, posit=TRUE))
stop("bad input for argument 'iscale'")
- if(!is.list(elocation)) elocation = list()
- if(!is.list(escale)) escale = list()
- if(!is.list(eshape)) eshape = list()
+ if (!is.list(elocation)) elocation = list()
+ if (!is.list(escale)) escale = list()
+ if (!is.list(eshape)) eshape = list()
new("vglmff",
- blurb=c("Log-gamma distribution (Prentice, 1974)",
+ blurb = c("Log-gamma distribution (Prentice, 1974)",
" f(y) = |q| * exp(w/q^2 - e^w) / (b*gamma(1/q^2)) ,\n",
"w=(y-a)*q/b + digamma(1/q^2), location=a, scale=b>0, shape=q\n\n",
"Links: ",
@@ -4840,22 +4847,22 @@ rlgamma = function(n, location=0, scale=1, k=1) {
constraints = cm.zero.vgam(constraints, x, .zero, M)
}), list( .zero=zero ))),
initialize=eval(substitute(expression({
- if(ncol(cbind(y)) != 1)
+ if (ncol(cbind(y)) != 1)
stop("response must be a vector or a one-column matrix")
predictors.names =
c(namesof("location", .llocation, earg=.elocation, tag=FALSE),
namesof("scale", .lscale, earg=.escale, tag=FALSE),
namesof("shape", .lshape, earg=.eshape, tag=FALSE))
- if(!length(etastart)) {
+ if (!length(etastart)) {
sdy = sqrt(var(y))
- k.init = if(length( .ishape)) rep( .ishape, len=length(y)) else {
+ k.init = if (length( .ishape)) rep( .ishape, len=length(y)) else {
skewness = mean((y-mean(y))^3) / sdy^3 # <0 Left Skewed
rep(-skewness, len=length(y))
}
- scale.init = if(length( .iscale)) rep( .iscale, len=length(y)) else {
+ scale.init = if (length( .iscale)) rep( .iscale, len=length(y)) else {
rep(sdy, len=length(y))
}
- loc.init = if(length( .iloc)) rep( .iloc, len=length(y)) else {
+ loc.init = if (length( .iloc)) rep( .iloc, len=length(y)) else {
rep(median(y), len=length(y))
}
etastart = cbind(theta2eta(loc.init, .llocation, earg= .elocation),
@@ -4869,7 +4876,7 @@ rlgamma = function(n, location=0, scale=1, k=1) {
eta2theta(eta[,1], .llocation, earg= .elocation)
}, list( .llocation=llocation, .lscale=lscale, .lshape=lshape,
.elocation=elocation, .escale=escale, .eshape=eshape ))),
- last=eval(substitute(expression({
+ last = eval(substitute(expression({
misc$link = c(location= .llocation, scale= .lscale, shape= .lshape)
misc$earg = list(location= .elocation, scale= .escale, shape= .eshape)
}), list( .llocation=llocation, .lscale=lscale, .lshape=lshape,
@@ -4881,7 +4888,7 @@ rlgamma = function(n, location=0, scale=1, k=1) {
k = eta2theta(eta[,3], .lshape, earg= .eshape)
tmp55 = k^(-2)
doubw = (y-a)*k/b + digamma(tmp55)
- if(residuals) stop("loglikelihood residuals not implemented yet") else
+ if (residuals) stop("loglikelihood residuals not implemented yet") else
sum(w*(log(abs(k)) -log(b) -lgamma(tmp55) + doubw*tmp55 -exp(doubw )))
}, list( .llocation=llocation, .lscale=lscale, .lshape=lshape,
.elocation=elocation, .escale=escale, .eshape=eshape ))),
@@ -4928,25 +4935,25 @@ rlgamma = function(n, location=0, scale=1, k=1) {
dggamma = function(x, scale=1, d=1, k=1, log = FALSE) {
- if(!is.logical(log.arg <- log))
+ if (!is.logical(log.arg <- log))
stop("bad input for argument 'log'")
rm(log)
- if(!is.Numeric(scale, posit=TRUE)) stop("bad input for argument 'scale'")
- if(!is.Numeric(d, posit=TRUE)) stop("bad input for argument 'd'")
- if(!is.Numeric(k, posit=TRUE)) stop("bad input for argument 'k'")
+ if (!is.Numeric(scale, posit=TRUE)) stop("bad input for argument 'scale'")
+ if (!is.Numeric(d, posit=TRUE)) stop("bad input for argument 'd'")
+ if (!is.Numeric(k, posit=TRUE)) stop("bad input for argument 'k'")
N = max(length(x), length(scale), length(d), length(k))
x = rep(x, len=N); scale = rep(scale, len=N);
d = rep(d, len=N); k = rep(k, len=N);
Loglik = rep(log(0), len=N)
xok = x > 0
- if(any(xok)) {
+ if (any(xok)) {
zedd = (x[xok]/scale[xok])^d[xok]
Loglik[xok] = log(d[xok]) + (-d[xok]*k[xok]) * log(scale[xok]) +
(d[xok]*k[xok]-1) * log(x[xok]) - zedd - lgamma(k[xok])
}
- if(log.arg) {
+ if (log.arg) {
Loglik
} else {
exp(Loglik)
@@ -4957,25 +4964,25 @@ dggamma = function(x, scale=1, d=1, k=1, log = FALSE) {
pggamma = function(q, scale=1, d=1, k=1) {
- if(!is.Numeric(scale, posit=TRUE)) stop("bad input for argument 'scale'")
- if(!is.Numeric(d, posit=TRUE)) stop("bad input for argument 'd'")
- if(!is.Numeric(k, posit=TRUE)) stop("bad input for argument 'k'")
+ if (!is.Numeric(scale, posit=TRUE)) stop("bad input for argument 'scale'")
+ if (!is.Numeric(d, posit=TRUE)) stop("bad input for argument 'd'")
+ if (!is.Numeric(k, posit=TRUE)) stop("bad input for argument 'k'")
z = (q/scale)^d
pgamma(z, k)
}
qggamma = function(p, scale=1, d=1, k=1) {
- if(!is.Numeric(scale, posit=TRUE)) stop("bad input for argument 'scale'")
- if(!is.Numeric(d, posit=TRUE)) stop("bad input for argument 'd'")
- if(!is.Numeric(k, posit=TRUE)) stop("bad input for argument 'k'")
+ if (!is.Numeric(scale, posit=TRUE)) stop("bad input for argument 'scale'")
+ if (!is.Numeric(d, posit=TRUE)) stop("bad input for argument 'd'")
+ if (!is.Numeric(k, posit=TRUE)) stop("bad input for argument 'k'")
q = qgamma(p, k)
scale * q^(1/d)
}
rggamma = function(n, scale=1, d=1, k=1) {
- if(!is.Numeric(n, posit=TRUE, integ=TRUE, allow=1))
+ if (!is.Numeric(n, posit=TRUE, integ=TRUE, allow=1))
stop("bad input for 'n'")
- if(!is.Numeric(scale, posit=TRUE)) stop("bad input for 'scale'")
- if(!is.Numeric(d, posit=TRUE)) stop("bad input for 'd'")
- if(!is.Numeric(k, posit=TRUE)) stop("bad input for 'k'")
+ if (!is.Numeric(scale, posit=TRUE)) stop("bad input for 'scale'")
+ if (!is.Numeric(d, posit=TRUE)) stop("bad input for 'd'")
+ if (!is.Numeric(k, posit=TRUE)) stop("bad input for 'k'")
y = rgamma(n, k)
scale * y^(1/d)
}
@@ -4984,22 +4991,22 @@ rggamma = function(n, scale=1, d=1, k=1) {
escale=list(), ed=list(), ek=list(),
iscale=NULL, id=NULL, ik=NULL, zero=NULL)
{
- if(mode(lscale) != "character" && mode(lscale) != "name")
+ if (mode(lscale) != "character" && mode(lscale) != "name")
lscale = as.character(substitute(lscale))
- if(mode(ld) != "character" && mode(ld) != "name")
+ if (mode(ld) != "character" && mode(ld) != "name")
ld = as.character(substitute(ld))
- if(mode(lk) != "character" && mode(lk) != "name")
+ if (mode(lk) != "character" && mode(lk) != "name")
lk = as.character(substitute(lk))
- if(length(zero) && !is.Numeric(zero, integer=TRUE, posit=TRUE))
+ if (length(zero) && !is.Numeric(zero, integer=TRUE, posit=TRUE))
stop("bad input for argument 'zero'")
- if(length(iscale) && !is.Numeric(iscale, posit=TRUE))
+ if (length(iscale) && !is.Numeric(iscale, posit=TRUE))
stop("bad input for argument 'iscale'")
- if(!is.list(escale)) escale = list()
- if(!is.list(ed)) ed = list()
- if(!is.list(ek)) ek = list()
+ if (!is.list(escale)) escale = list()
+ if (!is.list(ed)) ed = list()
+ if (!is.list(ek)) ek = list()
new("vglmff",
- blurb=c("Generalized gamma distribution",
+ blurb = c("Generalized gamma distribution",
" f(y) = d * b^(-d*k) * y^(d*k-1) * exp(-(y/b)^d) / gamma(k),\n",
"scale=b>0, d>0, k>0, y>0\n\n",
"Links: ",
@@ -5011,21 +5018,21 @@ rggamma = function(n, scale=1, d=1, k=1) {
constraints = cm.zero.vgam(constraints, x, .zero, M)
}), list( .zero=zero ))),
initialize=eval(substitute(expression({
- if(ncol(cbind(y)) != 1)
+ if (ncol(cbind(y)) != 1)
stop("response must be a vector or a one-column matrix")
- if(any(y <= 0)) stop("response must be have positive values only")
+ if (any(y <= 0)) stop("response must be have positive values only")
predictors.names =
c(namesof("scale", .lscale, earg=.escale, tag=FALSE),
namesof("d", .ld, earg=.ed, tag=FALSE),
namesof("k", .lk, earg=.ek, tag=FALSE))
- if(!length(etastart)) {
- b.init = if(length( .iscale)) rep( .iscale, len=length(y)) else {
+ if (!length(etastart)) {
+ b.init = if (length( .iscale)) rep( .iscale, len=length(y)) else {
rep(mean(y^2) / mean(y), len=length(y))
}
- k.init = if(length( .ik)) rep( .ik, len=length(y)) else {
+ k.init = if (length( .ik)) rep( .ik, len=length(y)) else {
rep(mean(y) / b.init, len=length(y))
}
- d.init = if(length( .id)) rep( .id, len=length(y)) else {
+ d.init = if (length( .id)) rep( .id, len=length(y)) else {
rep(digamma(k.init) / mean(log(y/b.init)), len=length(y))
}
etastart = cbind(theta2eta(b.init, .lscale, earg= .escale),
@@ -5041,7 +5048,7 @@ rggamma = function(n, scale=1, d=1, k=1) {
b * k
}, list( .ld=ld, .lscale=lscale, .lk=lk,
.escale=escale, .ed=ed, .ek=ek ))),
- last=eval(substitute(expression({
+ last = eval(substitute(expression({
misc$link = c(scale= .lscale, d= .ld, k= .lk)
misc$earg = list(scale= .escale, d= .ed, k= .ek)
}), list( .lscale=lscale, .ld=ld, .lk=lk,
@@ -5051,7 +5058,7 @@ rggamma = function(n, scale=1, d=1, k=1) {
b = eta2theta(eta[,1], .lscale, earg= .escale)
d = eta2theta(eta[,2], .ld, earg= .ed)
k = eta2theta(eta[,3], .lk, earg= .ek)
- if(residuals) stop("loglikelihood residuals not implemented yet") else {
+ if (residuals) stop("loglikelihood residuals not implemented yet") else {
sum(w * dggamma(x=y, scale=b, d=d, k=k, log = TRUE))
}
}, list( .lscale=lscale, .ld=ld, .lk=lk,
@@ -5094,18 +5101,21 @@ rggamma = function(n, scale=1, d=1, k=1) {
dlog = function(x, prob, log=FALSE) {
- if(!is.logical(log.arg <- log))
+ if (!is.logical(log.arg <- log))
stop("bad input for argument 'log'")
rm(log)
- if(!is.Numeric(prob, posit=TRUE) || max(prob) >= 1)
+ if (!is.Numeric(prob, posit=TRUE) || max(prob) >= 1)
stop("bad input for argument 'prob'")
N = max(length(x), length(prob))
- x = rep(x, len=N); prob = rep(prob, len=N);
+ if (length(x) != N)
+ x = rep(x, len=N)
+ if (length(prob) != N)
+ prob = rep(prob, len=N)
ox = !is.finite(x)
zero = ox | round(x) != x | x < 1
ans = rep(0.0, len=length(x))
- if(log.arg) {
+ if (log.arg) {
ans[ zero] = log(0.0)
ans[!zero] = x[!zero] * log(prob[!zero]) - log(x[!zero]) -
log(-log1p(-prob[!zero]))
@@ -5113,7 +5123,7 @@ dlog = function(x, prob, log=FALSE) {
ans[!zero] = -(prob[!zero]^(x[!zero])) / (x[!zero] *
log1p(-prob[!zero]))
}
- if(any(ox))
+ if (any(ox))
ans[ox] = NA
ans
}
@@ -5121,15 +5131,15 @@ dlog = function(x, prob, log=FALSE) {
plog = function(q, prob, log.p=FALSE) {
- if(!is.Numeric(q)) stop("bad input for argument 'q'")
- if(!is.Numeric(prob, posit=TRUE) || max(prob) >= 1)
+ if (!is.Numeric(q)) stop("bad input for argument 'q'")
+ if (!is.Numeric(prob, posit=TRUE) || max(prob) >= 1)
stop("bad input for argument 'prob'")
N = max(length(q), length(prob))
q = rep(q, len=N); prob = rep(prob, len=N);
bigno = 10
owen1965 = (q * (1 - prob) > bigno)
- if(specialCase <- any(owen1965)) {
+ if (specialCase <- any(owen1965)) {
qqq = q[owen1965]
ppp = prob[owen1965]
pqp = qqq * (1 - ppp)
@@ -5150,11 +5160,11 @@ plog = function(q, prob, log.p=FALSE) {
x=as.double(onevector), answer=double(N),
as.integer(N), as.double(seqq),
as.integer(length(onevector)), notok=integer(1))
- if(rlist$notok != 0) stop("error in 'cum8sum'")
- ans = if(log.p) log(rlist$answer) else rlist$answer
- if(specialCase)
- ans[owen1965] = if(log.p) log(bigans) else bigans
- ans[q < 1] = if(log.p) log(0.0) else 0.0
+ if (rlist$notok != 0) stop("error in 'cum8sum'")
+ ans = if (log.p) log(rlist$answer) else rlist$answer
+ if (specialCase)
+ ans[owen1965] = if (log.p) log(bigans) else bigans
+ ans[q < 1] = if (log.p) log(0.0) else 0.0
ans
}
@@ -5162,29 +5172,29 @@ plog = function(q, prob, log.p=FALSE) {
-if(FALSE)
+ if (FALSE)
plog = function(q, prob, log.p=FALSE) {
- if(!is.Numeric(q)) stop("bad input for argument 'q'")
- if(!is.Numeric(prob, posit=TRUE) || max(prob) >= 1)
+ if (!is.Numeric(q)) stop("bad input for argument 'q'")
+ if (!is.Numeric(prob, posit=TRUE) || max(prob) >= 1)
stop("bad input for argument 'prob'")
N = max(length(q), length(prob))
q = rep(q, len=N); prob = rep(prob, len=N);
ans = q * 0 # Retains names(q)
- if(max(abs(prob-prob[1])) < 1.0e-08) {
+ if (max(abs(prob-prob[1])) < 1.0e-08) {
qstar = floor(q)
- temp = if(max(qstar) >= 1) dlog(x=1:max(qstar),
+ temp = if (max(qstar) >= 1) dlog(x=1:max(qstar),
prob=prob[1]) else 0*qstar
unq = unique(qstar)
for(ii in unq) {
index = qstar == ii
- ans[index] = if(ii >= 1) sum(temp[1:ii]) else 0
+ ans[index] = if (ii >= 1) sum(temp[1:ii]) else 0
}
} else
for(ii in 1:N) {
qstar = floor(q[ii])
- ans[ii] = if(qstar >= 1) sum(dlog(x=1:qstar, prob=prob[ii])) else 0
+ ans[ii] = if (qstar >= 1) sum(dlog(x=1:qstar, prob=prob[ii])) else 0
}
- if(log.p) log(ans) else ans
+ if (log.p) log(ans) else ans
}
@@ -5194,11 +5204,11 @@ plog = function(q, prob, log.p=FALSE) {
rlog = function(n, prob, Smallno=1.0e-6) {
- if(!is.Numeric(n, posit=TRUE, integ=TRUE))
+ if (!is.Numeric(n, posit=TRUE, integ=TRUE))
stop("bad input for argument 'n'")
- if(!is.Numeric(prob, allow=1, posit=TRUE) || max(prob) >= 1)
+ if (!is.Numeric(prob, allow=1, posit=TRUE) || max(prob) >= 1)
stop("bad input for argument 'prob'")
- if(!is.Numeric(Smallno, posit=TRUE, allow=1) || Smallno > 0.01 ||
+ if (!is.Numeric(Smallno, posit=TRUE, allow=1) || Smallno > 0.01 ||
Smallno < 2 * .Machine$double.eps)
stop("bad input for argument 'Smallno'")
ans = rep(0.0, len=n)
@@ -5217,7 +5227,7 @@ rlog = function(n, prob, Smallno=1.0e-6) {
x = round(runif(2*n, min=Lower, max=Upper))
index = runif(2*n, max=ymax) < dlog(x,prob)
sindex = sum(index)
- if(sindex) {
+ if (sindex) {
ptr2 = min(n, ptr1 + sindex - 1)
ans[ptr1:ptr2] = (x[index])[1:(1+ptr2-ptr1)]
ptr1 = ptr2 + 1
@@ -5235,28 +5245,28 @@ rlog = function(n, prob, Smallno=1.0e-6) {
logff = function(link="logit", earg=list(), init.c=NULL)
{
- if(length(init.c) &&
+ if (length(init.c) &&
(!is.Numeric(init.c, posit=TRUE) || max(init.c) >= 1))
stop("init.c must be in (0,1)")
- if(mode(link) != "character" && mode(link) != "name")
+ if (mode(link) != "character" && mode(link) != "name")
link = as.character(substitute(link))
- if(!is.list(earg)) earg = list()
+ if (!is.list(earg)) earg = list()
new("vglmff",
- blurb=c("Logarithmic distribution f(y) = a * c^y / y, y=1,2,3,...,\n",
+ 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)
+ 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)) {
+ 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
+ c.init = if (length( .init.c )) .init.c else
getInitVals(gvals=seq(0.05, 0.95, len=9), llfun=llfun, y=y, w=w)
c.init = rep(c.init, length=length(y))
etastart = theta2eta(c.init, .link, earg= .earg)
@@ -5267,7 +5277,7 @@ rlog = function(n, prob, Smallno=1.0e-6) {
a = -1 / log1p(-cc)
a * cc / (1-cc)
}, list( .link=link, .earg=earg ))),
- last=eval(substitute(expression({
+ last = eval(substitute(expression({
misc$link = c(c= .link)
misc$earg = list(c= .earg)
misc$expected = TRUE
@@ -5276,7 +5286,7 @@ rlog = function(n, prob, Smallno=1.0e-6) {
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 {
+ 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 ))),
@@ -5306,47 +5316,47 @@ rlog = function(n, prob, Smallno=1.0e-6) {
delta.known = is.Numeric(delta, allow=1)
- if(mode(link.gamma) != "character" && mode(link.gamma) != "name")
+ if (mode(link.gamma) != "character" && mode(link.gamma) != "name")
link.gamma = as.character(substitute(link.gamma))
- if(!is.list(earg)) earg = list()
+ if (!is.list(earg)) earg = list()
new("vglmff",
- blurb=c("Levy distribution f(y) = sqrt(gamma/(2*pi)) * ",
+ blurb = c("Levy distribution f(y) = sqrt(gamma/(2*pi)) * ",
"(y-delta)^(-3/2) * \n",
" exp(-gamma / (2*(y-delta ))),\n",
" delta < y, gamma > 0",
- if(delta.known) paste(", delta = ", delta, ",", sep=""),
+ if (delta.known) paste(", delta = ", delta, ",", sep=""),
"\n\n",
- if(delta.known) "Link: " else "Links: ",
+ if (delta.known) "Link: " else "Links: ",
namesof("gamma", link.gamma, earg=earg),
- if(! delta.known)
+ if (! delta.known)
c(", ", namesof("delta", "identity", earg=list())),
"\n\n",
"Mean: NA",
"\n"),
initialize=eval(substitute(expression({
- if(ncol(cbind(y)) != 1)
+ if (ncol(cbind(y)) != 1)
stop("response must be a vector or a one-column matrix")
predictors.names =
c(namesof("gamma", .link.gamma, earg=.earg, tag=FALSE),
- if( .delta.known) NULL else
+ if ( .delta.known) NULL else
namesof("delta", "identity", earg=list(), tag=FALSE))
- if(!length(etastart)) {
- delta.init = if( .delta.known) {
- if(min(y,na.rm= TRUE) <= .delta)
+ if (!length(etastart)) {
+ delta.init = if ( .delta.known) {
+ if (min(y,na.rm= TRUE) <= .delta)
stop("delta must be < min(y)")
.delta
} else {
- if(length( .idelta)) .idelta else
+ if (length( .idelta)) .idelta else
min(y,na.rm= TRUE) - 1.0e-4 *
diff(range(y,na.rm= TRUE))
}
- gamma.init = if(length( .igamma)) .igamma else
+ 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),
- if( .delta.known) NULL else delta.init)
+ if ( .delta.known) NULL else delta.init)
}
}), list( .link.gamma=link.gamma, .earg=earg,
@@ -5357,19 +5367,19 @@ rlog = function(n, prob, Smallno=1.0e-6) {
inverse=eval(substitute(function(eta, extra=NULL) {
eta = as.matrix(eta)
mygamma = eta2theta(eta[,1], .link.gamma, earg= .earg)
- delta = if( .delta.known) .delta else eta[,2]
+ delta = if ( .delta.known) .delta else eta[,2]
NA * mygamma
}, list( .link.gamma=link.gamma, .earg=earg,
.delta.known=delta.known,
.delta=delta ))),
- last=eval(substitute(expression({
- misc$link = if( .delta.known) NULL else c(delta="identity")
+ 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)
+ if ( .delta.known)
misc$delta = .delta
}), list( .link.gamma=link.gamma, .earg=earg,
.delta.known=delta.known,
@@ -5378,8 +5388,8 @@ rlog = function(n, prob, Smallno=1.0e-6) {
function(mu,y,w,residuals= FALSE,eta, extra=NULL) {
eta = as.matrix(eta)
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
+ delta = if ( .delta.known) .delta else eta[,2]
+ if (residuals) stop("loglikelihood residuals not implemented yet") else
sum(w * 0.5 * (log(mygamma) -3*log(y-delta) - mygamma / (y-delta )))
}, list( .link.gamma=link.gamma, .earg = earg,
.delta.known=delta.known,
@@ -5388,20 +5398,20 @@ rlog = function(n, prob, Smallno=1.0e-6) {
deriv=eval(substitute(expression({
eta = as.matrix(eta)
mygamma = eta2theta(eta[,1], .link.gamma, earg= .earg)
- delta = if( .delta.known) .delta else eta[,2]
- if(! .delta.known)
+ 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)
w * cbind(dl.dgamma * dgamma.deta,
- if( .delta.known) NULL else dl.ddelta)
+ if ( .delta.known) NULL else dl.ddelta)
}), list( .link.gamma=link.gamma, .earg=earg,
.delta.known=delta.known,
.delta=delta ))),
weight=eval(substitute(expression({
- wz = matrix(as.numeric(NA), n, dimm(M)) # M = if(delta is known) 1 else 2
+ wz = matrix(as.numeric(NA), n, dimm(M)) # M = if (delta is known) 1 else 2
wz[,iam(1,1,M)] = 1 * dgamma.deta^2
- if(! .delta.known) {
+ if (! .delta.known) {
wz[,iam(1,2,M)] = 3 * dgamma.deta
wz[,iam(2,2,M)] = 21
}
@@ -5415,7 +5425,7 @@ rlog = function(n, prob, Smallno=1.0e-6) {
-if(FALSE)
+ if (FALSE)
stoppa = function(y0,
link.alpha="loge",
link.theta="loge", ealpha=list(), etheta=list(),
@@ -5423,20 +5433,20 @@ if(FALSE)
itheta=1.0,
zero=NULL)
{
- if(!is.Numeric(y0, allo=1) || y0 <= 0)
+ if (!is.Numeric(y0, allo=1) || y0 <= 0)
stop("y0 must be a positive value")
- if(mode(link.alpha) != "character" && mode(link.alpha) != "name")
+ if (mode(link.alpha) != "character" && mode(link.alpha) != "name")
link.alpha = as.character(substitute(link.alpha))
- if(mode(link.theta) != "character" && mode(link.theta) != "name")
+ if (mode(link.theta) != "character" && mode(link.theta) != "name")
link.theta = as.character(substitute(link.theta))
- if(length(zero) && !is.Numeric(zero, integer=TRUE, posit=TRUE))
+ if (length(zero) && !is.Numeric(zero, integer=TRUE, posit=TRUE))
stop("bad input for argument 'zero'")
- if(!is.list(ealpha)) ealpha = list()
- if(!is.list(etheta)) etheta = list()
+ if (!is.list(ealpha)) ealpha = list()
+ if (!is.list(etheta)) etheta = list()
new("vglmff",
- blurb=c("Stoppa distribution\n\n",
+ blurb = c("Stoppa distribution\n\n",
"Links: ",
namesof("alpha", link.alpha, earg=ealpha), ", ",
namesof("theta", link.theta, earg=etheta), "\n",
@@ -5450,16 +5460,16 @@ if(FALSE)
namesof("theta", .link.theta, earg=.etheta, tag=FALSE))
y0 = .y0
- if(min(y) < y0) stop("y0 must lie in the interval (0, min(y))")
- if(!length( .ialpha) || !length( .itheta)) {
+ if (min(y) < y0) stop("y0 must lie in the interval (0, min(y))")
+ if (!length( .ialpha) || !length( .itheta)) {
qvec = c(.25, .5, .75) # Arbitrary; could be made an argument
- init.theta = if(length( .itheta)) .itheta else 1
+ init.theta = if (length( .itheta)) .itheta else 1
xvec = log1p(-qvec^(1/init.theta))
fit0 = lsfit(x=xvec, y=log(quantile(y, qvec))-log(y0), intercept=FALSE)
}
extra$y0 = y0
- if(!length(etastart)) {
+ if (!length(etastart)) {
alpha = rep(if(length( .ialpha)) .ialpha else -1/fit0$coef[1], length=n)
theta = rep(if(length( .itheta)) .itheta else 1.0, length=n)
etastart = cbind(theta2eta(alpha, .link.alpha, earg= .ealpha),
@@ -5473,14 +5483,14 @@ if(FALSE)
theta = eta2theta(eta[,2], .link.theta, earg= .etheta)
theta * extra$y0 * beta(1-1/alpha, theta)
}, list( .link.theta=link.theta, .link.alpha=link.alpha ))),
- last=eval(substitute(expression({
+ last = eval(substitute(expression({
misc$link = c(alpha= .link.alpha, theta= .link.theta)
}), list( .link.theta=link.theta, .link.alpha=link.alpha ))),
loglikelihood=eval(substitute(
function(mu, y, w, residuals= FALSE,eta, extra=NULL) {
alpha = eta2theta(eta[,1], .link.alpha, earg= .ealpha)
theta = eta2theta(eta[,2], .link.theta, earg= .etheta)
- if(residuals) stop("loglikelihood residuals not implemented yet") else
+ if (residuals) stop("loglikelihood residuals not implemented yet") else
sum(w*(log(theta*alpha) + alpha*log(extra$y0) -(alpha+1)*log(y)+
(theta-1) * log1p(-(y/extra$y0)^(-alpha))))
}, list( .link.theta=link.theta, .link.alpha=link.alpha ))),
@@ -5518,33 +5528,33 @@ if(FALSE)
dlino = function(x, shape1, shape2, lambda=1, log = FALSE) {
- if(!is.logical(log.arg <- log))
+ if (!is.logical(log.arg <- log))
stop("bad input for argument 'log'")
rm(log)
loglik = dbeta(x=x, shape1=shape1, shape2=shape2, log=TRUE) +
shape1 * log(lambda) -
(shape1+shape2) * log1p(-(1-lambda)*x)
- if(log.arg) loglik else exp(loglik)
+ if (log.arg) loglik else exp(loglik)
}
plino = function(q, shape1, shape2, lambda=1) {
- if(!is.Numeric(q)) stop("bad input for 'q'")
- if(!is.Numeric(shape1, posit=TRUE))
+ if (!is.Numeric(q)) stop("bad input for 'q'")
+ if (!is.Numeric(shape1, posit=TRUE))
stop("bad input for argument 'shape1'")
- if(!is.Numeric(shape2, posit=TRUE))
+ if (!is.Numeric(shape2, posit=TRUE))
stop("bad input for argument 'shape2'")
- if(!is.Numeric(lambda, posit=TRUE))
+ if (!is.Numeric(lambda, posit=TRUE))
stop("bad input for argument 'lambda'")
pbeta(q=lambda*q/(1 - (1-lambda)*q), shape1=shape1, shape2=shape2)
}
qlino = function(p, shape1, shape2, lambda=1) {
- if(!is.Numeric(p, posit=TRUE) || any(p >= 1))
+ if (!is.Numeric(p, posit=TRUE) || any(p >= 1))
stop("bad input for argument 'p'")
- if(!is.Numeric(shape1, posit=TRUE))
+ if (!is.Numeric(shape1, posit=TRUE))
stop("bad input for argument 'shape1'")
- if(!is.Numeric(lambda, posit=TRUE))
+ if (!is.Numeric(lambda, posit=TRUE))
stop("bad input for argument 'lambda'")
Y = qbeta(p=p, shape1=shape1, shape2=shape2)
Y / (lambda + (1-lambda)*Y)
@@ -5552,13 +5562,13 @@ qlino = function(p, shape1, shape2, lambda=1) {
rlino = function(n, shape1, shape2, lambda=1) {
- if(!is.Numeric(n, posit=TRUE, integ=TRUE, allow=1))
+ if (!is.Numeric(n, posit=TRUE, integ=TRUE, allow=1))
stop("bad input for argument 'n'")
- if(!is.Numeric(shape1, posit=TRUE))
+ if (!is.Numeric(shape1, posit=TRUE))
stop("bad input for argument 'shape1'")
- if(!is.Numeric(shape2, posit=TRUE))
+ if (!is.Numeric(shape2, posit=TRUE))
stop("bad input for argument 'shape2'")
- if(!is.Numeric(lambda, posit=TRUE))
+ if (!is.Numeric(lambda, posit=TRUE))
stop("bad input for argument 'lambda'")
Y = rbeta(n=n, shape1=shape1, shape2=shape2)
Y / (lambda + (1-lambda)*Y)
@@ -5572,22 +5582,22 @@ rlino = function(n, shape1, shape2, lambda=1) {
eshape1=list(), eshape2=list(), elambda=list(),
ishape1=NULL, ishape2=NULL, ilambda=1, zero=NULL)
{
- if(mode(lshape1) != "character" && mode(lshape1) != "name")
+ if (mode(lshape1) != "character" && mode(lshape1) != "name")
lshape1 = as.character(substitute(lshape1))
- if(mode(lshape2) != "character" && mode(lshape2) != "name")
+ if (mode(lshape2) != "character" && mode(lshape2) != "name")
lshape2 = as.character(substitute(lshape2))
- if(mode(llambda) != "character" && mode(llambda) != "name")
+ if (mode(llambda) != "character" && mode(llambda) != "name")
llambda = as.character(substitute(llambda))
- if(length(zero) && !is.Numeric(zero, integer=TRUE, posit=TRUE))
+ if (length(zero) && !is.Numeric(zero, integer=TRUE, posit=TRUE))
stop("bad input for argument 'zero'")
- if(!is.Numeric(ilambda, positive=TRUE))
+ if (!is.Numeric(ilambda, positive=TRUE))
stop("bad input for argument 'ilambda'")
- if(!is.list(eshape1)) eshape1 = list()
- if(!is.list(eshape2)) eshape2 = list()
- if(!is.list(elambda)) elambda = list()
+ if (!is.list(eshape1)) eshape1 = list()
+ if (!is.list(eshape2)) eshape2 = list()
+ if (!is.list(elambda)) elambda = list()
new("vglmff",
- blurb=c("Generalized Beta distribution (Libby and Novick, 1982)\n\n",
+ blurb = c("Generalized Beta distribution (Libby and Novick, 1982)\n\n",
"Links: ",
namesof("shape1", lshape1, earg=eshape1), ", ",
namesof("shape2", lshape2, earg=eshape2), ", ",
@@ -5601,20 +5611,20 @@ rlino = function(n, shape1, shape2, lambda=1) {
c(namesof("shape1", .lshape1, earg=.eshape1, tag=FALSE),
namesof("shape2", .lshape2, earg=.eshape2, tag=FALSE),
namesof("lambda", .llambda, earg=.elambda, tag=FALSE))
- if(min(y) <= 0 || max(y) >= 1)
+ if (min(y) <= 0 || max(y) >= 1)
stop("values of the response must be between 0 and 1 (0,1)")
- if(ncol(cbind(y)) != 1)
+ if (ncol(cbind(y)) != 1)
stop("response must be a vector or a one-column matrix")
- if(!length(etastart)) {
+ if (!length(etastart)) {
lambda.init = rep(if(length( .ilambda )) .ilambda else 1, length=n)
- sh1.init = if(length( .ishape1 )) rep( .ishape1, length=n) else NULL
- sh2.init = if(length( .ishape2 )) rep( .ishape2, length=n) else NULL
+ sh1.init = if (length( .ishape1 )) rep( .ishape1, length=n) else NULL
+ sh2.init = if (length( .ishape2 )) rep( .ishape2, length=n) else NULL
txY.init = lambda.init * y / (1+lambda.init*y - y)
mean1 = mean(txY.init)
mean2 = mean(1/txY.init)
- if(!is.Numeric(sh1.init))
+ if (!is.Numeric(sh1.init))
sh1.init = rep((mean2 - 1) / (mean2 - 1/mean1), length=n)
- if(!is.Numeric(sh2.init))
+ if (!is.Numeric(sh2.init))
sh2.init = rep(sh1.init * (1-mean1) / mean1, length=n)
etastart = cbind(theta2eta(sh1.init, .lshape1, earg= .eshape1),
theta2eta(sh2.init, .lshape2, earg= .eshape2),
@@ -5630,7 +5640,7 @@ rlino = function(n, shape1, shape2, lambda=1) {
rep(as.numeric(NA), length=nrow(eta))
}, list( .lshape1=lshape1, .lshape2=lshape2, .llambda=llambda,
.eshape1=eshape1, .eshape2=eshape2, .elambda=elambda ))),
- last=eval(substitute(expression({
+ last = eval(substitute(expression({
misc$link = c(shape1 = .lshape1, shape2 = .lshape2, lambda = .llambda)
misc$earg =list(shape1 = .eshape1, shape2 = .eshape2, lambda = .elambda)
}), list( .lshape1=lshape1, .lshape2=lshape2, .llambda=llambda,
@@ -5640,7 +5650,7 @@ rlino = function(n, shape1, shape2, lambda=1) {
sh1 = eta2theta(eta[,1], .lshape1, earg= .eshape1)
sh2 = eta2theta(eta[,2], .lshape2, earg= .eshape2)
lambda = eta2theta(eta[,3], .llambda, earg= .elambda)
- if(residuals) stop("loglikelihood residuals not implemented yet") else {
+ if (residuals) stop("loglikelihood residuals not implemented yet") else {
sum(w * dlino(y, shape1=sh1, shape2=sh2, lambda=lambda, log=TRUE))
}
}, list( .lshape1=lshape1, .lshape2=lshape2, .llambda=llambda,
@@ -5698,23 +5708,23 @@ rlino = function(n, shape1, shape2, lambda=1) {
zero=NULL)
{
- if(mode(link.a) != "character" && mode(link.a) != "name")
+ if (mode(link.a) != "character" && mode(link.a) != "name")
link.a = as.character(substitute(link.a))
- if(mode(link.scale) != "character" && mode(link.scale) != "name")
+ if (mode(link.scale) != "character" && mode(link.scale) != "name")
link.scale = as.character(substitute(link.scale))
- if(mode(link.p) != "character" && mode(link.p) != "name")
+ if (mode(link.p) != "character" && mode(link.p) != "name")
link.p = as.character(substitute(link.p))
- if(mode(link.q) != "character" && mode(link.q) != "name")
+ if (mode(link.q) != "character" && mode(link.q) != "name")
link.q = as.character(substitute(link.q))
- if(length(zero) && !is.Numeric(zero, integer=TRUE, posit=TRUE))
+ if (length(zero) && !is.Numeric(zero, integer=TRUE, posit=TRUE))
stop("bad input for argument 'zero'")
- if(!is.list(earg.a)) earg.a = list()
- if(!is.list(earg.scale)) earg.scale = list()
- if(!is.list(earg.p)) earg.p = list()
- if(!is.list(earg.q)) earg.q = list()
+ if (!is.list(earg.a)) earg.a = list()
+ if (!is.list(earg.scale)) earg.scale = list()
+ if (!is.list(earg.p)) earg.p = list()
+ if (!is.list(earg.q)) earg.q = list()
new("vglmff",
- blurb=c("Generalized Beta II distribution\n\n",
+ blurb = c("Generalized Beta II distribution\n\n",
"Links: ",
namesof("a", link.a, earg=earg.a), ", ",
namesof("scale", link.scale, earg=earg.scale), ", ",
@@ -5731,14 +5741,14 @@ rlino = function(n, shape1, shape2, lambda=1) {
namesof("p", .link.p, earg=.earg.p, tag=FALSE),
namesof("q", .link.q, earg=.earg.q, tag=FALSE))
- if(!length(.init.a) || !length(.init.scale)) {
+ if (!length(.init.a) || !length(.init.scale)) {
qvec = c(.25, .5, .75) # Arbitrary; could be made an argument
- init.q = if(length(.init.q)) .init.q else 1
+ init.q = if (length(.init.q)) .init.q else 1
xvec = log( (1-qvec)^(-1/ init.q ) - 1 )
fit0 = lsfit(x=xvec, y=log(quantile(y, qvec )))
}
- if(!length(etastart)) {
+ if (!length(etastart)) {
aa = rep(if(length(.init.a)) .init.a else 1/fit0$coef[2], length=n)
scale = rep(if(length(.init.scale)) .init.scale else
exp(fit0$coef[1]), length=n)
@@ -5765,7 +5775,7 @@ rlino = function(n, shape1, shape2, lambda=1) {
.earg.a=earg.a, .earg.scale=earg.scale,
.earg.p=earg.p, .earg.q=earg.q,
.link.p=link.p, .link.q=link.q ))),
- last=eval(substitute(expression({
+ last = eval(substitute(expression({
misc$link = c(a= .link.a, scale= .link.scale,
p= .link.p, q= .link.q)
misc$earg = list(a= .earg.a, scale= .earg.scale,
@@ -5780,7 +5790,7 @@ rlino = function(n, shape1, shape2, lambda=1) {
scale = eta2theta(eta[,2], .link.scale, earg= .earg.scale)
parg = eta2theta(eta[,3], .link.p, earg= .earg.p)
qq = eta2theta(eta[,4], .link.q, earg= .earg.q)
- if(residuals) stop("loglikelihood residuals not implemented yet") else {
+ if (residuals) stop("loglikelihood residuals not implemented yet") else {
sum(w*(log(aa) + (aa*parg-1)*log(y) - aa*parg*log(scale) +
-lbeta(parg, qq) - (parg+qq)*log1p((y/scale)^aa)))
}
@@ -5961,7 +5971,7 @@ pinvparalogistic = function(q, a, scale=1)
dsinmad = function(x, a, scale=1, q.arg, log=FALSE) {
- if(!is.logical(log.arg <- log))
+ if (!is.logical(log.arg <- log))
stop("bad input for argument 'log'")
rm(log)
LLL = max(length(x), length(a), length(scale), length(q.arg))
@@ -5973,7 +5983,7 @@ dsinmad = function(x, a, scale=1, q.arg, log=FALSE) {
Loglik[xok] = log(a[xok]) + log(q.arg[xok]) + (a[xok]-1)*log(x[xok]) -
a[xok]*log(scale[xok]) -
(1+q.arg[xok]) * log1p((x[xok]/scale[xok])^a[xok])
- if(log.arg) Loglik else exp(Loglik)
+ if (log.arg) Loglik else exp(Loglik)
}
dlomax = function(x, scale=1, q.arg, log=FALSE)
@@ -5988,7 +5998,7 @@ dparalogistic = function(x, a, scale=1, log=FALSE)
ddagum = function(x, a, scale=1, p.arg, log=FALSE) {
- if(!is.logical(log.arg <- log))
+ if (!is.logical(log.arg <- log))
stop("bad input for argument 'log'")
rm(log)
@@ -6003,7 +6013,7 @@ ddagum = function(x, a, scale=1, p.arg, log=FALSE) {
a[xok]*p.arg[xok]*log(scale[xok]) -
(1+p.arg[xok]) * log1p((x[xok]/scale[xok])^a[xok])
Loglik[p.arg <= 0] = NaN
- if(log.arg) Loglik else exp(Loglik)
+ if (log.arg) Loglik else exp(Loglik)
}
@@ -6025,20 +6035,20 @@ dinvparalogistic = function(x, a, scale=1, log=FALSE)
zero=NULL)
{
- if(mode(link.a) != "character" && mode(link.a) != "name")
+ if (mode(link.a) != "character" && mode(link.a) != "name")
link.a = as.character(substitute(link.a))
- if(mode(link.scale) != "character" && mode(link.scale) != "name")
+ if (mode(link.scale) != "character" && mode(link.scale) != "name")
link.scale = as.character(substitute(link.scale))
- if(mode(link.q) != "character" && mode(link.q) != "name")
+ if (mode(link.q) != "character" && mode(link.q) != "name")
link.q = as.character(substitute(link.q))
- if(length(zero) && !is.Numeric(zero, integer=TRUE, posit=TRUE))
+ if (length(zero) && !is.Numeric(zero, integer=TRUE, posit=TRUE))
stop("bad input for argument 'zero'")
- if(!is.list(earg.a)) earg.a = list()
- if(!is.list(earg.scale)) earg.scale = list()
- if(!is.list(earg.q)) earg.q = list()
+ if (!is.list(earg.a)) earg.a = list()
+ if (!is.list(earg.scale)) earg.scale = list()
+ if (!is.list(earg.q)) earg.q = list()
new("vglmff",
- blurb=c("Singh-Maddala distribution\n\n",
+ blurb = c("Singh-Maddala distribution\n\n",
"Links: ",
namesof("a", link.a, earg=earg.a), ", ",
namesof("scale", link.scale, earg=earg.scale), ", ",
@@ -6048,7 +6058,7 @@ dinvparalogistic = function(x, a, scale=1, log=FALSE)
constraints = cm.zero.vgam(constraints, x, .zero, M)
}), list( .zero=zero ))),
initialize=eval(substitute(expression({
- if(ncol(cbind(y)) != 1)
+ if (ncol(cbind(y)) != 1)
stop("response must be a vector or a one-column matrix")
predictors.names =
c(namesof("a", .link.a, earg=.earg.a, tag=FALSE),
@@ -6056,14 +6066,14 @@ dinvparalogistic = function(x, a, scale=1, log=FALSE)
namesof("q", .link.q, earg=.earg.q, tag=FALSE))
parg = 1
- if(!length(.init.a) || !length(.init.scale)) {
+ if (!length(.init.a) || !length(.init.scale)) {
qvec = c(.25, .5, .75) # Arbitrary; could be made an argument
- init.q = if(length(.init.q)) .init.q else 1
+ init.q = if (length(.init.q)) .init.q else 1
xvec = log( (1-qvec)^(-1/ init.q ) - 1 )
fit0 = lsfit(x=xvec, y=log(quantile(y, qvec )))
}
- if(!length(etastart)) {
+ if (!length(etastart)) {
aa = rep(if(length(.init.a)) .init.a else 1/fit0$coef[2], length=n)
scale = rep(if(length(.init.scale)) .init.scale else
exp(fit0$coef[1]), length=n)
@@ -6087,7 +6097,7 @@ dinvparalogistic = function(x, a, scale=1, log=FALSE)
.earg.a=earg.a, .earg.scale=earg.scale,
.earg.q=earg.q,
.link.q=link.q ))),
- last=eval(substitute(expression({
+ last = eval(substitute(expression({
misc$link = c(a= .link.a, scale= .link.scale, q= .link.q)
misc$earg = list(a= .earg.a, scale= .earg.scale, q= .earg.q)
}), list( .link.a=link.a, .link.scale=link.scale,
@@ -6100,7 +6110,7 @@ dinvparalogistic = function(x, a, scale=1, log=FALSE)
scale = eta2theta(eta[,2], .link.scale, earg= .earg.scale)
parg = 1
qq = eta2theta(eta[,3], .link.q, earg= .earg)
- if(residuals) stop("loglikelihood residuals not implemented yet") else {
+ if (residuals) stop("loglikelihood residuals not implemented yet") else {
sum(w * dsinmad(x=y, a=aa, scale=scale, q.arg=qq, log=TRUE))
}
}, list( .link.a=link.a, .link.scale=link.scale, .link.q=link.q,
@@ -6165,20 +6175,20 @@ dinvparalogistic = function(x, a, scale=1, log=FALSE)
zero=NULL)
{
- if(mode(link.a) != "character" && mode(link.a) != "name")
+ if (mode(link.a) != "character" && mode(link.a) != "name")
link.a = as.character(substitute(link.a))
- if(mode(link.scale) != "character" && mode(link.scale) != "name")
+ if (mode(link.scale) != "character" && mode(link.scale) != "name")
link.scale = as.character(substitute(link.scale))
- if(mode(link.p) != "character" && mode(link.p) != "name")
+ if (mode(link.p) != "character" && mode(link.p) != "name")
link.p = as.character(substitute(link.p))
- if(length(zero) && !is.Numeric(zero, integer=TRUE, posit=TRUE))
+ if (length(zero) && !is.Numeric(zero, integer=TRUE, posit=TRUE))
stop("bad input for argument 'zero'")
- if(!is.list(earg.a)) earg.a = list()
- if(!is.list(earg.scale)) earg.scale = list()
- if(!is.list(earg.p)) earg.p = list()
+ if (!is.list(earg.a)) earg.a = list()
+ if (!is.list(earg.scale)) earg.scale = list()
+ if (!is.list(earg.p)) earg.p = list()
new("vglmff",
- blurb=c("Dagum distribution\n\n",
+ blurb = c("Dagum distribution\n\n",
"Links: ",
namesof("a", link.a, earg=earg.a), ", ",
namesof("scale", link.scale, earg=earg.scale), ", ",
@@ -6188,21 +6198,21 @@ dinvparalogistic = function(x, a, scale=1, log=FALSE)
constraints = cm.zero.vgam(constraints, x, .zero, M)
}), list( .zero=zero ))),
initialize=eval(substitute(expression({
- if(ncol(cbind(y)) != 1)
+ if (ncol(cbind(y)) != 1)
stop("response must be a vector or a one-column matrix")
predictors.names =
c(namesof("a", .link.a, earg=.earg.a, tag=FALSE),
namesof("scale", .link.scale, earg=.earg.scale, tag=FALSE),
namesof("p", .link.p, earg=.earg.p, tag=FALSE))
- if(!length(.init.a) || !length(.init.scale)) {
+ if (!length(.init.a) || !length(.init.scale)) {
qvec = c(.25, .5, .75) # Arbitrary; could be made an argument
- init.p = if(length(.init.p)) .init.p else 1
+ init.p = if (length(.init.p)) .init.p else 1
xvec = log( qvec^(-1/ init.p ) - 1 )
fit0 = lsfit(x=xvec, y=log(quantile(y, qvec )))
}
- if(!length(etastart)) {
+ if (!length(etastart)) {
parg = rep(if(length(.init.p)) .init.p else 1.0, length=n)
aa = rep(if(length(.init.a)) .init.a else -1/fit0$coef[2], length=n)
scale = rep(if(length(.init.scale)) .init.scale else
@@ -6227,7 +6237,7 @@ dinvparalogistic = function(x, a, scale=1, log=FALSE)
.earg.a=earg.a, .earg.scale=earg.scale,
.earg.p=earg.p,
.link.p=link.p ))),
- last=eval(substitute(expression({
+ last = eval(substitute(expression({
misc$link = c(a= .link.a, scale= .link.scale, p= .link.p )
misc$earg = list(a= .earg.a, scale= .earg.scale, p= .earg.p)
}), list( .link.a=link.a, .link.scale=link.scale,
@@ -6240,7 +6250,7 @@ dinvparalogistic = function(x, a, scale=1, log=FALSE)
scale = eta2theta(eta[,2], .link.scale, earg= .earg.scale)
parg = eta2theta(eta[,3], .link.p, earg= .earg.p)
qq = 1
- if(residuals) stop("loglikelihood residuals not implemented yet") else {
+ if (residuals) stop("loglikelihood residuals not implemented yet") else {
sum(w * ddagum(x=y, a=aa, scale=scale, p.arg=parg, log=TRUE))
}
}, list( .link.a=link.a, .link.scale=link.scale, .link.p=link.p,
@@ -6301,20 +6311,20 @@ dinvparalogistic = function(x, a, scale=1, log=FALSE)
init.scale=NULL, init.p=1.0, init.q=1.0, zero=NULL)
{
- if(mode(link.scale) != "character" && mode(link.scale) != "name")
+ if (mode(link.scale) != "character" && mode(link.scale) != "name")
link.scale = as.character(substitute(link.scale))
- if(mode(link.p) != "character" && mode(link.p) != "name")
+ if (mode(link.p) != "character" && mode(link.p) != "name")
link.p = as.character(substitute(link.p))
- if(mode(link.q) != "character" && mode(link.q) != "name")
+ if (mode(link.q) != "character" && mode(link.q) != "name")
link.q = as.character(substitute(link.q))
- if(length(zero) && !is.Numeric(zero, integer=TRUE, posit=TRUE))
+ if (length(zero) && !is.Numeric(zero, integer=TRUE, posit=TRUE))
stop("bad input for argument 'zero'")
- if(!is.list(earg.scale)) earg.scale = list()
- if(!is.list(earg.p)) earg.p = list()
- if(!is.list(earg.q)) earg.q = list()
+ if (!is.list(earg.scale)) earg.scale = list()
+ if (!is.list(earg.p)) earg.p = list()
+ if (!is.list(earg.q)) earg.q = list()
new("vglmff",
- blurb=c("Beta II distribution\n\n",
+ blurb = c("Beta II distribution\n\n",
"Links: ",
namesof("scale", link.scale, earg=earg.scale), ", ",
namesof("p", link.p, earg=earg.p), ", ",
@@ -6324,21 +6334,21 @@ dinvparalogistic = function(x, a, scale=1, log=FALSE)
constraints = cm.zero.vgam(constraints, x, .zero, M)
}), list( .zero=zero ))),
initialize=eval(substitute(expression({
- if(ncol(cbind(y)) != 1)
+ if (ncol(cbind(y)) != 1)
stop("response must be a vector or a one-column matrix")
predictors.names =
c(namesof("scale", .link.scale, earg=.earg.scale, tag=FALSE),
namesof("p", .link.p, earg=.earg.p, tag=FALSE),
namesof("q", .link.q, earg=.earg.q, tag=FALSE))
- if(!length(.init.scale)) {
+ if (!length(.init.scale)) {
qvec = c(.25, .5, .75) # Arbitrary; could be made an argument
- init.q = if(length(.init.q)) .init.q else 1
+ init.q = if (length(.init.q)) .init.q else 1
xvec = log( (1-qvec)^(-1/ init.q ) - 1 )
fit0 = lsfit(x=xvec, y=log(quantile(y, qvec )))
}
- if(!length(etastart)) {
+ if (!length(etastart)) {
scale = rep(if(length(.init.scale)) .init.scale else
exp(fit0$coef[1]), length=n)
qq = rep(if(length(.init.q)) .init.q else 1.0, length=n)
@@ -6363,7 +6373,7 @@ dinvparalogistic = function(x, a, scale=1, log=FALSE)
.earg.scale=earg.scale,
.earg.p=earg.p, .earg.q=earg.q,
.link.p=link.p, .link.q=link.q ))),
- last=eval(substitute(expression({
+ last = eval(substitute(expression({
misc$link = c(scale= .link.scale, p= .link.p, q= .link.q)
misc$earg = list(scale= .earg.scale, p= .earg.p, q= .earg.q)
}), list( .link.scale=link.scale,
@@ -6376,7 +6386,7 @@ dinvparalogistic = function(x, a, scale=1, log=FALSE)
scale = eta2theta(eta[,1], .link.scale, earg= .earg.scale)
parg = eta2theta(eta[,2], .link.p, earg= .earg.p)
qq = eta2theta(eta[,3], .link.q, earg= .earg.q)
- if(residuals) stop("loglikelihood residuals not implemented yet") else
+ if (residuals) stop("loglikelihood residuals not implemented yet") else
sum(w*(log(aa) + (aa*parg-1)*log(y) - aa*parg*log(scale) +
(-lbeta(parg, qq)) - (parg+qq)*log1p((y/scale)^aa)))
}, list( .link.scale=link.scale,
@@ -6442,17 +6452,17 @@ dinvparalogistic = function(x, a, scale=1, log=FALSE)
zero=NULL)
{
- if(mode(link.scale) != "character" && mode(link.scale) != "name")
+ if (mode(link.scale) != "character" && mode(link.scale) != "name")
link.scale = as.character(substitute(link.scale))
- if(mode(link.q) != "character" && mode(link.q) != "name")
+ if (mode(link.q) != "character" && mode(link.q) != "name")
link.q = as.character(substitute(link.q))
- if(length(zero) && !is.Numeric(zero, integer=TRUE, posit=TRUE))
+ if (length(zero) && !is.Numeric(zero, integer=TRUE, posit=TRUE))
stop("bad input for argument 'zero'")
- if(!is.list(earg.scale)) earg.scale = list()
- if(!is.list(earg.q)) earg.q = list()
+ if (!is.list(earg.scale)) earg.scale = list()
+ if (!is.list(earg.q)) earg.q = list()
new("vglmff",
- blurb=c("Lomax distribution\n\n",
+ blurb = c("Lomax distribution\n\n",
"Links: ",
namesof("scale", link.scale, earg=earg.scale), ", ",
namesof("q", link.q, earg=earg.q), "\n",
@@ -6461,21 +6471,21 @@ dinvparalogistic = function(x, a, scale=1, log=FALSE)
constraints = cm.zero.vgam(constraints, x, .zero, M)
}), list( .zero=zero ))),
initialize=eval(substitute(expression({
- if(ncol(cbind(y)) != 1)
+ if (ncol(cbind(y)) != 1)
stop("response must be a vector or a one-column matrix")
predictors.names =
c(namesof("scale", .link.scale, earg=.earg.scale, tag=FALSE),
namesof("q", .link.q, earg=.earg.q, tag=FALSE))
aa = parg = 1
- if(!length(.init.scale)) {
+ if (!length(.init.scale)) {
qvec = c(.25, .5, .75) # Arbitrary; could be made an argument
- init.q = if(length(.init.q)) .init.q else 1
+ init.q = if (length(.init.q)) .init.q else 1
xvec = log( (1-qvec)^(-1/ init.q ) - 1 )
fit0 = lsfit(x=xvec, y=log(quantile(y, qvec )))
}
- if(!length(etastart)) {
+ if (!length(etastart)) {
qq = rep(if(length(.init.q)) .init.q else 1.0, length=n)
scale = rep(if(length(.init.scale)) .init.scale else
exp(fit0$coef[1]), length=n)
@@ -6491,7 +6501,7 @@ dinvparalogistic = function(x, a, scale=1, log=FALSE)
scale/(qq-1)
}, list( .link.scale=link.scale, .link.q=link.q,
.earg.scale=earg.scale, .earg.q=earg.q ))),
- last=eval(substitute(expression({
+ last = eval(substitute(expression({
misc$link = c(scale= .link.scale, q= .link.q)
misc$earg = list(scale= .earg.scale, q= .earg.q)
}), list( .link.scale=link.scale, .link.q=link.q,
@@ -6502,7 +6512,7 @@ dinvparalogistic = function(x, a, scale=1, log=FALSE)
scale = eta2theta(eta[,1], .link.scale, earg= .earg.scale)
parg = 1
qq = eta2theta(eta[,2], .link.q, earg= .earg.q)
- if(residuals) stop("loglikelihood residuals not implemented yet") else {
+ if (residuals) stop("loglikelihood residuals not implemented yet") else {
sum(w * dlomax(x=y, scale=scale, q.arg=qq, log=TRUE))
}
}, list( .link.scale=link.scale, .link.q=link.q,
@@ -6546,17 +6556,17 @@ dinvparalogistic = function(x, a, scale=1, log=FALSE)
zero=NULL)
{
- if(mode(link.a) != "character" && mode(link.a) != "name")
+ if (mode(link.a) != "character" && mode(link.a) != "name")
link.a = as.character(substitute(link.a))
- if(mode(link.scale) != "character" && mode(link.scale) != "name")
+ if (mode(link.scale) != "character" && mode(link.scale) != "name")
link.scale = as.character(substitute(link.scale))
- if(length(zero) && !is.Numeric(zero, integer=TRUE, posit=TRUE))
+ if (length(zero) && !is.Numeric(zero, integer=TRUE, posit=TRUE))
stop("bad input for argument 'zero'")
- if(!is.list(earg.a)) earg.a = list()
- if(!is.list(earg.scale)) earg.scale = list()
+ if (!is.list(earg.a)) earg.a = list()
+ if (!is.list(earg.scale)) earg.scale = list()
new("vglmff",
- blurb=c("Fisk distribution\n\n",
+ blurb = c("Fisk distribution\n\n",
"Links: ",
namesof("a", link.a, earg=earg.a), ", ",
namesof("scale", link.scale, earg=earg.scale), "\n",
@@ -6570,13 +6580,13 @@ dinvparalogistic = function(x, a, scale=1, log=FALSE)
namesof("scale", .link.scale, earg=.earg.scale, tag=FALSE))
qq = parg = 1
- if(!length(.init.scale)) {
+ if (!length(.init.scale)) {
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 )))
}
- if(!length(etastart)) {
+ if (!length(etastart)) {
aa = rep(if(length(.init.a)) .init.a else -1/fit0$coef[2], length=n)
scale = rep(if(length(.init.scale)) .init.scale else
exp(fit0$coef[1]), length=n)
@@ -6593,7 +6603,7 @@ dinvparalogistic = function(x, a, scale=1, log=FALSE)
scale*gamma(1 + 1/aa)*gamma(1-1/aa)
}, list( .link.a=link.a, .link.scale=link.scale,
.earg.a=earg.a, .earg.scale=earg.scale ))),
- last=eval(substitute(expression({
+ last = eval(substitute(expression({
misc$link = c(a= .link.a, scale= .link.scale)
misc$earg = list(a= .earg.a, scale= .earg.scale)
}), list( .link.a=link.a, .link.scale=link.scale,
@@ -6604,7 +6614,7 @@ dinvparalogistic = function(x, a, scale=1, log=FALSE)
aa = eta2theta(eta[,1], .link.a, earg= .earg)
scale = eta2theta(eta[,2], .link.scale, earg= .earg.scale)
parg = qq = 1
- if(residuals) stop("loglikelihood residuals not implemented yet") else {
+ if (residuals) stop("loglikelihood residuals not implemented yet") else {
sum(w * dfisk(x=y, a=aa, scale=scale, log=TRUE))
}
}, list( .link.a=link.a, .link.scale=link.scale,
@@ -6653,17 +6663,17 @@ dinvparalogistic = function(x, a, scale=1, log=FALSE)
zero=NULL)
{
- if(mode(link.scale) != "character" && mode(link.scale) != "name")
+ if (mode(link.scale) != "character" && mode(link.scale) != "name")
link.scale = as.character(substitute(link.scale))
- if(mode(link.p) != "character" && mode(link.p) != "name")
+ if (mode(link.p) != "character" && mode(link.p) != "name")
link.p = as.character(substitute(link.p))
- if(length(zero) && !is.Numeric(zero, integer=TRUE, posit=TRUE))
+ if (length(zero) && !is.Numeric(zero, integer=TRUE, posit=TRUE))
stop("bad input for argument 'zero'")
- if(!is.list(earg.scale)) earg.scale = list()
- if(!is.list(earg.p)) earg.p = list()
+ if (!is.list(earg.scale)) earg.scale = list()
+ if (!is.list(earg.p)) earg.p = list()
new("vglmff",
- blurb=c("Inverse Lomax distribution\n\n",
+ blurb = c("Inverse Lomax distribution\n\n",
"Links: ",
namesof("scale", link.scale, earg=earg.scale), ", ",
namesof("p", link.p, earg=earg.p), "\n",
@@ -6672,20 +6682,20 @@ dinvparalogistic = function(x, a, scale=1, log=FALSE)
constraints = cm.zero.vgam(constraints, x, .zero, M)
}), list( .zero=zero ))),
initialize=eval(substitute(expression({
- if(ncol(cbind(y)) != 1)
+ if (ncol(cbind(y)) != 1)
stop("response must be a vector or a one-column matrix")
predictors.names =
c(namesof("scale", .link.scale, earg=.earg.scale, tag=FALSE),
namesof("p", .link.p, earg=.earg.p, tag=FALSE))
qq = aa = 1
- if(!length(.init.scale)) {
+ if (!length(.init.scale)) {
qvec = c(.25, .5, .75) # Arbitrary; could be made an argument
- init.p = if(length(.init.p)) .init.p else 1
+ init.p = if (length(.init.p)) .init.p else 1
xvec = log( qvec^(-1/ init.p ) - 1 )
fit0 = lsfit(x=xvec, y=log(quantile(y, qvec )))
}
- if(!length(etastart)) {
+ if (!length(etastart)) {
scale = rep(if(length(.init.scale)) .init.scale else
exp(fit0$coef[1]), length=n)
parg = rep(if(length(.init.p)) .init.p else 1.0, length=n)
@@ -6704,7 +6714,7 @@ dinvparalogistic = function(x, a, scale=1, log=FALSE)
.earg.scale=earg.scale,
.earg.p=earg.p,
.link.p=link.p ))),
- last=eval(substitute(expression({
+ last = eval(substitute(expression({
misc$link = c(scale= .link.scale, p= .link.p )
misc$earg = list(scale= .earg.scale, p= .earg.p )
}), list( .link.scale=link.scale,
@@ -6716,7 +6726,7 @@ dinvparalogistic = function(x, a, scale=1, log=FALSE)
aa = qq = 1
scale = eta2theta(eta[,1], .link.scale, earg= .earg.scale)
parg = eta2theta(eta[,2], .link.p, earg= .earg.p)
- if(residuals) stop("loglikelihood residuals not implemented yet") else {
+ if (residuals) stop("loglikelihood residuals not implemented yet") else {
sum(w * dinvlomax(x=y, scale=scale, p.arg=parg, log=TRUE))
}
}, list( .link.scale=link.scale, .link.p=link.p,
@@ -6761,17 +6771,17 @@ dinvparalogistic = function(x, a, scale=1, log=FALSE)
zero=NULL)
{
- if(mode(link.a) != "character" && mode(link.a) != "name")
+ if (mode(link.a) != "character" && mode(link.a) != "name")
link.a = as.character(substitute(link.a))
- if(mode(link.scale) != "character" && mode(link.scale) != "name")
+ if (mode(link.scale) != "character" && mode(link.scale) != "name")
link.scale = as.character(substitute(link.scale))
- if(length(zero) && !is.Numeric(zero, integer=TRUE, posit=TRUE))
+ if (length(zero) && !is.Numeric(zero, integer=TRUE, posit=TRUE))
stop("bad input for argument 'zero'")
- if(!is.list(earg.a)) earg.a = list()
- if(!is.list(earg.scale)) earg.scale = list()
+ if (!is.list(earg.a)) earg.a = list()
+ if (!is.list(earg.scale)) earg.scale = list()
new("vglmff",
- blurb=c("Paralogistic distribution\n\n",
+ blurb = c("Paralogistic distribution\n\n",
"Links: ",
namesof("a", link.a, earg=earg.a), ", ",
namesof("scale", link.scale, earg=earg.scale), "\n",
@@ -6780,21 +6790,21 @@ dinvparalogistic = function(x, a, scale=1, log=FALSE)
constraints = cm.zero.vgam(constraints, x, .zero, M)
}), list( .zero=zero ))),
initialize=eval(substitute(expression({
- if(ncol(cbind(y)) != 1)
+ if (ncol(cbind(y)) != 1)
stop("response must be a vector or a one-column matrix")
predictors.names =
c(namesof("a", .link.a, earg=.earg.a, tag=FALSE),
namesof("scale", .link.scale, earg=.earg.scale, tag=FALSE))
parg = 1
- if(!length(.init.a) || !length(.init.scale)) {
+ if (!length(.init.a) || !length(.init.scale)) {
qvec = c(.25, .5, .75) # Arbitrary; could be made an argument
- init.a = if(length(.init.a)) .init.a else 1
+ init.a = if (length(.init.a)) .init.a else 1
xvec = log( (1-qvec)^(-1/ init.a ) - 1 )
fit0 = lsfit(x=xvec, y=log(quantile(y, qvec )))
}
- if(!length(etastart)) {
+ if (!length(etastart)) {
aa = rep(if(length(.init.a)) .init.a else 1/fit0$coef[2], length=n)
scale = rep(if(length(.init.scale)) .init.scale else
exp(fit0$coef[1]), length=n)
@@ -6812,7 +6822,7 @@ dinvparalogistic = function(x, a, scale=1, log=FALSE)
scale*gamma(1 + 1/aa)*gamma(qq-1/aa)/(gamma(qq))
}, list( .link.a=link.a, .link.scale=link.scale,
.earg.a=earg.a, .earg.scale=earg.scale ))),
- last=eval(substitute(expression({
+ last = eval(substitute(expression({
misc$link = c(a= .link.a, scale= .link.scale)
misc$earg = list(a= .earg.a, scale= .earg.scale )
}), list( .link.a=link.a, .link.scale=link.scale,
@@ -6823,7 +6833,7 @@ dinvparalogistic = function(x, a, scale=1, log=FALSE)
scale = eta2theta(eta[,2], .link.scale, earg= .earg.scale)
parg = 1
qq = aa
- if(residuals) stop("loglikelihood residuals not implemented yet") else {
+ if (residuals) stop("loglikelihood residuals not implemented yet") else {
sum(w * dparalogistic(x=y, a=aa, scale=scale, log=TRUE))
}
}, list( .link.a=link.a, .link.scale=link.scale,
@@ -6873,17 +6883,17 @@ dinvparalogistic = function(x, a, scale=1, log=FALSE)
zero=NULL)
{
- if(mode(link.a) != "character" && mode(link.a) != "name")
+ if (mode(link.a) != "character" && mode(link.a) != "name")
link.a = as.character(substitute(link.a))
- if(mode(link.scale) != "character" && mode(link.scale) != "name")
+ if (mode(link.scale) != "character" && mode(link.scale) != "name")
link.scale = as.character(substitute(link.scale))
- if(length(zero) && !is.Numeric(zero, integer=TRUE, posit=TRUE))
+ if (length(zero) && !is.Numeric(zero, integer=TRUE, posit=TRUE))
stop("bad input for argument 'zero'")
- if(!is.list(earg.a)) earg.a = list()
- if(!is.list(earg.scale)) earg.scale = list()
+ if (!is.list(earg.a)) earg.a = list()
+ if (!is.list(earg.scale)) earg.scale = list()
new("vglmff",
- blurb=c("Inverse paralogistic distribution\n\n",
+ blurb = c("Inverse paralogistic distribution\n\n",
"Links: ",
namesof("a", link.a, earg=earg.a), ", ",
namesof("scale", link.scale, earg=earg.scale), "\n",
@@ -6892,21 +6902,21 @@ dinvparalogistic = function(x, a, scale=1, log=FALSE)
constraints = cm.zero.vgam(constraints, x, .zero, M)
}), list( .zero=zero ))),
initialize=eval(substitute(expression({
- if(ncol(cbind(y)) != 1)
+ if (ncol(cbind(y)) != 1)
stop("response must be a vector or a one-column matrix")
predictors.names =
c(namesof("a", .link.a, earg=.earg.a, tag=FALSE),
namesof("scale", .link.scale, earg=.earg.scale, tag=FALSE))
- if(!length(.init.a) || !length(.init.scale)) {
+ if (!length(.init.a) || !length(.init.scale)) {
qvec = c(.25, .5, .75) # Arbitrary; could be made an argument
- init.p = if(length(.init.a)) .init.a else 1
+ init.p = if (length(.init.a)) .init.a else 1
xvec = log( qvec^(-1/ init.p ) - 1 )
fit0 = lsfit(x=xvec, y=log(quantile(y, qvec )))
}
qq = 1
- if(!length(etastart)) {
+ if (!length(etastart)) {
aa = rep(if(length(.init.a)) .init.a else -1/fit0$coef[2], length=n)
scale = rep(if(length(.init.scale)) .init.scale else
exp(fit0$coef[1]), length=n)
@@ -6924,7 +6934,7 @@ dinvparalogistic = function(x, a, scale=1, log=FALSE)
scale*gamma(parg + 1/aa)*gamma(qq-1/aa)/(gamma(parg)*gamma(qq))
}, list( .link.a=link.a, .link.scale=link.scale,
.earg.a=earg.a, .earg.scale=earg.scale ))),
- last=eval(substitute(expression({
+ last = eval(substitute(expression({
misc$link = c(a= .link.a, scale= .link.scale )
misc$earg = list(a= .earg.a, scale= .earg.scale )
}), list( .link.a=link.a, .link.scale=link.scale,
@@ -6935,7 +6945,7 @@ dinvparalogistic = function(x, a, scale=1, log=FALSE)
scale = eta2theta(eta[,2], .link.scale, earg= .earg.scale)
parg = aa
qq = 1
- if(residuals) stop("loglikelihood residuals not implemented yet") else {
+ if (residuals) stop("loglikelihood residuals not implemented yet") else {
sum(w * dinvparalogistic(x=y, a=aa, scale=scale, log=TRUE))
}
}, list( .link.a=link.a, .link.scale=link.scale,
@@ -6978,7 +6988,7 @@ dinvparalogistic = function(x, a, scale=1, log=FALSE)
-if(FALSE)
+ if (FALSE)
genlognormal = function(link.sigma="loge", link.r="loge",
esigma=list(), er=list(),
init.sigma=1, init.r=1, zero=NULL)
@@ -6989,17 +6999,17 @@ warning("2/4/04; doesn't work, possibly because first derivs are ",
"matrices). Possibly fundamentally cannot be estimated by IRLS. ",
"Pooling doesn't seem to help")
- if(mode(link.sigma) != "character" && mode(link.sigma) != "name")
+ if (mode(link.sigma) != "character" && mode(link.sigma) != "name")
link.sigma = as.character(substitute(link.sigma))
- if(mode(link.r) != "character" && mode(link.r) != "name")
+ if (mode(link.r) != "character" && mode(link.r) != "name")
link.r = as.character(substitute(link.r))
- if(length(zero) && !is.Numeric(zero, integer=TRUE, posit=TRUE))
+ if (length(zero) && !is.Numeric(zero, integer=TRUE, posit=TRUE))
stop("bad input for argument 'zero'")
- if(!is.list(esigma)) esigma = list()
- if(!is.list(er)) er = list()
+ if (!is.list(esigma)) esigma = list()
+ if (!is.list(er)) er = list()
new("vglmff",
- blurb=c("Three-parameter generalized lognormal distribution\n\n",
+ blurb = c("Three-parameter generalized lognormal distribution\n\n",
"Links: ",
"loc; ", namesof("sigma", link.sigma, earg=esigma, tag= TRUE),
", ", namesof("r", link.r, earg=er, tag= TRUE)),
@@ -7007,22 +7017,22 @@ warning("2/4/04; doesn't work, possibly because first derivs are ",
constraints = cm.zero.vgam(constraints, x, .zero, M)
}), list( .zero=zero ))),
initialize=eval(substitute(expression({
- if(ncol(cbind(y)) != 1)
+ if (ncol(cbind(y)) != 1)
stop("response must be a vector or a one-column matrix")
predictors.names =
c(namesof("loc", "identity", earg= list(), tag=FALSE),
namesof("sigma", .link.sigma, earg=.esigma, tag=FALSE),
namesof("r", .link.r, earg=.er, tag=FALSE))
- if(!length(.init.sigma) || !length(.init.r)) {
- init.r = if(length(.init.r)) .init.r else 1
+ if (!length(.init.sigma) || !length(.init.r)) {
+ init.r = if (length(.init.r)) .init.r else 1
sigma.init = (0.5 * sum(abs(log(y) - mean(log(y )))^init.r))^(1/init.r)
}
- if(any(y <= 0)) stop("y must be positive")
+ if (any(y <= 0)) stop("y must be positive")
- if(!length(etastart)) {
+ if (!length(etastart)) {
sigma.init = rep(if(length( .init.sigma)) .init.sigma else sigma.init, len=n)
- r.init = if(length( .init.r)) .init.r else init.r
+ r.init = if (length( .init.r)) .init.r else init.r
etastart = cbind(mu=rep(log(median(y)), len=n),
sigma=sigma.init,
r = r.init)
@@ -7035,7 +7045,7 @@ warning("2/4/04; doesn't work, possibly because first derivs are ",
r = eta2theta(eta[,3], .link.r, earg= .er)
r
}, list( .link.sigma=link.sigma, .link.r=link.r ))),
- last=eval(substitute(expression({
+ last = eval(substitute(expression({
misc$link = c(loc="identity", "sigma"= .link.sigma, r= .link.r )
misc$expected = TRUE
}), list( .link.sigma=link.sigma, .link.r=link.r ))),
@@ -7045,7 +7055,7 @@ warning("2/4/04; doesn't work, possibly because first derivs are ",
sigma = eta2theta(eta[,2], .link.sigma, earg= .esigma)
r = eta2theta(eta[,3], .link.r, earg= .er)
temp89 = (abs(log(y)-mymu)/sigma)^r
- if(residuals) stop("loglikelihood residuals not implemented yet") else
+ if (residuals) stop("loglikelihood residuals not implemented yet") else
sum(w * (-log(r^(1/r) * sigma) - lgamma(1+1/r) - temp89/r))
}, list( .link.sigma=link.sigma, .link.r=link.r ))),
vfamily=c("genlognormal3"),
@@ -7087,12 +7097,12 @@ warning("2/4/04; doesn't work, possibly because first derivs are ",
betaprime = function(link="loge", earg=list(), i1=2, i2=NULL, zero=NULL)
{
- if(mode(link) != "character" && mode(link) != "name")
+ if (mode(link) != "character" && mode(link) != "name")
link = as.character(substitute(link))
- if(!is.list(earg)) earg = list()
+ if (!is.list(earg)) earg = list()
new("vglmff",
- blurb=c("Beta-prime distribution\n",
+ blurb = c("Beta-prime distribution\n",
"y^(shape1-1) * (1+y)^(-shape1-shape2) / Beta(shape1,shape2),",
" y>0, shape1>0, shape2>0\n\n",
"Links: ",
@@ -7103,21 +7113,21 @@ warning("2/4/04; doesn't work, possibly because first derivs are ",
constraints = cm.zero.vgam(constraints, x, .zero, M)
}), list( .zero=zero ))),
initialize=eval(substitute(expression({
- if(ncol(y <- as.matrix(y)) > 1)
+ if (ncol(y <- as.matrix(y)) > 1)
stop("betaprime cannot handle matrix responses yet")
- if(min(y) <= 0)
+ if (min(y) <= 0)
stop("response must be positive")
predictors.names = c(namesof("shape1", .link, earg=.earg, short=TRUE),
namesof("shape2", .link, earg=.earg, short=TRUE))
- if(is.numeric(.i1) && is.numeric(.i2)) {
+ 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))
etastart = matrix(vec, n, 2, byrow= TRUE)
}
- if(!length(etastart)) {
- init1 = if(length( .i1)) rep( .i1, len=n) else rep(1, len=n)
- init2 = if(length( .i2)) rep( .i2, len=n) else 1 + init1 / (y + 0.1)
+ if (!length(etastart)) {
+ init1 = if (length( .i1)) rep( .i1, len=n) else rep(1, len=n)
+ init2 = if (length( .i2)) rep( .i2, len=n) else 1 + init1 / (y + 0.1)
etastart = matrix(theta2eta(c(init1, init2), .link, earg= .earg),
n,2,byrow=TRUE)
}
@@ -7126,14 +7136,14 @@ warning("2/4/04; doesn't work, possibly because first derivs are ",
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({
+ last = eval(substitute(expression({
misc$link = c(shape1 = .link, shape2 = .link)
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)
- if(residuals) stop("loglikelihood residuals not implemented yet") else {
+ if (residuals) stop("loglikelihood residuals not implemented yet") else {
sum(w *((shapes[,1]-1) * log(y) - lbeta(shapes[,1], shapes[,2]) -
(shapes[,2]+shapes[,1]) * log1p(y)))
}
@@ -7169,7 +7179,7 @@ warning("2/4/04; doesn't work, possibly because first derivs are ",
dmaxwell = function(x, a, log = FALSE) {
- if(!is.logical(log.arg <- log))
+ if (!is.logical(log.arg <- log))
stop("bad input for argument 'log'")
rm(log)
@@ -7179,47 +7189,47 @@ dmaxwell = function(x, a, log = FALSE) {
xok = (x > 0)
logdensity[xok] = 0.5 * log(2/pi) + 1.5 * log(a[xok]) +
2 * log(x[xok]) - 0.5 * a[xok] * x[xok]^2
- if(log.arg) logdensity else exp(logdensity)
+ if (log.arg) logdensity else exp(logdensity)
}
pmaxwell = function(q, a) {
- if(any(a <= 0)) stop("argument 'a' must be positive")
+ if (any(a <= 0)) stop("argument 'a' must be positive")
L = max(length(q), length(a))
q = rep(q, len=L); a = rep(a, len=L);
ifelse(q > 0, erf(q*sqrt(a/2)) - q*exp(-0.5*a*q^2) * sqrt(2*a/pi), 0)
}
rmaxwell = function(n, a) {
- if(!is.Numeric(n, posit=TRUE, allow=1))
+ if (!is.Numeric(n, posit=TRUE, allow=1))
stop("bad input for argument 'n'")
- if(any(a <= 0)) stop("argument 'a' must be positive")
+ if (any(a <= 0)) stop("argument 'a' must be positive")
sqrt(2 * rgamma(n=n, 1.5) / a)
}
qmaxwell = function(p, a) {
- if(!is.Numeric(p, posit=TRUE) || any(p>=1))
+ if (!is.Numeric(p, posit=TRUE) || any(p>=1))
stop("bad input for argument 'p'")
- if(any(a <= 0)) stop("argument 'a' must be positive")
+ if (any(a <= 0)) stop("argument 'a' must be positive")
N = max(length(p), length(a)); p = rep(p, len=N); a = rep(a, len=N)
sqrt(2 * qgamma(p=p, 1.5) / a)
}
maxwell = function(link="loge", earg=list()) {
- if(mode(link) != "character" && mode(link) != "name")
+ if (mode(link) != "character" && mode(link) != "name")
link = as.character(substitute(link))
- if(!is.list(earg)) earg = list()
+ if (!is.list(earg)) earg = list()
new("vglmff",
- blurb=c("Maxwell distribution f(y) = sqrt(2/pi) * a^(3/2) * y^2 *",
+ blurb = c("Maxwell distribution f(y) = sqrt(2/pi) * a^(3/2) * y^2 *",
" exp(-0.5*a*y^2), y>0, a>0\n",
"Link: ", namesof("a", link, earg=earg), "\n", "\n",
"Mean: sqrt(8 / (a * pi))"),
initialize=eval(substitute(expression({
- if(ncol(cbind(y)) != 1)
+ if (ncol(cbind(y)) != 1)
stop("response must be a vector or a one-column matrix")
predictors.names = namesof("a", .link, earg=.earg, tag=FALSE)
- if(!length(etastart)) {
+ if (!length(etastart)) {
a.init = rep(8 / (pi*(y+0.1)^2), length=length(y))
etastart = theta2eta(a.init, .link, earg= .earg)
}
@@ -7228,14 +7238,14 @@ qmaxwell = function(p, a) {
a = eta2theta(eta, .link, earg= .earg)
sqrt(8 / (a * pi))
}, list( .link=link, .earg=earg ))),
- last=eval(substitute(expression({
+ last = eval(substitute(expression({
misc$link = c(a= .link)
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)
- if(residuals) stop("loglikelihood residuals not implemented yet") else
+ 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"),
@@ -7256,7 +7266,7 @@ qmaxwell = function(p, a) {
dnaka = function(x, shape, scale=1, log = FALSE) {
- if(!is.logical(log.arg <- log))
+ if (!is.logical(log.arg <- log))
stop("bad input for argument 'log'")
rm(log)
L = max(length(x), length(shape), length(scale))
@@ -7267,16 +7277,16 @@ dnaka = function(x, shape, scale=1, log = FALSE) {
logdensity[xok] = dgamma(x=x[xok]^2, shape=shape[xok],
scale=scale[xok]/shape[xok], log=TRUE) +
log(2) + log(x[xok])
- if(log.arg) logdensity else exp(logdensity)
+ if (log.arg) logdensity else exp(logdensity)
}
pnaka = function(q, shape, scale=1) {
- if(!is.Numeric(q))
+ if (!is.Numeric(q))
stop("bad input for argument 'q'")
- if(!is.Numeric(shape, posit=TRUE))
+ if (!is.Numeric(shape, posit=TRUE))
stop("bad input for argument 'shape'")
- if(!is.Numeric(scale, posit=TRUE))
+ if (!is.Numeric(scale, posit=TRUE))
stop("bad input for argument 'scale'")
L = max(length(q), length(shape), length(scale))
q = rep(q, len=L); shape = rep(shape, len=L); scale = rep(scale, len=L);
@@ -7285,11 +7295,11 @@ pnaka = function(q, shape, scale=1) {
qnaka = function(p, shape, scale=1, ...) {
- if(!is.Numeric(p, posit=TRUE) || max(p) >= 1)
+ if (!is.Numeric(p, posit=TRUE) || max(p) >= 1)
stop("bad input for argument 'p'")
- if(!is.Numeric(shape, posit=TRUE))
+ if (!is.Numeric(shape, posit=TRUE))
stop("bad input for argument 'shape'")
- if(!is.Numeric(scale, posit=TRUE))
+ if (!is.Numeric(scale, posit=TRUE))
stop("bad input for argument 'scale'")
L = max(length(p), length(shape), length(scale))
p = rep(p, len=L); shape = rep(shape, len=L); scale = rep(scale, len=L);
@@ -7309,13 +7319,13 @@ qnaka = function(p, shape, scale=1, ...) {
rnaka = function(n, shape, scale=1, Smallno=1.0e-6) {
- if(!is.Numeric(n, posit=TRUE, integ=TRUE))
+ if (!is.Numeric(n, posit=TRUE, integ=TRUE))
stop("bad input for argument 'n'")
- if(!is.Numeric(scale, posit=TRUE, allow=1))
+ if (!is.Numeric(scale, posit=TRUE, allow=1))
stop("bad input for argument 'scale'")
- if(!is.Numeric(shape, posit=TRUE, allow=1))
+ if (!is.Numeric(shape, posit=TRUE, allow=1))
stop("bad input for argument 'shape'")
- if(!is.Numeric(Smallno, posit=TRUE, allow=1) || Smallno > 0.01 ||
+ if (!is.Numeric(Smallno, posit=TRUE, allow=1) || Smallno > 0.01 ||
Smallno < 2 * .Machine$double.eps)
stop("bad input for argument 'Smallno'")
ans = rep(0.0, len=n)
@@ -7330,7 +7340,7 @@ rnaka = function(n, shape, scale=1, Smallno=1.0e-6) {
x = runif(2*n, min=0, max=Upper)
index = runif(2*n, max=ymax) < dnaka(x, shape=shape, scale=scale)
sindex = sum(index)
- if(sindex) {
+ if (sindex) {
ptr2 = min(n, ptr1 + sindex - 1)
ans[ptr1:ptr2] = (x[index])[1:(1+ptr2-ptr1)]
ptr1 = ptr2 + 1
@@ -7346,17 +7356,17 @@ rnaka = function(n, shape, scale=1, Smallno=1.0e-6) {
nakagami = function(lshape="loge", lscale="loge",
eshape=list(), escale=list(), ishape=NULL, iscale=1) {
- if(mode(lshape) != "character" && mode(lshape) != "name")
+ if (mode(lshape) != "character" && mode(lshape) != "name")
lshape = as.character(substitute(lshape))
- if(mode(lscale) != "character" && mode(lscale) != "name")
+ if (mode(lscale) != "character" && mode(lscale) != "name")
lscale = as.character(substitute(lscale))
- if(!is.null(iscale) && !is.Numeric(iscale, positi=TRUE))
+ if (!is.null(iscale) && !is.Numeric(iscale, positi=TRUE))
stop("argument 'iscale' must be a positive number or NULL")
- if(!is.list(eshape)) eshape = list()
- if(!is.list(escale)) escale = list()
+ if (!is.list(eshape)) eshape = list()
+ if (!is.list(escale)) escale = list()
new("vglmff",
- blurb=c("Nakagami distribution f(y) = 2 * (shape/scale)^shape *\n",
+ blurb = c("Nakagami distribution f(y) = 2 * (shape/scale)^shape *\n",
" ",
"y^(2*shape-1) * exp(-shape*y^2/scale) / gamma(shape),\n",
" ",
@@ -7368,14 +7378,14 @@ rnaka = function(n, shape, scale=1, Smallno=1.0e-6) {
"\n",
"Mean: sqrt(scale/shape) * gamma(shape+0.5) / gamma(shape)"),
initialize=eval(substitute(expression({
- if(ncol(cbind(y)) != 1)
+ 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))
- if(!length(etastart)) {
- init2 = if(is.Numeric( .iscale, posit=TRUE))
+ if (!length(etastart)) {
+ init2 = if (is.Numeric( .iscale, posit=TRUE))
rep( .iscale, len=n) else rep(1, len=n)
- init1 = if(is.Numeric( .ishape, posit=TRUE))
+ init1 = if (is.Numeric( .ishape, posit=TRUE))
rep( .ishape, len=n) else
rep(init2 / (y+1/8)^2, len=n)
etastart = cbind(theta2eta(init1, .lshape, earg= .eshape),
@@ -7390,7 +7400,7 @@ rnaka = function(n, shape, scale=1, Smallno=1.0e-6) {
sqrt(scale/shape) * gamma(shape+0.5) / gamma(shape)
}, list( .lscale=lscale, .lshape=lshape,
.escale=escale, .eshape=eshape ))),
- last=eval(substitute(expression({
+ last = eval(substitute(expression({
misc$link = c(shape= .lshape, scale= .lscale)
misc$earg = list(shape = .eshape, scale = .escale)
misc$expected = TRUE
@@ -7400,7 +7410,7 @@ rnaka = function(n, shape, scale=1, Smallno=1.0e-6) {
function(mu,y,w,residuals= FALSE,eta, extra=NULL) {
shape = eta2theta(eta[,1], .lshape, earg= .eshape)
scale = eta2theta(eta[,2], .lscale, earg= .escale)
- if(residuals) stop("loglikelihood residuals not implemented yet") else
+ if (residuals) stop("loglikelihood residuals not implemented yet") else
sum(w * dnaka(x=y, shape=shape, scale=scale, log=TRUE))
}, list( .lscale=lscale, .lshape=lshape,
.escale=escale, .eshape=eshape ))),
@@ -7430,7 +7440,7 @@ rnaka = function(n, shape, scale=1, Smallno=1.0e-6) {
drayleigh = function(x, a, log=FALSE) {
- if(!is.logical(log.arg <- log))
+ if (!is.logical(log.arg <- log))
stop("bad input for argument 'log'")
rm(log)
@@ -7439,48 +7449,48 @@ drayleigh = function(x, a, log=FALSE) {
logdensity = rep(log(0), len=L)
xok = (x > 0)
logdensity[xok] = log(x[xok]) - 0.5 * (x[xok]/a[xok])^2 - 2*log(a[xok])
- if(log.arg) logdensity else exp(logdensity)
+ if (log.arg) logdensity else exp(logdensity)
}
prayleigh = function(q, a) {
- if(any(a <= 0)) stop("argument 'a' must be positive")
+ if (any(a <= 0)) stop("argument 'a' must be positive")
L = max(length(q), length(a))
q = rep(q, len=L); a = rep(a, len=L);
ifelse(q > 0, 1 - exp(-0.5*(q/a)^2), 0)
}
qrayleigh = function(p, a) {
- if(any(a <= 0)) stop("argument 'a' must be positive")
- if(any(p <= 0) || any(p >= 1)) stop("argument 'p' must be between 0 and 1")
+ if (any(a <= 0)) stop("argument 'a' must be positive")
+ if (any(p <= 0) || any(p >= 1)) stop("argument 'p' must be between 0 and 1")
a * sqrt(-2 * log1p(-p))
}
rrayleigh = function(n, a) {
- if(!is.Numeric(n, posit=TRUE, allow=1, integ=TRUE))
+ if (!is.Numeric(n, posit=TRUE, allow=1, integ=TRUE))
stop("bad input for argument 'n'")
- if(any(a <= 0)) stop("a must be positive")
+ if (any(a <= 0)) stop("a must be positive")
a * sqrt(-2 * log(runif(n )))
}
rayleigh = function(link="loge", earg=list(), nrfs=1/3+0.01) {
- if(mode(link) != "character" && mode(link) != "name")
+ if (mode(link) != "character" && mode(link) != "name")
link = as.character(substitute(link))
- if(!is.list(earg)) earg = list()
- if(!is.Numeric(nrfs, allow=1) || nrfs<0 || nrfs > 1)
+ if (!is.list(earg)) earg = list()
+ if (!is.Numeric(nrfs, allow=1) || nrfs<0 || nrfs > 1)
stop("bad input for 'nrfs'")
new("vglmff",
- blurb=c("Rayleigh distribution f(y) = y*exp(-0.5*(y/a)^2)/a^2, y>0, a>0\n",
+ blurb = c("Rayleigh distribution f(y) = y*exp(-0.5*(y/a)^2)/a^2, y>0, a>0\n",
"Link: ",
namesof("a", link, earg=earg), "\n\n",
"Mean: a * sqrt(pi / 2)"),
initialize=eval(substitute(expression({
- if(ncol(cbind(y)) != 1)
+ if (ncol(cbind(y)) != 1)
stop("response must be a vector or a one-column matrix")
predictors.names = namesof("a", .link, earg=.earg, tag=FALSE)
- if(!length(etastart)) {
+ if (!length(etastart)) {
a.init = (y+1/8) / sqrt(pi/2)
etastart = theta2eta(a.init, .link, earg= .earg)
}
@@ -7489,7 +7499,7 @@ rrayleigh = function(n, a) {
a = eta2theta(eta, .link, earg= .earg)
a * sqrt(pi/2)
}, list( .link=link, .earg=earg ))),
- last=eval(substitute(expression({
+ last = eval(substitute(expression({
misc$link = c(a= .link)
misc$earg = list(a = .earg)
misc$nrfs = .nrfs
@@ -7497,7 +7507,7 @@ rrayleigh = function(n, a) {
loglikelihood=eval(substitute(
function(mu,y,w,residuals= FALSE,eta, extra=NULL) {
a = eta2theta(eta, .link, earg= .earg)
- if(residuals) stop("loglikelihood residuals not implemented yet") else {
+ if (residuals) stop("loglikelihood residuals not implemented yet") else {
sum(w * drayleigh(x=y, a=a, log=TRUE))
}
}, list( .link=link, .earg=earg ))),
@@ -7521,7 +7531,7 @@ rrayleigh = function(n, a) {
dparetoIV = function(x, location=0, scale=1, inequality=1, shape=1, log=FALSE) {
- if(!is.logical(log.arg <- log))
+ if (!is.logical(log.arg <- log))
stop("bad input for argument 'log'")
rm(log)
@@ -7537,16 +7547,16 @@ dparetoIV = function(x, location=0, scale=1, inequality=1, shape=1, log=FALSE) {
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)
+ if (log.arg) logdensity else exp(logdensity)
}
pparetoIV = function(q, location=0, scale=1, inequality=1, shape=1) {
- if(!is.Numeric(q)) stop("bad input for argument 'q'")
- if(!is.Numeric(scale, posit=TRUE))
+ if (!is.Numeric(q)) stop("bad input for argument 'q'")
+ if (!is.Numeric(scale, posit=TRUE))
stop("bad input for argument 'scale'")
- if(!is.Numeric(inequality, posi=TRUE))
+ if (!is.Numeric(inequality, posi=TRUE))
stop("bad input for argument 'inequality'")
- if(!is.Numeric(shape, posit=TRUE))
+ if (!is.Numeric(shape, posit=TRUE))
stop("bad input for argument 'shape'")
N = max(length(q), length(location), length(scale), length(inequality),
length(shape))
@@ -7561,24 +7571,24 @@ pparetoIV = function(q, location=0, scale=1, inequality=1, shape=1) {
}
qparetoIV = function(p, location=0, scale=1, inequality=1, shape=1) {
- if(!is.Numeric(p, posit=TRUE) || any(p >= 1))
+ if (!is.Numeric(p, posit=TRUE) || any(p >= 1))
stop("bad input for argument 'p'")
- if(!is.Numeric(scale, posit=TRUE))
+ if (!is.Numeric(scale, posit=TRUE))
stop("bad input for argument 'scale'")
- if(!is.Numeric(inequality, posi=TRUE))
+ if (!is.Numeric(inequality, posi=TRUE))
stop("bad input for argument 'inequality'")
- if(!is.Numeric(shape, posit=TRUE))
+ if (!is.Numeric(shape, posit=TRUE))
stop("bad input for argument 'shape'")
location + scale * (-1 + (1-p)^(-1/shape))^inequality
}
rparetoIV = function(n, location=0, scale=1, inequality=1, shape=1) {
- if(!is.Numeric(n, posit=TRUE, integ=TRUE, allow=1))
+ if (!is.Numeric(n, posit=TRUE, integ=TRUE, allow=1))
stop("bad input for argument n")
- if(!is.Numeric(scale, posit=TRUE)) stop("bad input for argument 'scale'")
- if(!is.Numeric(inequality, posi=TRUE))
+ if (!is.Numeric(scale, posit=TRUE)) stop("bad input for argument 'scale'")
+ if (!is.Numeric(inequality, posi=TRUE))
stop("bad input for argument 'inequality'")
- if(!is.Numeric(shape, posit=TRUE)) stop("bad input for argument 'shape'")
+ if (!is.Numeric(shape, posit=TRUE)) stop("bad input for argument 'shape'")
location + scale * (-1 + runif(n)^(-1/shape))^inequality
}
@@ -7636,30 +7646,30 @@ rparetoI = function(n, scale=1, shape=1)
escale=list(), einequality=list(), eshape=list(),
iscale=1, iinequality=1, ishape=NULL,
method.init=1) {
- if(mode(lscale) != "character" && mode(lscale) != "name")
+ if (mode(lscale) != "character" && mode(lscale) != "name")
lscale = as.character(substitute(lscale))
- if(mode(linequality) != "character" && mode(linequality) != "name")
+ if (mode(linequality) != "character" && mode(linequality) != "name")
linequality = as.character(substitute(linequality))
- if(mode(lshape) != "character" && mode(lshape) != "name")
+ if (mode(lshape) != "character" && mode(lshape) != "name")
lshape = as.character(substitute(lshape))
- if(!is.Numeric(location))
+ if (!is.Numeric(location))
stop("argument 'location' must be numeric")
- if(is.Numeric(iscale) && any(iscale <= 0))
+ if (is.Numeric(iscale) && any(iscale <= 0))
stop("argument 'iscale' must be positive")
- if(is.Numeric(iinequality) && any(iinequality <= 0))
+ if (is.Numeric(iinequality) && any(iinequality <= 0))
stop("argument 'iinequality' must be positive")
- if(is.Numeric(ishape) && any(ishape <= 0))
+ if (is.Numeric(ishape) && any(ishape <= 0))
stop("argument 'ishape' must be positive")
- if(!is.Numeric(method.init, allow=1, integ=TRUE) || method.init>2)
+ if (!is.Numeric(method.init, allow=1, integ=TRUE) || method.init>2)
stop("bad input for argument 'method.init'")
- if(linequality == "nloge" && location != 0)
+ if (linequality == "nloge" && location != 0)
warning("The Burr distribution has 'location=0' and 'linequality=nloge'")
- if(!is.list(escale)) escale = list()
- if(!is.list(einequality)) einequality = list()
- if(!is.list(eshape)) eshape = list()
+ if (!is.list(escale)) escale = list()
+ if (!is.list(einequality)) einequality = list()
+ if (!is.list(eshape)) eshape = list()
new("vglmff",
- blurb=c("Pareto(IV) distribution F(y)=1-[1+((y - ", location,
+ blurb = c("Pareto(IV) distribution F(y)=1-[1+((y - ", location,
")/scale)^(1/inequality)]^(-shape),",
"\n", " y > ",
location, ", scale > 0, inequality > 0, shape > 0,\n",
@@ -7668,22 +7678,22 @@ rparetoI = function(n, scale=1, shape=1)
namesof("shape", lshape, earg=eshape ), "\n",
"Mean: location + scale * NA"),
initialize=eval(substitute(expression({
- if(ncol(cbind(y)) != 1)
+ if (ncol(cbind(y)) != 1)
stop("response must be a vector or a one-column matrix")
predictors.names =
c(namesof("scale", .lscale, earg=.escale, tag=FALSE),
namesof("inequality", .linequality, earg=.einequality, tag=FALSE),
namesof("shape", .lshape, earg=.eshape, tag=FALSE))
extra$location = location = .location
- if(any(y <= location))
+ if (any(y <= location))
stop("the response must have values > than the 'location' argument")
- if(!length(etastart)) {
- inequality.init = if(length(.iinequality)) .iinequality else 1
- scale.init = if(length( .iscale)) .iscale else 1
- shape.init = if(length( .ishape)) .ishape else NULL
- if(!length(shape.init)) {
+ if (!length(etastart)) {
+ inequality.init = if (length(.iinequality)) .iinequality else 1
+ scale.init = if (length( .iscale)) .iscale else 1
+ shape.init = if (length( .ishape)) .ishape else NULL
+ if (!length(shape.init)) {
zedd = (y - location) / scale.init
- if( .method.init == 1) {
+ if ( .method.init == 1) {
A1 = weighted.mean(1/(1 + zedd^(1/inequality.init)), w=w)
A2 = weighted.mean(1/(1 + zedd^(1/inequality.init))^2, w=w)
} else {
@@ -7709,7 +7719,7 @@ rparetoI = function(n, scale=1, shape=1)
location + Scale * NA
}, list( .lscale=lscale, .linequality=linequality, .lshape=lshape,
.escale=escale, .einequality=einequality, .eshape=eshape ))),
- last=eval(substitute(expression({
+ last = eval(substitute(expression({
misc$link=c("scale"= .lscale, "inequality"= .linequality,
"shape"= .lshape)
misc$earg = list(scale = .escale, inequality= .einequality,
@@ -7724,7 +7734,7 @@ rparetoI = function(n, scale=1, shape=1)
inequality = eta2theta(eta[,2], .linequality, earg= .einequality)
shape = eta2theta(eta[,3], .lshape, earg= .eshape)
zedd = (y - location) / Scale
- if(residuals) stop("loglikelihood residuals not implemented yet") else {
+ if (residuals) stop("loglikelihood residuals not implemented yet") else {
sum(w * dparetoIV(x=y, location=location, scale=Scale,
inequality=inequality, shape=shape, log=TRUE))
}
@@ -7779,21 +7789,21 @@ rparetoI = function(n, scale=1, shape=1)
linequality="loge",
escale=list(), einequality=list(),
iscale=NULL, iinequality=NULL) {
- if(mode(lscale) != "character" && mode(lscale) != "name")
+ if (mode(lscale) != "character" && mode(lscale) != "name")
lscale = as.character(substitute(lscale))
- if(mode(linequality) != "character" && mode(linequality) != "name")
+ if (mode(linequality) != "character" && mode(linequality) != "name")
linequality = as.character(substitute(linequality))
- if(!is.Numeric(location))
+ if (!is.Numeric(location))
stop("argument 'location' must be numeric")
- if(is.Numeric(iscale) && any(iscale <= 0))
+ if (is.Numeric(iscale) && any(iscale <= 0))
stop("argument 'iscale' must be positive")
- if(is.Numeric(iinequality) && any(iinequality <= 0))
+ if (is.Numeric(iinequality) && any(iinequality <= 0))
stop("argument 'iinequality' must be positive")
- if(!is.list(escale)) escale = list()
- if(!is.list(einequality)) einequality = list()
+ if (!is.list(escale)) escale = list()
+ if (!is.list(einequality)) einequality = list()
new("vglmff",
- blurb=c("Pareto(III) distribution F(y)=1-[1+((y - ", location,
+ blurb = c("Pareto(III) distribution F(y)=1-[1+((y - ", location,
")/scale)^(1/inequality)]^(-1),",
"\n", " y > ",
location, ", scale > 0, inequality > 0, \n",
@@ -7802,24 +7812,24 @@ rparetoI = function(n, scale=1, shape=1)
namesof("inequality", linequality, earg=einequality ), "\n",
"Mean: location + scale * NA"),
initialize=eval(substitute(expression({
- if(ncol(cbind(y)) != 1)
+ if (ncol(cbind(y)) != 1)
stop("the response must be a vector or a one-column matrix")
predictors.names =
c(namesof("scale", .lscale, earg=.escale, tag=FALSE),
namesof("inequality", .linequality, earg=.einequality, tag=FALSE))
extra$location = location = .location
- if(any(y <= location))
+ if (any(y <= location))
stop("the response must have values > than the 'location' argument")
- if(!length(etastart)) {
- inequality.init = if(length(.iinequality)) .iinequality else NULL
- scale.init = if(length( .iscale)) .iscale else NULL
- if(!length(inequality.init) || !length(scale.init)) {
+ if (!length(etastart)) {
+ inequality.init = if (length(.iinequality)) .iinequality else NULL
+ scale.init = if (length( .iscale)) .iscale else NULL
+ if (!length(inequality.init) || !length(scale.init)) {
probs = (1:4)/5
ytemp = quantile(x=log(y-location), probs=probs)
fittemp = lsfit(x=logit(probs), y=ytemp, int=TRUE)
- if(!length(inequality.init))
+ if (!length(inequality.init))
inequality.init = max(fittemp$coef["X"], 0.01)
- if(!length(scale.init))
+ if (!length(scale.init))
scale.init = exp(fittemp$coef["Intercept"])
}
etastart=cbind(
@@ -7837,7 +7847,7 @@ rparetoI = function(n, scale=1, shape=1)
location + Scale * NA
}, list( .lscale=lscale, .linequality=linequality,
.escale=escale, .einequality=einequality ))),
- last=eval(substitute(expression({
+ last = eval(substitute(expression({
misc$link=c("scale"= .lscale, "inequality"= .linequality)
misc$earg = list(scale = .escale, inequality= .einequality)
misc$location = extra$location # Use this for prediction
@@ -7849,7 +7859,7 @@ rparetoI = function(n, scale=1, shape=1)
Scale = eta2theta(eta[,1], .lscale, earg= .escale)
inequality = eta2theta(eta[,2], .linequality, earg= .einequality)
zedd = (y - location) / Scale
- if(residuals) stop("loglikelihood residuals not implemented yet") else {
+ if (residuals) stop("loglikelihood residuals not implemented yet") else {
sum(w * dparetoIII(x=y, location=location, scale=Scale,
inequality=inequality, log=TRUE))
}
@@ -7892,21 +7902,21 @@ rparetoI = function(n, scale=1, shape=1)
lshape="loge",
escale=list(), eshape=list(),
iscale=NULL, ishape=NULL) {
- if(mode(lscale) != "character" && mode(lscale) != "name")
+ if (mode(lscale) != "character" && mode(lscale) != "name")
lscale = as.character(substitute(lscale))
- if(mode(lshape) != "character" && mode(lshape) != "name")
+ if (mode(lshape) != "character" && mode(lshape) != "name")
lshape = as.character(substitute(lshape))
- if(!is.Numeric(location))
+ if (!is.Numeric(location))
stop("argument 'location' must be numeric")
- if(is.Numeric(iscale) && any(iscale <= 0))
+ if (is.Numeric(iscale) && any(iscale <= 0))
stop("argument 'iscale' must be positive")
- if(is.Numeric(ishape) && any(ishape <= 0))
+ if (is.Numeric(ishape) && any(ishape <= 0))
stop("argument 'ishape' must be positive")
- if(!is.list(escale)) escale = list()
- if(!is.list(eshape)) eshape = list()
+ if (!is.list(escale)) escale = list()
+ if (!is.list(eshape)) eshape = list()
new("vglmff",
- blurb=c("Pareto(II) distribution F(y)=1-[1+(y - ", location,
+ blurb = c("Pareto(II) distribution F(y)=1-[1+(y - ", location,
")/scale]^(-shape),",
"\n", " y > ",
location, ", scale > 0, shape > 0,\n",
@@ -7914,25 +7924,25 @@ rparetoI = function(n, scale=1, shape=1)
namesof("shape", lshape, earg=eshape ), "\n",
"Mean: location + scale * NA"),
initialize=eval(substitute(expression({
- if(ncol(cbind(y)) != 1)
+ if (ncol(cbind(y)) != 1)
stop("the response must be a vector or a one-column matrix")
predictors.names =
c(namesof("scale", .lscale, earg=.escale, tag=FALSE),
namesof("shape", .lshape, earg=.eshape, tag=FALSE))
extra$location = location = .location
- if(any(y <= location))
+ if (any(y <= location))
stop("the response must have values > than the 'location' argument")
- if(!length(etastart)) {
- scale.init = if(length( .iscale)) .iscale else NULL
- shape.init = if(length( .ishape)) .ishape else NULL
- if(!length(shape.init) || !length(scale.init)) {
+ if (!length(etastart)) {
+ scale.init = if (length( .iscale)) .iscale else NULL
+ shape.init = if (length( .ishape)) .ishape else NULL
+ if (!length(shape.init) || !length(scale.init)) {
probs = (1:4)/5
scale.init.0 = 1
ytemp = quantile(x=log(y-location+scale.init.0), probs=probs)
fittemp = lsfit(x=log1p(-probs), y=ytemp, int=TRUE)
- if(!length(shape.init))
+ if (!length(shape.init))
shape.init = max(-1/fittemp$coef["X"], 0.01)
- if(!length(scale.init))
+ if (!length(scale.init))
scale.init = exp(fittemp$coef["Intercept"])
}
etastart=cbind(
@@ -7949,7 +7959,7 @@ rparetoI = function(n, scale=1, shape=1)
location + Scale * NA
}, list( .lscale=lscale, .lshape=lshape,
.escale=escale, .eshape=eshape ))),
- last=eval(substitute(expression({
+ last = eval(substitute(expression({
misc$link=c("scale"= .lscale, "shape"= .lshape)
misc$earg = list(scale = .escale, shape= .eshape)
misc$location = extra$location # Use this for prediction
@@ -7961,7 +7971,7 @@ rparetoI = function(n, scale=1, shape=1)
Scale = eta2theta(eta[,1], .lscale, earg= .escale)
shape = eta2theta(eta[,2], .lshape, earg= .eshape)
zedd = (y - location) / Scale
- if(residuals) stop("loglikelihood residuals not implemented yet") else {
+ if (residuals) stop("loglikelihood residuals not implemented yet") else {
sum(w * dparetoII(x=y, location=location, scale=Scale,
shape=shape, log=TRUE))
}
@@ -8000,7 +8010,7 @@ rparetoI = function(n, scale=1, shape=1)
dpareto = function(x, location, shape, log = FALSE) {
- if(!is.logical(log.arg <- log))
+ if (!is.logical(log.arg <- log))
stop("bad input for argument 'log'")
rm(log)
@@ -8011,62 +8021,62 @@ dpareto = function(x, location, shape, log = FALSE) {
xok = (x > location)
logdensity[xok] = log(shape[xok]) + shape[xok] * log(location[xok]) -
(shape[xok]+1) * log(x[xok])
- if(log.arg) logdensity else exp(logdensity)
+ if (log.arg) logdensity else exp(logdensity)
}
ppareto = function(q, location, shape) {
- if(any(location <= 0)) stop("argument 'location' must be positive")
- if(any(shape <= 0)) stop("argument 'shape' must be positive")
+ if (any(location <= 0)) stop("argument 'location' must be positive")
+ if (any(shape <= 0)) stop("argument 'shape' must be positive")
L = max(length(q), length(location), length(shape))
q = rep(q, len=L); location = rep(location, len=L); shape= rep(shape, len=L)
ifelse(q > location, 1 - (location/q)^shape, 0)
}
qpareto = function(p, location, shape) {
- if(any(location <= 0)) stop("argument 'location' must be positive")
- if(any(shape <= 0)) stop("argument 'shape' must be positive")
- if(any(p <= 0) || any(p >= 1)) stop("argument 'p' must be between 0 and 1")
+ if (any(location <= 0)) stop("argument 'location' must be positive")
+ if (any(shape <= 0)) stop("argument 'shape' must be positive")
+ if (any(p <= 0) || any(p >= 1)) stop("argument 'p' must be between 0 and 1")
location / (1 - p)^(1/shape)
}
rpareto = function(n, location, shape) {
- if(!is.Numeric(n, posit=TRUE, integ=TRUE, allow=1))
+ if (!is.Numeric(n, posit=TRUE, integ=TRUE, allow=1))
stop("bad input for argument 'n'")
- if(any(location <= 0)) stop("argument 'location' must be positive")
- if(any(shape <= 0)) stop("argument 'shape' must be positive")
+ if (any(location <= 0)) stop("argument 'location' must be positive")
+ if (any(shape <= 0)) stop("argument 'shape' must be positive")
location / runif(n)^(1/shape)
}
pareto1 = function(lshape="loge", earg=list(), location=NULL) {
- if(mode(lshape) != "character" && mode(lshape) != "name")
+ if (mode(lshape) != "character" && mode(lshape) != "name")
lshape = as.character(substitute(lshape))
- if(is.Numeric(location) && location <= 0)
+ if (is.Numeric(location) && location <= 0)
stop("argument 'location' must be positive")
- if(!is.list(earg)) earg = list()
+ if (!is.list(earg)) earg = list()
new("vglmff",
- blurb=c("Pareto distribution f(y) = shape * location^shape / y^(shape+1),",
+ blurb = c("Pareto distribution f(y) = shape * location^shape / y^(shape+1),",
" 0<location<y, shape>0\n",
"Link: ", namesof("shape", lshape, earg=earg), "\n", "\n",
"Mean: location*shape/(shape-1) for shape>1"),
initialize=eval(substitute(expression({
- if(ncol(cbind(y)) != 1)
+ if (ncol(cbind(y)) != 1)
stop("response must be a vector or a one-column matrix")
predictors.names = namesof("shape", .lshape, earg=.earg, tag=FALSE)
- locationhat = if(!length( .location)) {
+ locationhat = if (!length( .location)) {
locationEstimated = TRUE
min(y) # - .smallno
} else {
locationEstimated = FALSE
.location
}
- if(any(y < locationhat))
+ if (any(y < locationhat))
stop("the value of location is too high (requires 0 < location < min(y))")
extra$location = locationhat
extra$locationEstimated = locationEstimated
- if(!length(etastart)) {
+ if (!length(etastart)) {
k.init = (y + 1/8) / (y - locationhat + 1/8)
etastart = theta2eta(k.init, .lshape, earg= .earg)
}
@@ -8077,7 +8087,7 @@ rpareto = function(n, location, shape) {
location = extra$location
ifelse(k>1, k * location / (k-1), NA)
}, list( .lshape=lshape, .earg=earg ))),
- last=eval(substitute(expression({
+ last = eval(substitute(expression({
misc$link = c(k= .lshape)
misc$earg = list(k = .earg)
misc$location = extra$location # Use this for prediction
@@ -8086,7 +8096,7 @@ rpareto = function(n, location, shape) {
function(mu,y,w,residuals= FALSE,eta, extra=NULL) {
k = eta2theta(eta, .lshape, earg= .earg)
location = extra$location
- if(residuals) stop("loglikelihood residuals not implemented yet") else {
+ if (residuals) stop("loglikelihood residuals not implemented yet") else {
sum(w * (log(k) + k * log(location) - (k+1) * log(y )))
@@ -8110,10 +8120,10 @@ rpareto = function(n, location, shape) {
dtpareto = function(x, lower, upper, shape) {
- if(!is.Numeric(x)) stop("bad input for argument 'x'")
- if(!is.Numeric(lower, pos=TRUE)) stop("argument 'lower' must be positive")
- if(!is.Numeric(upper, pos=TRUE)) stop("argument 'upper' must be positive")
- if(!is.Numeric(shape, pos=TRUE)) stop("argument 'shape' must be positive")
+ if (!is.Numeric(x)) stop("bad input for argument 'x'")
+ if (!is.Numeric(lower, pos=TRUE)) stop("argument 'lower' must be positive")
+ if (!is.Numeric(upper, pos=TRUE)) stop("argument 'upper' must be positive")
+ if (!is.Numeric(shape, pos=TRUE)) stop("argument 'shape' must be positive")
L = max(length(x), length(lower), length(upper), length(shape))
x = rep(x, len=L); lower = rep(lower, len=L); upper = rep(upper, len=L);
shape= rep(shape, len=L)
@@ -8122,10 +8132,10 @@ dtpareto = function(x, lower, upper, shape) {
}
ptpareto = function(q, lower, upper, shape) {
- if(!is.Numeric(q)) stop("bad input for argument 'q'")
- if(!is.Numeric(lower, pos=TRUE)) stop("argument 'lower' must be positive")
- if(!is.Numeric(upper, pos=TRUE)) stop("argument 'upper' must be positive")
- if(!is.Numeric(shape, pos=TRUE)) stop("argument 'shape' must be positive")
+ if (!is.Numeric(q)) stop("bad input for argument 'q'")
+ if (!is.Numeric(lower, pos=TRUE)) stop("argument 'lower' must be positive")
+ if (!is.Numeric(upper, pos=TRUE)) stop("argument 'upper' must be positive")
+ if (!is.Numeric(shape, pos=TRUE)) stop("argument 'shape' must be positive")
L = max(length(q), length(lower), length(upper), length(shape))
q = rep(q, len=L); lower = rep(lower, len=L); upper = rep(upper, len=L);
shape= rep(shape, len=L)
@@ -8136,20 +8146,20 @@ ptpareto = function(q, lower, upper, shape) {
}
qtpareto = function(p, lower, upper, shape) {
- if(!is.Numeric(p, posit=TRUE)) stop("bad input for argument 'p'")
- if(!is.Numeric(lower, pos=TRUE)) stop("argument 'lower' must be positive")
- if(!is.Numeric(upper, pos=TRUE)) stop("argument 'upper' must be positive")
- if(!is.Numeric(shape, pos=TRUE)) stop("argument 'shape' must be positive")
- if(max(p) >= 1) stop("argument 'p' must be between 0 and 1")
+ if (!is.Numeric(p, posit=TRUE)) stop("bad input for argument 'p'")
+ if (!is.Numeric(lower, pos=TRUE)) stop("argument 'lower' must be positive")
+ if (!is.Numeric(upper, pos=TRUE)) stop("argument 'upper' must be positive")
+ if (!is.Numeric(shape, pos=TRUE)) stop("argument 'shape' must be positive")
+ if (max(p) >= 1) stop("argument 'p' must be between 0 and 1")
lower / (1 - p*(1-(lower/upper)^shape))^(1/shape)
}
rtpareto = function(n, lower, upper, shape) {
- if(!is.Numeric(n, posit=TRUE, integ=TRUE, allow=1))
+ if (!is.Numeric(n, posit=TRUE, integ=TRUE, allow=1))
stop("bad input for argument 'n'")
- if(!is.Numeric(lower, pos=TRUE)) stop("argument 'lower' must be positive")
- if(!is.Numeric(upper, pos=TRUE)) stop("argument 'upper' must be positive")
- if(!is.Numeric(shape, pos=TRUE)) stop("argument 'shape' must be positive")
+ if (!is.Numeric(lower, pos=TRUE)) stop("argument 'lower' must be positive")
+ if (!is.Numeric(upper, pos=TRUE)) stop("argument 'upper' must be positive")
+ if (!is.Numeric(shape, pos=TRUE)) stop("argument 'shape' must be positive")
lower / (1 - runif(n)*(1-(lower/upper)^shape))^(1/shape)
}
@@ -8158,43 +8168,43 @@ rtpareto = function(n, lower, upper, shape) {
tpareto1 = function(lower, upper, lshape="loge", earg=list(), ishape=NULL,
method.init=1) {
- if(mode(lshape) != "character" && mode(lshape) != "name")
+ if (mode(lshape) != "character" && mode(lshape) != "name")
lshape = as.character(substitute(lshape))
- if(!is.Numeric(lower, posit=TRUE, allow=1))
+ if (!is.Numeric(lower, posit=TRUE, allow=1))
stop("bad input for argument 'lower'")
- if(!is.Numeric(upper, posit=TRUE, allow=1))
+ if (!is.Numeric(upper, posit=TRUE, allow=1))
stop("bad input for argument 'upper'")
- if(lower >= upper)
+ if (lower >= upper)
stop("lower < upper is required")
- if(length(ishape) && !is.Numeric(ishape, posit=TRUE))
+ if (length(ishape) && !is.Numeric(ishape, posit=TRUE))
stop("bad input for argument 'ishape'")
- if(!is.list(earg)) earg = list()
- if(!is.Numeric(method.init, allow=1, integ=TRUE, posit=TRUE) ||
+ if (!is.list(earg)) earg = list()
+ if (!is.Numeric(method.init, allow=1, integ=TRUE, posit=TRUE) ||
method.init > 2)
stop("'method.init' must be 1 or 2")
new("vglmff",
- blurb=c("Truncated Pareto distribution f(y) = shape * lower^shape /",
+ blurb = c("Truncated Pareto distribution f(y) = shape * lower^shape /",
"(y^(shape+1) * (1-(lower/upper)^shape)),",
" 0 < lower < y < upper < Inf, shape>0\n",
"Link: ", namesof("shape", lshape, earg=earg), "\n", "\n",
"Mean: shape*lower^shape*(upper^(1-shape)-lower^(1-shape)) /",
" ((1-shape) * (1-(lower/upper)^shape))"),
initialize=eval(substitute(expression({
- if(ncol(cbind(y)) != 1)
+ if (ncol(cbind(y)) != 1)
stop("response must be a vector or a one-column matrix")
predictors.names = namesof("shape", .lshape, earg=.earg, tag=FALSE)
- if(any(y <= .lower))
+ if (any(y <= .lower))
stop("the value of argument 'lower' is too high ",
"(requires '0 < lower < min(y)')")
extra$lower = .lower
- if(any(y >= .upper))
+ if (any(y >= .upper))
stop("the value of argument 'upper' is too low ",
"(requires 'max(y) < upper')")
extra$upper = .upper
- if(!length(etastart)) {
- shape.init = if(is.Numeric( .ishape)) 0 * y + .ishape else
- if( .method.init == 2) {
+ if (!length(etastart)) {
+ shape.init = if (is.Numeric( .ishape)) 0 * y + .ishape else
+ if ( .method.init == 2) {
0 * y + median(rep((y + 1/8) / (y - .lower + 1/8), times=w))
} else {
tpareto1.Loglikfun = function(shape, y, x, w, extraargs) {
@@ -8219,7 +8229,7 @@ rtpareto = function(n, lower, upper, shape) {
constprop = shape * .lower^shape / (1 - myratio^shape)
constprop * ( .upper^(1-shape) - .lower^(1-shape)) / (1-shape)
}, list( .lshape=lshape, .earg=earg, .lower=lower, .upper=upper ))),
- last=eval(substitute(expression({
+ last = eval(substitute(expression({
misc$link = c(shape= .lshape)
misc$earg = list(shape = .earg)
misc$lower = extra$lower
@@ -8230,7 +8240,7 @@ rtpareto = function(n, lower, upper, shape) {
function(mu,y,w,residuals= FALSE,eta, extra=NULL) {
shape = eta2theta(eta, .lshape, earg= .earg)
myratio = .lower / .upper
- if(residuals) stop("loglikelihood residuals not implemented yet") else
+ if (residuals) stop("loglikelihood residuals not implemented yet") else
sum(w * (log(shape) + shape * log( .lower) - (shape+1) * log(y) -
log1p(-myratio^shape)))
}, list( .lshape=lshape, .earg=earg, .lower=lower, .upper=upper ))),
@@ -8264,12 +8274,12 @@ erfc = function(x)
wald <- function(link.lambda="loge", earg=list(), init.lambda=NULL)
{
- if(mode(link.lambda) != "character" && mode(link.lambda) != "name")
+ if (mode(link.lambda) != "character" && mode(link.lambda) != "name")
link.lambda = as.character(substitute(link.lambda))
- if(!is.list(earg)) earg = list()
+ if (!is.list(earg)) earg = list()
new("vglmff",
- blurb=c("Standard Wald distribution\n\n",
+ blurb = c("Standard Wald distribution\n\n",
"f(y) = sqrt(lambda/(2*pi*y^3)) * exp(-lambda*(y-1)^2/(2*y)), y&lambda>0",
"\n",
"Link: ",
@@ -8277,13 +8287,13 @@ erfc = function(x)
"Mean: ", "1\n",
"Variance: 1 / lambda"),
initialize=eval(substitute(expression({
- if(ncol(cbind(y)) != 1)
+ if (ncol(cbind(y)) != 1)
stop("response must be a vector or a one-column matrix")
- if(any(y <= 0)) stop("Require the response to have positive values")
+ if (any(y <= 0)) stop("Require the response to have positive values")
predictors.names =
namesof("lambda", .link.lambda, earg=.earg, short=TRUE)
- if(!length(etastart)) {
- initlambda = if(length( .init.lambda)) .init.lambda else
+ if (!length(etastart)) {
+ initlambda = if (length( .init.lambda)) .init.lambda else
1 / (0.01 + (y-1)^2)
initlambda = rep(initlambda, len=n)
etastart = cbind(theta2eta(initlambda, link=.link.lambda, earg= .earg))
@@ -8293,14 +8303,14 @@ erfc = function(x)
inverse=function(eta, extra=NULL) {
0*eta + 1
},
- last=eval(substitute(expression({
+ last = eval(substitute(expression({
misc$link = c(lambda = .link.lambda )
misc$earg = list(lambda = .earg )
}), 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)
- if(residuals) stop("loglikelihood residuals not implemented yet") else
+ 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",
@@ -8323,24 +8333,24 @@ erfc = function(x)
tolerance = 1.0e-6,
zero=NULL) {
- if(mode(lshape) != "character" && mode(lshape) != "name")
+ if (mode(lshape) != "character" && mode(lshape) != "name")
lshape = as.character(substitute(lshape))
- if(mode(lscale) != "character" && mode(lscale) != "name")
+ if (mode(lscale) != "character" && mode(lscale) != "name")
lscale = as.character(substitute(lscale))
- if(length(zero) && !is.Numeric(zero, integer=TRUE, posit=TRUE))
+ if (length(zero) && !is.Numeric(zero, integer=TRUE, posit=TRUE))
stop("bad input for argument 'zero'")
- if(!is.Numeric(tolerance, posit=TRUE, allow=1) || tolerance>1.0e-2)
+ if (!is.Numeric(tolerance, posit=TRUE, allow=1) || tolerance>1.0e-2)
stop("bad input for argument 'tolerance'")
- if(!is.Numeric(ishape, posit=TRUE))
+ if (!is.Numeric(ishape, posit=TRUE))
stop("bad input for argument 'ishape'")
- if(length(iscale) && !is.Numeric(iscale, posit=TRUE))
+ if (length(iscale) && !is.Numeric(iscale, posit=TRUE))
stop("bad input for argument 'iscale'")
ishape[ishape==1] = 1.1 # Fails in @deriv
- if(!is.list(escale)) escale = list()
- if(!is.list(eshape)) eshape = list()
+ if (!is.list(escale)) escale = list()
+ if (!is.list(eshape)) eshape = list()
new("vglmff",
- blurb=c("Exponentiated Exponential Distribution\n",
+ blurb = c("Exponentiated Exponential Distribution\n",
"Links: ",
namesof("shape", lshape, earg=eshape), ", ",
namesof("scale", lscale, earg=escale),"\n",
@@ -8349,16 +8359,16 @@ erfc = function(x)
constraints = cm.zero.vgam(constraints, x, .zero, M)
}), list( .zero=zero ))),
initialize=eval(substitute(expression({
- if(ncol(cbind(y)) != 1)
+ if (ncol(cbind(y)) != 1)
stop("response must be a vector or a one-column matrix")
predictors.names =
c(namesof("shape", .lshape, earg=.eshape, short=TRUE),
namesof("scale", .lscale, earg=.escale, short=TRUE))
- if(!length(etastart)) {
- shape.init = if(!is.Numeric( .ishape, posit=TRUE))
+ if (!length(etastart)) {
+ shape.init = if (!is.Numeric( .ishape, posit=TRUE))
stop("argument 'ishape' must be positive") else
rep(.ishape, len=n)
- scale.init = if(length( .iscale)) rep(.iscale, len=n) else
+ scale.init = if (length( .iscale)) rep(.iscale, len=n) else
(digamma(shape.init+1) - digamma(1)) / (y+1/8)
scale.init = rep(weighted.mean(scale.init, w=w), len=n)
etastart = cbind(theta2eta(shape.init, .lshape, earg= .eshape),
@@ -8372,7 +8382,7 @@ erfc = function(x)
(digamma(shape+1)-digamma(1)) / scale
}, list( .lshape=lshape, .lscale=lscale,
.eshape=eshape, .escale=escale ))),
- last=eval(substitute(expression({
+ last = eval(substitute(expression({
misc$link = c("shape"= .lshape, "scale"= .lscale)
misc$earg = list(shape= .eshape, scale= .escale)
misc$expected = TRUE
@@ -8382,7 +8392,7 @@ erfc = function(x)
function(mu, y, w, residuals = FALSE, eta, extra=NULL) {
shape = eta2theta(eta[,1], .lshape, earg= .eshape)
scale = eta2theta(eta[,2], .lscale, earg= .escale)
- if(residuals) stop("loglikelihood residuals not implemented yet") else
+ if (residuals) stop("loglikelihood residuals not implemented yet") else
sum(w * (log(shape) + log(scale) +
(shape-1)*log1p(-exp(-scale*y)) - scale*y))
}, list( .lscale=lscale, .lshape=lshape,
@@ -8403,7 +8413,7 @@ erfc = function(x)
d22 = d12 = rep(as.numeric(NA), len=n)
index2 = abs(shape - 2) > .tolerance # index2 = shape != 1
largeno = 10000
- if(any(index2)) {
+ if (any(index2)) {
Shape = shape[index2]
Shape[abs(Shape-1) < .tolerance] = 1.001 # digamma(0) is undefined
Scale = scale[index2]
@@ -8413,19 +8423,19 @@ erfc = function(x)
d22[index2] = (1 + Shape*(Shape-1)*tmp200/(Shape-2)) / Scale^2 +
Shape*tmp300 / Scale^2
}
- if(any(!index2)) {
+ if (any(!index2)) {
Scale = scale[!index2]
d22[!index2] = (1 + 4 * sum(1/(2 + (0:largeno))^3)) / Scale^2
}
index1 = abs(shape - 1) > .tolerance # index1 = shape != 1
- if(any(index1)) {
+ if (any(index1)) {
Shape = shape[index1]
Scale = scale[index1]
d12[index1] = -(Shape*(digamma(Shape)-digamma(1))/(Shape-1) -
digamma(Shape+1) + digamma(1)) / Scale
}
- if(any(!index1)) {
+ if (any(!index1)) {
Scale = scale[!index1]
d12[!index1] = -sum(1/(2 + (0:largeno))^2) / Scale
}
@@ -8445,34 +8455,34 @@ erfc = function(x)
escale=list(),
iscale=NULL,
ishape=1) {
- if(mode(lscale) != "character" && mode(lscale) != "name")
+ if (mode(lscale) != "character" && mode(lscale) != "name")
lscale = as.character(substitute(lscale))
- if(!is.list(escale)) escale = list()
- if(length(iscale) && !is.Numeric(iscale, posit=TRUE))
+ if (!is.list(escale)) escale = list()
+ if (length(iscale) && !is.Numeric(iscale, posit=TRUE))
stop("bad input for argument 'iscale'")
new("vglmff",
- blurb=c("Exponentiated Exponential Distribution",
+ blurb = c("Exponentiated Exponential Distribution",
" (profile likelihood estimation)\n",
"Links: ",
namesof("scale", lscale, earg=escale), "\n",
"Mean: (digamma(shape+1)-digamma(1))/scale"),
initialize=eval(substitute(expression({
- if(ncol(cbind(y)) != 1)
+ 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)
- if(length(w) != n || !is.Numeric(w, integer=TRUE, posit=TRUE))
+ if (length(w) != n || !is.Numeric(w, integer=TRUE, posit=TRUE))
stop("weights must be a vector of positive integers")
- if(!intercept.only)
+ if (!intercept.only)
stop("this family function only works for an intercept-only, i.e., y ~ 1")
extra$yvector = y
extra$sumw = sum(w)
extra$w = w
- if(!length(etastart)) {
- shape.init = if(!is.Numeric( .ishape, posit=TRUE))
+ if (!length(etastart)) {
+ shape.init = if (!is.Numeric( .ishape, posit=TRUE))
stop("argument 'ishape' must be positive") else
rep(.ishape, len=n)
- scaleinit = if(length( .iscale)) rep(.iscale, len=n) else
+ scaleinit = if (length( .iscale)) rep(.iscale, len=n) else
(digamma(shape.init+1) - digamma(1)) / (y+1/8)
etastart = cbind(theta2eta(scaleinit, .lscale, earg= .escale))
}
@@ -8485,7 +8495,7 @@ erfc = function(x)
(digamma(shape+1)-digamma(1)) / scale
}, list( .lscale=lscale,
.escale=escale ))),
- last=eval(substitute(expression({
+ last = eval(substitute(expression({
misc$link = c("scale"= .lscale)
misc$earg = list(scale= .escale)
temp7 = -expm1(-scale*y)
@@ -8498,7 +8508,7 @@ erfc = function(x)
scale = eta2theta(eta, .lscale, earg= .escale)
temp7 = -expm1(-scale*y)
shape = -extra$sumw / sum(w*log(temp7)) # \gamma(\theta)
- if(residuals) stop("loglikelihood residuals not implemented yet") else
+ if (residuals) stop("loglikelihood residuals not implemented yet") else
sum(w * (log(shape) + log(scale) +
(shape-1)*log1p(-exp(-scale*y)) - scale*y))
}, list( .lscale=lscale, .escale=escale ))),
@@ -8518,7 +8528,7 @@ erfc = function(x)
wz[,iam(1,1,M)] = dtheta.deta(scale, .lscale, earg= .escale)^2 * d11 -
d2theta.deta2(scale, .lscale, earg= .escale) * d1
- if(FALSE && intercept.only) {
+ if (FALSE && intercept.only) {
sumw = sum(w)
for(ii in 1:ncol(wz))
wz[,ii] = sum(wz[,ii]) / sumw
@@ -8539,21 +8549,21 @@ betaffqn.control <- function(save.weight=TRUE, ...)
-if(FALSE)
+ if (FALSE)
betaffqn = function(link="loge", earg=list(),
i1=NULL, i2=NULL, trim=0.05, A=0, B=1)
{
- if(mode(link) != "character" && mode(link) != "name")
+ if (mode(link) != "character" && mode(link) != "name")
link = as.character(substitute(link))
- if(!is.Numeric(A, allow=1) || !is.Numeric(B, allow=1) || A >= B)
+ if (!is.Numeric(A, allow=1) || !is.Numeric(B, allow=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()
+ if (!is.list(earg)) earg = list()
new("vglmff",
- blurb=c("Two-parameter Beta distribution\n",
- if(stdbeta)
+ blurb = c("Two-parameter Beta distribution\n",
+ 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,
@@ -8562,13 +8572,13 @@ if(FALSE)
namesof("shape1", link, earg=earg), ", ",
namesof("shape2", link, earg=earg)),
initialize=eval(substitute(expression({
- if(ncol(cbind(y)) != 1)
+ if (ncol(cbind(y)) != 1)
stop("response must be a vector or a one-column matrix")
- if(min(y) <= .A || max(y) >= .B)
+ 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))
- if(is.numeric(.i1) && is.numeric(.i2)) {
+ 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))
@@ -8576,10 +8586,10 @@ if(FALSE)
}
# For QN update below
- if(length(w) != n || !is.Numeric(w, posit=TRUE))
+ if (length(w) != n || !is.Numeric(w, posit=TRUE))
stop("weights must be a vector of positive weights")
- if(!length(etastart)) {
+ if (!length(etastart)) {
mu1d = mean(y, trim=.trim)
uu = (mu1d-.A) / (.B - .A)
DD = (.B - .A)^2
@@ -8593,7 +8603,7 @@ if(FALSE)
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({
+ last = eval(substitute(expression({
misc$link = c(shape1 = .link, shape2 = .link)
misc$earg = list(shape1 = .earg, shape2 = .earg)
misc$limits = c(.A, .B)
@@ -8604,7 +8614,7 @@ if(FALSE)
function(mu, y, w, residuals= FALSE, eta, extra=NULL){
shapes = eta2theta(eta, .link, earg= .earg)
temp = lbeta(shapes[,1], shapes[,2])
- if(residuals) stop("loglikelihood residuals not implemented yet") else {
+ if (residuals) stop("loglikelihood residuals not implemented yet") else {
@@ -8618,7 +8628,7 @@ if(FALSE)
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) {
+ if (iter == 1) {
etanew = eta
} else {
derivold = derivnew
@@ -8629,7 +8639,7 @@ if(FALSE)
derivnew
}), list( .link=link, .earg=earg, .A=A, .B=B ))),
weight=expression({
- if(iter == 1) {
+ if (iter == 1) {
wznew = cbind(matrix(w, n, M), matrix(0, n, dimm(M)-M))
} else {
wzold = wznew
@@ -8651,21 +8661,21 @@ if(FALSE)
escale=list(),
ilocation=NULL, iscale=NULL,
method.init=1, zero=NULL) {
- if(mode(llocation) != "character" && mode(llocation) != "name")
+ if (mode(llocation) != "character" && mode(llocation) != "name")
llocation = as.character(substitute(llocation))
- if(mode(lscale) != "character" && mode(lscale) != "name")
+ if (mode(lscale) != "character" && mode(lscale) != "name")
lscale = as.character(substitute(lscale))
- if(!is.Numeric(method.init, allow=1, integ=TRUE, posit=TRUE) ||
+ if (!is.Numeric(method.init, allow=1, integ=TRUE, posit=TRUE) ||
method.init > 2) stop("argument 'method.init' must be 1 or 2")
- if(length(zero) && !is.Numeric(zero, integer=TRUE, posit=TRUE))
+ if (length(zero) && !is.Numeric(zero, integer=TRUE, posit=TRUE))
stop("bad input for argument 'zero'")
- if(length(iscale) && !is.Numeric(iscale, posit=TRUE))
+ if (length(iscale) && !is.Numeric(iscale, posit=TRUE))
stop("bad input for argument 'iscale'")
- if(!is.list(elocation)) elocation = list()
- if(!is.list(escale)) escale = list()
+ if (!is.list(elocation)) elocation = list()
+ if (!is.list(escale)) escale = list()
new("vglmff",
- blurb=c("Two-parameter logistic distribution\n\n",
+ blurb = c("Two-parameter logistic distribution\n\n",
"Links: ",
namesof("location", llocation, earg=elocation), ", ",
namesof("scale", lscale, earg=escale),
@@ -8676,23 +8686,23 @@ if(FALSE)
constraints = cm.zero.vgam(constraints, x, .zero, M)
}), list( .zero=zero ))),
initialize=eval(substitute(expression({
- if(ncol(cbind(y)) != 1)
+ if (ncol(cbind(y)) != 1)
stop("response must be a vector or a one-column matrix")
predictors.names =
c(namesof("location", .llocation, earg=.elocation, tag=FALSE),
namesof("scale", .lscale, earg=.escale, tag=FALSE))
- if(!length(etastart)) {
- if( .method.init == 1) {
+ if (!length(etastart)) {
+ if ( .method.init == 1) {
location.init = y
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)
}
- location.init = if(length(.ilocation)) rep(.ilocation, len=n) else
+ location.init = if (length(.ilocation)) rep(.ilocation, len=n) else
rep(location.init, len=n)
- if(.llocation == "loge") location.init = abs(location.init) + 0.001
- scale.init = if(length(.iscale)) rep(.iscale, len=n) else
+ if (.llocation == "loge") location.init = abs(location.init) + 0.001
+ scale.init = if (length(.iscale)) rep(.iscale, len=n) else
rep(1, len=n)
etastart = cbind(
theta2eta(location.init, .llocation, earg= .elocation),
@@ -8705,7 +8715,7 @@ if(FALSE)
eta2theta(eta[,1], .llocation, earg= .elocation)
}, list( .llocation=llocation,
.elocation=elocation, .escale=escale ))),
- last=eval(substitute(expression({
+ last = eval(substitute(expression({
misc$link = c(location=.llocation, scale= .lscale)
misc$earg = list(location= .elocation, scale= .escale)
}), list( .llocation=llocation, .lscale=lscale,
@@ -8714,7 +8724,7 @@ if(FALSE)
function(mu,y,w,residuals= FALSE,eta, extra=NULL) {
location = eta2theta(eta[,1], .llocation, earg= .elocation)
Scale = eta2theta(eta[,2], .lscale, earg= .escale)
- if(residuals) stop("loglikelihood residuals not implemented yet") else {
+ if (residuals) stop("loglikelihood residuals not implemented yet") else {
sum(w * dlogis(x=y, location = location,
scale = Scale, log = TRUE))
}
@@ -8760,35 +8770,35 @@ if(FALSE)
dfmu.init = 3,
method.init=1, zero="(1 + M/2):M") {
- if(!is.Numeric(kappa, posit=TRUE))
+ if (!is.Numeric(kappa, posit=TRUE))
stop("bad input for argument 'kappa'")
- if(length(tau) && max(abs(kappa - sqrt(tau/(1-tau)))) > 1.0e-6)
+ 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")
+ if (mode(llocation) != "character" && mode(llocation) != "name")
llocation = as.character(substitute(llocation))
- if(mode(lscale) != "character" && mode(lscale) != "name")
+ if (mode(lscale) != "character" && mode(lscale) != "name")
lscale = as.character(substitute(lscale))
- if(!is.Numeric(method.init, allow=1, integ=TRUE, posit=TRUE) ||
+ if (!is.Numeric(method.init, allow=1, integ=TRUE, posit=TRUE) ||
method.init > 4) stop("argument 'method.init' must be 1, 2 or ... 4")
- if(length(iscale) && !is.Numeric(iscale, posit=TRUE))
+ if (length(iscale) && !is.Numeric(iscale, posit=TRUE))
stop("bad input for argument 'iscale'")
- if(!is.list(elocation)) elocation = list()
- if(!is.list(escale)) escale = list()
- if(!is.Numeric(shrinkage.init, allow=1) || shrinkage.init < 0 ||
+ if (!is.list(elocation)) elocation = list()
+ if (!is.list(escale)) escale = list()
+ if (!is.Numeric(shrinkage.init, allow=1) || shrinkage.init < 0 ||
shrinkage.init > 1) stop("bad input for argument 'shrinkage.init'")
- if(length(zero) &&
+ if (length(zero) &&
!(is.Numeric(zero, integer=TRUE, posit=TRUE) || is.character(zero )))
stop("bad input for argument 'zero'")
- if(!is.logical(sameScale) || length(sameScale) != 1)
+ if (!is.logical(sameScale) || length(sameScale) != 1)
stop("bad input for argument 'sameScale'")
- if(!is.logical(parallelLocation) || length(parallelLocation) != 1)
+ if (!is.logical(parallelLocation) || length(parallelLocation) != 1)
stop("bad input for argument 'parallelLocation'")
fittedMean = FALSE
- if(!is.logical(fittedMean) || length(fittedMean) != 1)
+ if (!is.logical(fittedMean) || length(fittedMean) != 1)
stop("bad input for argument 'fittedMean'")
new("vglmff",
- blurb=c("Two-parameter asymmetric Laplace distribution\n\n",
+ blurb = c("Two-parameter asymmetric Laplace distribution\n\n",
"Links: ",
namesof("location", llocation, earg=elocation), ", ",
namesof("scale", lscale, earg=escale),
@@ -8798,24 +8808,24 @@ if(FALSE)
"Variance: scale^2 * (1 + kappa^4) / (2 * kappa^2)"),
constraints=eval(substitute(expression({
.ZERO = .zero
- if(is.character(.ZERO)) .ZERO = eval(parse(text = .ZERO))
+ if (is.character(.ZERO)) .ZERO = eval(parse(text = .ZERO))
.PARALLEL = .parallelLocation
- parHmat = if(is.logical(.PARALLEL) && .PARALLEL)
+ parHmat = if (is.logical(.PARALLEL) && .PARALLEL)
matrix(1, M/2, 1) else diag(M/2)
- scaleHmat = if(is.logical(.sameScale) && .sameScale)
+ scaleHmat = if (is.logical(.sameScale) && .sameScale)
matrix(1, M/2, 1) else diag(M/2)
mycmatrix = cbind(rbind(parHmat, 0*parHmat),
rbind(0*scaleHmat, scaleHmat))
constraints=cm.vgam(mycmatrix, x, .PARALLEL, constraints, int=FALSE)
constraints = cm.zero.vgam(constraints, x, .ZERO, M)
- if(.PARALLEL && names(constraints)[1] == "(Intercept)") {
+ if (.PARALLEL && names(constraints)[1] == "(Intercept)") {
parHmat = diag(M/2)
mycmatrix = cbind(rbind(parHmat, 0*parHmat),
rbind(0*scaleHmat, scaleHmat))
constraints[["(Intercept)"]] = mycmatrix
}
- if(is.logical(.sameScale) && .sameScale &&
+ if (is.logical(.sameScale) && .sameScale &&
names(constraints)[1] == "(Intercept)") {
temp3 = constraints[["(Intercept)"]]
temp3 = cbind(temp3[,1:(M/2)], rbind(0*scaleHmat, scaleHmat))
@@ -8826,7 +8836,7 @@ if(FALSE)
initialize=eval(substitute(expression({
extra$kappa = .kappa
extra$tau = extra$kappa^2 / (1 + extra$kappa^2)
- if(ncol(y <- cbind(y)) != 1)
+ if (ncol(y <- cbind(y)) != 1)
stop("response must be a vector or a one-column matrix")
extra$M = M = 2 * length(extra$kappa)
extra$n = n
@@ -8839,14 +8849,14 @@ if(FALSE)
namesof(if(M==2) "scale" else paste("scale", 1:(M/2), sep=""),
.lscale, earg=.escale, tag=FALSE))
- if(!length(etastart)) {
- if( .method.init == 1) {
+ if (!length(etastart)) {
+ if ( .method.init == 1) {
location.init = weighted.mean(y, w)
scale.init = sqrt(var(y) / 2)
- } else if( .method.init == 2) {
+ } else if ( .method.init == 2) {
location.init = median(y)
scale.init = sqrt(sum(w*abs(y-median(y))) / (sum(w) *2))
- } else if( .method.init == 3) {
+ } else if ( .method.init == 3) {
fit500 = vsmooth.spline(x=x[,min(ncol(x),2)], y=y, w=w,
df= .dfmu.init)
location.init = c(predict(fit500, x=x[,min(ncol(x),2)])$y)
@@ -8856,10 +8866,10 @@ if(FALSE)
location.init = (1- .sinit)*y + .sinit * use.this
scale.init = sqrt(sum(w*abs(y-median(y ))) / (sum(w) *2))
}
- location.init = if(length(.ilocation)) rep(.ilocation, len=n) else
+ location.init = if (length(.ilocation)) rep(.ilocation, len=n) else
rep(location.init, len=n)
location.init = matrix(location.init, n, M/2)
- scale.init = if(length(.iscale)) rep(.iscale, len=n) else
+ scale.init = if (length(.iscale)) rep(.iscale, len=n) else
rep(scale.init, len=n)
scale.init = matrix(scale.init, n, M/2)
etastart =
@@ -8873,7 +8883,7 @@ if(FALSE)
.llocation=llocation, .lscale=lscale, .kappa=kappa,
.ilocation=ilocation, .iscale=iscale ))),
inverse=eval(substitute(function(eta, extra=NULL) {
- if( .fittedMean) {
+ if ( .fittedMean) {
kappamat = matrix(extra$kappa, extra$n, extra$M/2, byrow=TRUE)
location = eta2theta(eta[,1:(extra$M/2),drop=FALSE],
.llocation, earg= .elocation)
@@ -8888,7 +8898,7 @@ if(FALSE)
}, list( .elocation=elocation, .llocation=llocation,
.fittedMean=fittedMean, .escale=escale, .lscale=lscale,
.kappa=kappa ))),
- last=eval(substitute(expression({
+ last = eval(substitute(expression({
misc$link = c(location= .llocation, scale= .lscale)
misc$earg = list(location= .elocation, scale= .escale)
misc$expected = TRUE
@@ -8910,7 +8920,7 @@ if(FALSE)
location = eta2theta(eta[,1:(extra$M/2),drop=FALSE],
.llocation, earg= .elocation)
Scale = eta2theta(eta[,(1+extra$M/2):extra$M], .lscale, earg= .escale)
- if(residuals) stop("loglikelihood residuals not implemented yet") else {
+ if (residuals) stop("loglikelihood residuals not implemented yet") else {
sum(w * dalap(x=c(ymat), location=c(location),
scale=c(Scale), kappa=c(kappamat), log=TRUE))
}
@@ -8966,30 +8976,30 @@ alaplace1.control <- function(maxit=300, ...)
method.init=1, zero=NULL) {
- if(!is.Numeric(kappa, posit=TRUE))
+ if (!is.Numeric(kappa, posit=TRUE))
stop("bad input for argument 'kappa'")
- if(length(tau) && max(abs(kappa - sqrt(tau/(1-tau)))) > 1.0e-6)
+ 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")
+ if (mode(llocation) != "character" && mode(llocation) != "name")
llocation = as.character(substitute(llocation))
- if(!is.Numeric(method.init, allow=1, integ=TRUE, posit=TRUE) ||
+ if (!is.Numeric(method.init, allow=1, integ=TRUE, posit=TRUE) ||
method.init > 4) stop("argument 'method.init' must be 1, 2 or ... 4")
- if(!is.list(elocation)) elocation = list()
- if(!is.Numeric(shrinkage.init, allow=1) || shrinkage.init < 0 ||
+ if (!is.list(elocation)) elocation = list()
+ if (!is.Numeric(shrinkage.init, allow=1) || shrinkage.init < 0 ||
shrinkage.init > 1) stop("bad input for argument 'shrinkage.init'")
- if(length(zero) &&
+ if (length(zero) &&
!(is.Numeric(zero, integer=TRUE, posit=TRUE) || is.character(zero )))
stop("bad input for argument 'zero'")
- if(!is.Numeric(Scale.arg, posit=TRUE))
+ if (!is.Numeric(Scale.arg, posit=TRUE))
stop("bad input for argument 'Scale.arg'")
- if(!is.logical(parallelLocation) || length(parallelLocation) != 1)
+ if (!is.logical(parallelLocation) || length(parallelLocation) != 1)
stop("bad input for argument 'parallelLocation'")
fittedMean = FALSE
- if(!is.logical(fittedMean) || length(fittedMean) != 1)
+ if (!is.logical(fittedMean) || length(fittedMean) != 1)
stop("bad input for argument 'fittedMean'")
new("vglmff",
- blurb=c("One-parameter asymmetric Laplace distribution\n\n",
+ blurb = c("One-parameter asymmetric Laplace distribution\n\n",
"Links: ",
namesof("location", llocation, earg=elocation),
"\n", "\n",
@@ -9007,7 +9017,7 @@ alaplace1.control <- function(maxit=300, ...)
extra$Scale = rep( .Scale.arg, length=M)
extra$kappa = rep( .kappa, length=M)
extra$tau = extra$kappa^2 / (1 + extra$kappa^2)
- if(ncol(y <- cbind(y)) != 1)
+ if (ncol(y <- cbind(y)) != 1)
stop("response must be a vector or a one-column matrix")
extra$n = n
extra$y.names = y.names = paste("tau=", round(extra$tau, dig=.digt),
@@ -9016,12 +9026,12 @@ alaplace1.control <- function(maxit=300, ...)
predictors.names = namesof(paste("quantile(", y.names, ")", sep=""),
.llocation, earg=.elocation, tag=FALSE)
- if(!length(etastart)) {
- if( .method.init == 1) {
+ if (!length(etastart)) {
+ if ( .method.init == 1) {
location.init = weighted.mean(y, w)
- } else if( .method.init == 2) {
+ } else if ( .method.init == 2) {
location.init = median(y)
- } else if( .method.init == 3) {
+ } else if ( .method.init == 3) {
fit500 = vsmooth.spline(x=x[,min(ncol(x),2)], y=y, w=w,
df= .dfmu.init)
location.init = c(predict(fit500, x=x[,min(ncol(x),2)])$y)
@@ -9029,10 +9039,10 @@ alaplace1.control <- function(maxit=300, ...)
use.this = weighted.mean(y, w)
location.init = (1- .sinit)*y + .sinit * use.this
}
- location.init = if(length(.ilocation)) rep(.ilocation, len=n) else
+ location.init = if (length(.ilocation)) rep(.ilocation, len=n) else
rep(location.init, len=n)
location.init = matrix(location.init, n, M)
- if( .llocation == "loge") location.init = abs(location.init)
+ if ( .llocation == "loge") location.init = abs(location.init)
etastart =
cbind(theta2eta(location.init, .llocation, earg= .elocation))
}
@@ -9043,21 +9053,21 @@ alaplace1.control <- function(maxit=300, ...)
.llocation=llocation, .kappa=kappa,
.ilocation=ilocation ))),
inverse=eval(substitute(function(eta, extra=NULL) {
- if( .fittedMean) {
+ if ( .fittedMean) {
kappamat = matrix(extra$kappa, extra$n, extra$M, byrow=TRUE)
location = eta2theta(eta, .llocation, earg= .elocation)
Scale = matrix(extra$Scale, extra$n, extra$M, byrow=TRUE)
location + Scale * (1/kappamat - kappamat)
} else {
location = eta2theta(eta, .llocation, earg= .elocation)
- if(length(location) > extra$n)
+ if (length(location) > extra$n)
dimnames(location) = list(dimnames(eta)[[1]], extra$y.names)
location
}
}, list( .elocation=elocation, .llocation=llocation,
.fittedMean=fittedMean, .Scale.arg=Scale.arg,
.kappa=kappa ))),
- last=eval(substitute(expression({
+ last = eval(substitute(expression({
misc$link = c(location= .llocation)
misc$earg = list(location= .elocation)
misc$expected = TRUE
@@ -9078,7 +9088,7 @@ alaplace1.control <- function(maxit=300, ...)
kappamat = matrix(extra$kappa, extra$n, extra$M, byrow=TRUE)
location = eta2theta(eta, .llocation, earg= .elocation)
Scale = matrix(extra$Scale, extra$n, extra$M, byrow=TRUE)
- if(residuals) stop("loglikelihood residuals not implemented yet") else {
+ if (residuals) stop("loglikelihood residuals not implemented yet") else {
sum(w * dalap(x=c(ymat), location=c(location),
scale=c(Scale), kappa=c(kappamat), log=TRUE))
}
@@ -9114,24 +9124,24 @@ alaplace1.control <- function(maxit=300, ...)
elocation=list(), escale=list(), ekappa=list(),
ilocation=NULL, iscale=NULL, ikappa=1.0,
method.init=1, zero=2:3) {
- if(mode(llocation) != "character" && mode(llocation) != "name")
+ if (mode(llocation) != "character" && mode(llocation) != "name")
llocation = as.character(substitute(llocation))
- if(mode(lscale) != "character" && mode(lscale) != "name")
+ if (mode(lscale) != "character" && mode(lscale) != "name")
lscale = as.character(substitute(lscale))
- if(mode(lkappa) != "character" && mode(lkappa) != "name")
+ if (mode(lkappa) != "character" && mode(lkappa) != "name")
lkappa = as.character(substitute(lkappa))
- if(!is.Numeric(method.init, allow=1, integ=TRUE, posit=TRUE) ||
+ if (!is.Numeric(method.init, allow=1, integ=TRUE, posit=TRUE) ||
method.init > 2) stop("argument 'method.init' must be 1 or 2")
- if(length(zero) && !is.Numeric(zero, integer=TRUE, posit=TRUE))
+ if (length(zero) && !is.Numeric(zero, integer=TRUE, posit=TRUE))
stop("bad input for argument 'zero'")
- if(length(iscale) && !is.Numeric(iscale, posit=TRUE))
+ if (length(iscale) && !is.Numeric(iscale, posit=TRUE))
stop("bad input for argument 'iscale'")
- if(!is.list(elocation)) elocation = list()
- if(!is.list(escale)) escale = list()
- if(!is.list(ekappa)) ekappa = list()
+ if (!is.list(elocation)) elocation = list()
+ if (!is.list(escale)) escale = list()
+ if (!is.list(ekappa)) ekappa = list()
new("vglmff",
- blurb=c("Three-parameter asymmetric Laplace distribution\n\n",
+ blurb = c("Three-parameter asymmetric Laplace distribution\n\n",
"Links: ",
namesof("location", llocation, earg=elocation), ", ",
namesof("scale", lscale, earg=escale), ", ",
@@ -9144,25 +9154,25 @@ alaplace1.control <- function(maxit=300, ...)
constraints = cm.zero.vgam(constraints, x, .zero, M)
}), list( .zero=zero ))),
initialize=eval(substitute(expression({
- if(ncol(cbind(y)) != 1)
+ if (ncol(cbind(y)) != 1)
stop("response must be a vector or a one-column matrix")
predictors.names =
c(namesof("location", .llocation, earg=.elocation, tag=FALSE),
namesof("scale", .lscale, earg=.escale, tag=FALSE),
namesof("kappa", .lkappa, earg=.ekappa, tag=FALSE))
- if(!length(etastart)) {
- kappa.init = if(length( .ikappa)) rep( .ikappa, len=n) else
+ if (!length(etastart)) {
+ kappa.init = if (length( .ikappa)) rep( .ikappa, len=n) else
rep( 1.0, len=n)
- if( .method.init == 1) {
+ if ( .method.init == 1) {
location.init = median(y)
scale.init = sqrt(var(y) / 2)
} else {
location.init = y
scale.init = sqrt(sum(w*abs(y-median(y ))) / (sum(w) *2))
}
- location.init = if(length(.ilocation)) rep(.ilocation, len=n) else
+ location.init = if (length(.ilocation)) rep(.ilocation, len=n) else
rep(location.init, len=n)
- scale.init = if(length(.iscale)) rep(.iscale, len=n) else
+ scale.init = if (length(.iscale)) rep(.iscale, len=n) else
rep(scale.init, len=n)
etastart =
cbind(theta2eta(location.init, .llocation, earg= .elocation),
@@ -9181,7 +9191,7 @@ alaplace1.control <- function(maxit=300, ...)
}, list( .elocation=elocation, .llocation=llocation,
.escale=escale, .lscale=lscale,
.ekappa=ekappa, .lkappa=lkappa ))),
- last=eval(substitute(expression({
+ last = eval(substitute(expression({
misc$link = c(location= .llocation, scale= .lscale, kappa= .lkappa)
misc$earg = list(location= .elocation, scale= .escale, kappa= .ekappa)
misc$expected = TRUE
@@ -9193,7 +9203,7 @@ alaplace1.control <- function(maxit=300, ...)
location = eta2theta(eta[,1], .llocation, earg= .elocation)
Scale = eta2theta(eta[,2], .lscale, earg= .escale)
kappamat = eta2theta(eta[,3], .lkappa, earg= .ekappa)
- if(residuals) stop("loglikelihood residuals not implemented yet") else {
+ if (residuals) stop("loglikelihood residuals not implemented yet") else {
sum(w * dalap(x=y, location=location,
scale=Scale, kappa=kappamat, log=TRUE))
}
@@ -9242,16 +9252,16 @@ alaplace1.control <- function(maxit=300, ...)
dlaplace = function(x, location=0, scale=1, log = FALSE) {
- if(!is.logical(log.arg <- 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)
+ if (log.arg) logdensity else exp(logdensity)
}
plaplace = function(q, location=0, scale=1) {
- if(!is.Numeric(scale, posit=TRUE))
+ if (!is.Numeric(scale, posit=TRUE))
stop("argument 'scale' must be positive")
zedd = (q-location) / scale
L = max(length(q), length(location), length(scale))
@@ -9260,7 +9270,7 @@ plaplace = function(q, location=0, scale=1) {
}
qlaplace = function(p, location=0, scale=1) {
- if(!is.Numeric(scale, posit=TRUE))
+ if (!is.Numeric(scale, posit=TRUE))
stop("argument 'scale' must be positive")
L = max(length(p), length(location), length(scale))
p = rep(p, len=L); location = rep(location, len=L); scale= rep(scale, len=L)
@@ -9268,9 +9278,9 @@ qlaplace = function(p, location=0, scale=1) {
}
rlaplace = function(n, location=0, scale=1) {
- if(!is.Numeric(n, posit=TRUE, integ=TRUE, allow=1))
+ if (!is.Numeric(n, posit=TRUE, integ=TRUE, allow=1))
stop("bad input for argument 'n'")
- if(!is.Numeric(scale, posit=TRUE)) stop("'scale' must be positive")
+ if (!is.Numeric(scale, posit=TRUE)) stop("'scale' must be positive")
location = rep(location, len=n); scale= rep(scale, len=n)
r = runif(n)
location - sign(r-0.5) * scale * log(2*ifelse(r < 0.5, r, 1-r))
@@ -9281,21 +9291,21 @@ rlaplace = function(n, location=0, scale=1) {
elocation=list(), escale=list(),
ilocation=NULL, iscale=NULL,
method.init=1, zero=2) {
- if(mode(llocation) != "character" && mode(llocation) != "name")
+ if (mode(llocation) != "character" && mode(llocation) != "name")
llocation = as.character(substitute(llocation))
- if(mode(lscale) != "character" && mode(lscale) != "name")
+ if (mode(lscale) != "character" && mode(lscale) != "name")
lscale = as.character(substitute(lscale))
- if(!is.Numeric(method.init, allow=1, integ=TRUE, posit=TRUE) ||
+ if (!is.Numeric(method.init, allow=1, integ=TRUE, posit=TRUE) ||
method.init > 3) stop("argument 'method.init' must be 1 or 2 or 3")
- if(length(zero) && !is.Numeric(zero, integer=TRUE, posit=TRUE))
+ if (length(zero) && !is.Numeric(zero, integer=TRUE, posit=TRUE))
stop("bad input for argument 'zero'")
- if(!is.list(elocation)) elocation = list()
- if(!is.list(escale)) escale = list()
- if(length(iscale) && !is.Numeric(iscale, posit=TRUE))
+ if (!is.list(elocation)) elocation = list()
+ if (!is.list(escale)) escale = list()
+ if (length(iscale) && !is.Numeric(iscale, posit=TRUE))
stop("bad input for argument 'iscale'")
new("vglmff",
- blurb=c("Two-parameter Laplace distribution\n\n",
+ blurb = c("Two-parameter Laplace distribution\n\n",
"Links: ",
namesof("location", llocation, earg=elocation), ", ",
namesof("scale", lscale, earg=escale),
@@ -9306,25 +9316,25 @@ rlaplace = function(n, location=0, scale=1) {
constraints = cm.zero.vgam(constraints, x, .zero, M)
}), list( .zero=zero ))),
initialize=eval(substitute(expression({
- if(ncol(cbind(y)) != 1)
+ if (ncol(cbind(y)) != 1)
stop("response must be a vector or a one-column matrix")
predictors.names =
c(namesof("location", .llocation, earg=.elocation, tag=FALSE),
namesof("scale", .lscale, earg=.escale, tag=FALSE))
- if(!length(etastart)) {
- if( .method.init == 1) {
+ if (!length(etastart)) {
+ if ( .method.init == 1) {
location.init = median(y)
scale.init = sqrt(var(y) / 2)
- } else if( .method.init == 2) {
+ } else if ( .method.init == 2) {
location.init = weighted.mean(y, w)
scale.init = sqrt(var(y) / 2)
} else {
location.init = median(y)
scale.init = sqrt(sum(w*abs(y-median(y ))) / (sum(w) *2))
}
- location.init = if(length(.ilocation)) rep(.ilocation, len=n) else
+ location.init = if (length(.ilocation)) rep(.ilocation, len=n) else
rep(location.init, len=n)
- scale.init = if(length(.iscale)) rep(.iscale, len=n) else
+ scale.init = if (length(.iscale)) rep(.iscale, len=n) else
rep(scale.init, len=n)
etastart =
cbind(theta2eta(location.init, .llocation, earg= .elocation),
@@ -9337,7 +9347,7 @@ rlaplace = function(n, location=0, scale=1) {
inverse=eval(substitute(function(eta, extra=NULL) {
eta2theta(eta[,1], .llocation, earg= .elocation)
}, list( .elocation=elocation, .llocation=llocation ))),
- last=eval(substitute(expression({
+ last = eval(substitute(expression({
misc$link = c(location= .llocation, scale= .lscale)
misc$earg = list(location= .elocation, scale= .escale)
misc$expected = TRUE
@@ -9348,7 +9358,7 @@ rlaplace = function(n, location=0, scale=1) {
function(mu,y,w,residuals= FALSE,eta, extra=NULL) {
location = eta2theta(eta[,1], .llocation, earg= .elocation)
Scale = eta2theta(eta[,2], .lscale, earg= .escale)
- if(residuals) stop("loglikelihood residuals not implemented yet") else {
+ if (residuals) stop("loglikelihood residuals not implemented yet") else {
sum(w * dlaplace(x=y, location=location, scale=Scale, log=TRUE))
}
}, list( .escale=escale, .lscale=lscale,
@@ -9383,47 +9393,53 @@ fff.control <- function(save.weight=TRUE, ...)
}
fff = function(link="loge", earg=list(),
- idf1=NULL, idf2=NULL,
- method.init=1, zero=NULL) {
- if(mode(link) != "character" && mode(link) != "name")
+ idf1=NULL, idf2=NULL, nsimEIM=100, # ncp=0,
+ method.init=1, zero=NULL) {
+ if (mode(link) != "character" && mode(link) != "name")
link = as.character(substitute(link))
- if(!is.Numeric(method.init, allow=1, integ=TRUE, posit=TRUE) ||
+ if (!is.Numeric(method.init, allow=1, integ=TRUE, posit=TRUE) ||
method.init > 2) stop("argument 'method.init' must be 1 or 2")
- if(length(zero) && !is.Numeric(zero, integer=TRUE, posit=TRUE))
+ if (length(zero) && !is.Numeric(zero, integer=TRUE, posit=TRUE))
stop("bad input for argument 'zero'")
- if(!is.list(earg)) earg = list()
+ if (!is.list(earg)) earg = list()
+ if (!is.Numeric(nsimEIM, allow=1, integ=TRUE) || nsimEIM <= 10)
+ stop("'nsimEIM' should be an integer greater than 10")
+ ncp = 0
+ if (any(ncp != 0)) warning("not sure about ncp != 0 wrt dl/dtheta")
new("vglmff",
- blurb=c("F-distribution\n\n",
+ blurb = c("F-distribution\n\n",
"Links: ",
namesof("df1", link, earg=earg), ", ",
namesof("df2", link, earg=earg),
"\n", "\n",
- "Mean: df2/(df2-2) provided df2>2", "\n",
- "Variance: 2*df2^2*(df1+df2-2)/(df1*(df2-2)^2*(df2-4)) provided df2>4"),
+ "Mean: df2/(df2-2) provided df2>2 and ncp=0", "\n",
+ "Variance: ",
+ "2*df2^2*(df1+df2-2)/(df1*(df2-2)^2*(df2-4)) ",
+ "provided df2>4 and ncp=0"),
constraints=eval(substitute(expression({
constraints = cm.zero.vgam(constraints, x, .zero, M)
}), list( .zero=zero ))),
initialize=eval(substitute(expression({
- if(ncol(cbind(y)) != 1)
+ 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( .method.init == 1) {
+ if (!length(etastart)) {
+ if ( .method.init == 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
+ 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]
df1.init = 2*b^2*(b-2)/(var.est*(b-2)^2 * (b-4) - 2*b^2)
}
- df1.init = if(length(.idf1)) rep(.idf1, len=n) else
+ df1.init = if (length(.idf1)) rep(.idf1, len=n) else
rep(df1.init, len=n)
- df2.init = if(length(.idf2)) rep(.idf2, len=n) else rep(1, len=n)
+ df2.init = if (length(.idf2)) rep(.idf2, len=n) else rep(1, len=n)
etastart = cbind(theta2eta(df1.init, .link, earg= .earg),
theta2eta(df2.init, .link, earg= .earg))
}
@@ -9435,18 +9451,22 @@ fff.control <- function(save.weight=TRUE, ...)
ans[df2>2] = df2[df2>2] / (df2[df2>2]-2)
ans
}, list( .link=link, .earg=earg ))),
- last=eval(substitute(expression({
+ last = eval(substitute(expression({
misc$link = c(df1= .link, df2= .link)
misc$earg = list(df1= .earg, df2= .earg)
- }), list( .link=link, .earg=earg ))),
+ misc$nsimEIM = .nsimEIM
+ misc$ncp = .ncp
+ }), list( .link=link, .earg=earg,
+ .ncp=ncp,
+ .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)
- if(residuals) stop("loglikelihood residuals not implemented yet") else {
- sum(w * df(x=y, df1=df1, df2=df2, log=TRUE))
+ if (residuals) stop("loglikelihood residuals not implemented yet") else {
+ sum(w * df(x=y, df1=df1, df2=df2, ncp= .ncp, log=TRUE))
}
- }, list( .link=link, .earg=earg ))),
+ }, list( .link=link, .earg=earg, .ncp=ncp ))),
vfamily=c("fff"),
deriv=eval(substitute(expression({
df1 = eta2theta(eta[,1], .link, earg= .earg)
@@ -9455,34 +9475,41 @@ fff.control <- function(save.weight=TRUE, ...)
0.5*log(y) - 0.5*digamma(0.5*df1) -
0.5*(df1+df2)*(y/df2) / (1 + df1*y/df2) -
0.5*log1p(df1*y/df2)
- ddf1.deta = dtheta.deta(df1, .link, earg= .earg)
dl.ddf2 = 0.5*digamma(0.5*(df1+df2)) - 0.5*df1/df2 -
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)
- if(iter == 1) {
- etanew = eta
- } else {
- derivold = derivnew
- etaold = etanew
- etanew = eta
- }
- derivnew = w * cbind(dl.ddf1 * ddf1.deta,
- dl.ddf2 * ddf2.deta)
- derivnew
+ dthetas.detas = cbind(ddf1.deta, ddf2.deta)
+ w * dthetas.detas * cbind(dl.ddf1, dl.ddf2)
}), list( .link=link, .earg=earg ))),
weight=eval(substitute(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
+ 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)
+ 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) -
+ 0.5*log1p(df1*ysim/df2)
+ dl.ddf2 = 0.5*digamma(0.5*(df1+df2)) - 0.5*df1/df2 -
+ 0.5*digamma(0.5*df2) -
+ 0.5*(df1+df2) * (-df1*ysim/df2^2)/(1 + df1*ysim/df2) -
+ 0.5*log1p(df1*ysim/df2)
+ rm(ysim)
+ temp3 = cbind(dl.ddf1, dl.ddf2)
+ run.varcov = ((ii-1) * run.varcov +
+ temp3[,ind1$row.index]*temp3[,ind1$col.index]) / ii
}
- wznew
- }), list( .link=link, .earg=earg ))))
+ wz = if (intercept.only)
+ matrix(colMeans(run.varcov),
+ n, ncol(run.varcov), byrow=TRUE) else run.varcov
+
+ wz = w * wz * dthetas.detas[,ind1$row] * dthetas.detas[,ind1$col]
+ wz
+ }), list( .link=link, .earg=earg, .nsimEIM=nsimEIM,
+ .ncp = ncp ))))
}
@@ -9491,37 +9518,36 @@ fff.control <- function(save.weight=TRUE, ...)
hyperg = function(N=NULL, D=NULL,
lprob="logit", earg=list(),
iprob=NULL) {
- print("hi 20090409")
- if(mode(lprob) != "character" && mode(lprob) != "name")
+ if (mode(lprob) != "character" && mode(lprob) != "name")
lprob = as.character(substitute(lprob))
inputN = is.Numeric(N, positive=TRUE)
inputD = is.Numeric(D, positive=TRUE)
- if(inputD && inputN)
+ if (inputD && inputN)
stop("only one of 'N' and 'D' is to be inputted")
- if(!inputD && !inputN)
+ if (!inputD && !inputN)
stop("one of 'N' and 'D' needs to be inputted")
- if(!is.list(earg)) earg = list()
+ if (!is.list(earg)) earg = list()
new("vglmff",
- blurb=c("Hypergeometric distribution\n\n",
+ blurb = c("Hypergeometric distribution\n\n",
"Link: ",
namesof("prob", lprob, earg=earg), "\n",
"Mean: D/N\n"),
initialize=eval(substitute(expression({
NCOL = function (x)
- if(is.array(x) && length(dim(x)) > 1 ||
+ if (is.array(x) && length(dim(x)) > 1 ||
is.data.frame(x)) ncol(x) else as.integer(1)
- if(NCOL(y) == 1) {
- if(is.factor(y)) y = y != levels(y)[1]
+ if (NCOL(y) == 1) {
+ if (is.factor(y)) y = y != levels(y)[1]
nn = rep(1, len=n)
- if(!all(y >= 0 & y <= 1))
+ if (!all(y >= 0 & y <= 1))
stop("response values must be in [0, 1]")
mustart = (0.5 + w * y) / (1 + w)
no.successes = w * y
- if(any(abs(no.successes - round(no.successes)) > 0.001))
+ if (any(abs(no.successes - round(no.successes)) > 0.001))
stop("Number of successes must be integer-valued")
- } else if(NCOL(y) == 2) {
- if(any(abs(y - round(y)) > 0.001))
+ } 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)
@@ -9535,8 +9561,8 @@ fff.control <- function(save.weight=TRUE, ...)
extra$Nvector = .N
extra$Dvector = .D
extra$Nunknown = length(extra$Nvector) == 0
- if(!length(etastart)) {
- init.prob = if(length( .iprob)) rep( .iprob, len=n) else mustart
+ if (!length(etastart)) {
+ init.prob = if (length( .iprob)) rep( .iprob, len=n) else mustart
etastart = matrix(init.prob, n, ncol(cbind(y )))
}
@@ -9544,7 +9570,7 @@ fff.control <- function(save.weight=TRUE, ...)
inverse=eval(substitute(function(eta, extra=NULL) {
eta2theta(eta, .lprob, earg= .earg)
}, list( .lprob=lprob, .earg=earg ))),
- last=eval(substitute(expression({
+ last = eval(substitute(expression({
misc$link = c("prob"= .lprob)
misc$earg = list("prob"= .earg)
misc$Dvector = .D
@@ -9559,8 +9585,8 @@ fff.control <- function(save.weight=TRUE, ...)
Dvec = extra$Dvector
prob = mu
yvec = w * y
- if(residuals) stop("loglikelihood residuals not implemented yet") else {
- if(extra$Nunknown) {
+ if (residuals) stop("loglikelihood residuals not implemented yet") else {
+ if (extra$Nunknown) {
tmp12 = Dvec * (1-prob) / prob
@@ -9582,7 +9608,7 @@ fff.control <- function(save.weight=TRUE, ...)
Dvec = extra$Dvector
Nvec = extra$Nvector
yvec = w * y
- if(extra$Nunknown) {
+ if (extra$Nunknown) {
tmp72 = -Dvec / prob^2
tmp12 = Dvec * (1-prob) / prob
dl.dprob = tmp72 * (digamma(1 + tmp12) + digamma(1 + Dvec/prob -w) -
@@ -9594,7 +9620,7 @@ fff.control <- function(save.weight=TRUE, ...)
w * dl.dprob * dprob.deta
}), list( .lprob=lprob, .earg=earg ))),
weight=eval(substitute(expression({
- if(extra$Nunknown) {
+ if (extra$Nunknown) {
tmp722 = tmp72^2
tmp13 = 2*Dvec / prob^3
d2l.dprob2 = tmp722 * (trigamma(1 + tmp12) +
@@ -9623,7 +9649,7 @@ fff.control <- function(save.weight=TRUE, ...)
dbenini = function(x, shape, y0, log=FALSE) {
- if(!is.logical(log.arg <- log))
+ if (!is.logical(log.arg <- log))
stop("bad input for argument 'log'")
rm(log)
@@ -9635,13 +9661,13 @@ dbenini = function(x, shape, y0, log=FALSE) {
tempxok = log(x[xok]/y0[xok])
logdensity[xok] = log(2*shape[xok]) - shape[xok] * tempxok^2 +
log(tempxok) - log(x[xok])
- if(log.arg) logdensity else exp(logdensity)
+ 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, posit=TRUE)) stop("bad input for argument 'shape'")
- if(!is.Numeric(y0, posit=TRUE)) stop("bad input for argument 'y0'")
+ if (!is.Numeric(q)) stop("bad input for argument 'q'")
+ if (!is.Numeric(shape, posit=TRUE)) stop("bad input for argument 'shape'")
+ if (!is.Numeric(y0, posit=TRUE)) stop("bad input for argument 'y0'")
N = max(length(q), length(shape), length(y0))
q = rep(q, len=N); shape = rep(shape, len=N); y0 = rep(y0, len=N);
ans = y0 * 0
@@ -9651,52 +9677,52 @@ pbenini = function(q, shape, y0) {
}
qbenini = function(p, shape, y0) {
- if(!is.Numeric(p, posit=TRUE) || any(p >= 1))
+ if (!is.Numeric(p, posit=TRUE) || any(p >= 1))
stop("bad input for argument 'p'")
- if(!is.Numeric(shape, posit=TRUE)) stop("bad input for argument 'shape'")
- if(!is.Numeric(y0, posit=TRUE)) stop("bad input for argument 'y0'")
+ if (!is.Numeric(shape, posit=TRUE)) stop("bad input for argument 'shape'")
+ if (!is.Numeric(y0, posit=TRUE)) stop("bad input for argument 'y0'")
y0 * exp(sqrt(-log1p(-p) / shape))
}
rbenini = function(n, shape, y0) {
- if(!is.Numeric(n, posit=TRUE, integ=TRUE, allow=1))
+ if (!is.Numeric(n, posit=TRUE, integ=TRUE, allow=1))
stop("bad input for argument 'n'")
- if(!is.Numeric(shape, posit=TRUE)) stop("bad input for argument 'shape'")
- if(!is.Numeric(y0, posit=TRUE)) stop("bad input for argument 'y0'")
+ if (!is.Numeric(shape, posit=TRUE)) stop("bad input for argument 'shape'")
+ if (!is.Numeric(y0, posit=TRUE)) stop("bad input for argument 'y0'")
y0 * exp(sqrt(-log(runif(n)) / shape))
}
benini = function(y0=stop("argument 'y0' must be specified"),
lshape="loge", earg=list(),
ishape=NULL, method.init=1) {
- if(mode(lshape) != "character" && mode(lshape) != "name")
+ if (mode(lshape) != "character" && mode(lshape) != "name")
lshape = as.character(substitute(lshape))
- if(!is.Numeric(method.init, allow=1, integ=TRUE, posit=TRUE) ||
+ if (!is.Numeric(method.init, allow=1, integ=TRUE, posit=TRUE) ||
method.init > 2) stop("argument 'method.init' must be 1 or 2")
- if(!is.Numeric(y0, allow=1, posit=TRUE))
+ if (!is.Numeric(y0, allow=1, posit=TRUE))
stop("bad input for argument 'y0'")
- if(!is.list(earg)) earg = list()
+ if (!is.list(earg)) earg = list()
new("vglmff",
- blurb=c("1-parameter Benini distribution\n\n",
+ blurb = c("1-parameter Benini distribution\n\n",
"Link: ",
namesof("shape", lshape, earg=earg),
"\n", "\n"),
initialize=eval(substitute(expression({
- if(ncol(cbind(y)) != 1)
+ if (ncol(cbind(y)) != 1)
stop("response must be a vector or a one-column matrix")
predictors.names = c(namesof("shape", .lshape, earg=.earg, tag=FALSE))
extra$y0 = .y0
- if(min(y) <= extra$y0) stop("argument 'y0' is too large")
- if(!length(etastart)) {
+ if (min(y) <= extra$y0) stop("argument 'y0' is too large")
+ if (!length(etastart)) {
probs = (1:3) / 4
qofy= quantile(rep(y, times=w), probs=probs) # fails if w != integer
- if( .method.init == 1) {
+ if ( .method.init == 1) {
shape.init = mean(-log1p(-probs) / (log(qofy))^2)
} else {
shape.init = median(-log1p(-probs) / (log(qofy))^2)
}
- shape.init = if(length(.ishape)) rep(.ishape, len=n) else
+ shape.init = if (length(.ishape)) rep(.ishape, len=n) else
rep(shape.init, len=n)
etastart = cbind(theta2eta(shape.init, .lshape, earg= .earg))
}
@@ -9709,7 +9735,7 @@ rbenini = function(n, shape, y0) {
((sqrt(pi) * (1 - pgamma(temp, 0.5 ))) / (2*sqrt(shape)) +
1 - pgamma(temp, 1))
}, list( .lshape=lshape, .earg=earg ))),
- last=eval(substitute(expression({
+ last = eval(substitute(expression({
misc$link = c(shape= .lshape)
misc$earg = list(shape= .earg )
}), list( .lshape=lshape, .earg=earg ))),
@@ -9717,7 +9743,7 @@ rbenini = function(n, shape, y0) {
function(mu,y,w,residuals= FALSE,eta, extra=NULL) {
shape = eta2theta(eta, .lshape, earg= .earg)
y0 = extra$y0
- if(residuals) stop("loglikelihood residuals not implemented yet") else {
+ if (residuals) stop("loglikelihood residuals not implemented yet") else {
sum(w * dbenini(x=y, shape=shape, y0=y0, log=TRUE))
}
}, list( .lshape=lshape, .earg=earg ))),
@@ -9740,12 +9766,12 @@ rbenini = function(n, shape, y0) {
dpolono = function(x, meanlog=0, sdlog=1, bigx=Inf, ...) {
- if(!is.Numeric(x)) stop("bad input for argument 'x'")
- if(!is.Numeric(meanlog)) stop("bad input for argument 'meanlog'")
- if(!is.Numeric(sdlog, posit=TRUE)) stop("bad input for argument 'sdlog'")
- if(length(bigx) != 1)
+ if (!is.Numeric(x)) stop("bad input for argument 'x'")
+ if (!is.Numeric(meanlog)) stop("bad input for argument 'meanlog'")
+ if (!is.Numeric(sdlog, posit=TRUE)) stop("bad input for argument 'sdlog'")
+ if (length(bigx) != 1)
stop("bad input for argument 'bigx'")
- if(bigx < 10)
+ if (bigx < 10)
warning("argument 'bigx' is probably too small")
N = max(length(x), length(meanlog), length(sdlog))
x = rep(x, len=N); meanlog = rep(meanlog, len=N); sdlog = rep(sdlog, len=N)
@@ -9753,8 +9779,8 @@ dpolono = function(x, meanlog=0, sdlog=1, bigx=Inf, ...) {
integrand = function(t, x, meanlog, sdlog)
exp(t*x - exp(t) - 0.5*((t-meanlog)/sdlog)^2)
for(ii in 1:N) {
- if(x[ii] == round(x[ii]) && x[ii] >= 0) {
- if(x[ii] >= bigx) {
+ if (x[ii] == round(x[ii]) && x[ii] >= 0) {
+ if (x[ii] >= bigx) {
zedd = (log(x[ii])-meanlog[ii]) / sdlog[ii]
temp = 1 + (zedd^2 + log(x[ii]) - meanlog[ii] -
1) / (2*x[ii]*(sdlog[ii])^2)
@@ -9762,7 +9788,7 @@ dpolono = function(x, meanlog=0, sdlog=1, bigx=Inf, ...) {
} else {
temp = integrate(f=integrand, lower=-Inf, upper=Inf, x=x[ii],
meanlog=meanlog[ii], sdlog=sdlog[ii], ...)
- if(temp$message == "OK") {
+ if (temp$message == "OK") {
ans[ii] = temp$value / (sqrt(2*pi) * sdlog[ii] *
exp(lgamma(x[ii]+1)))
} else {
@@ -9792,7 +9818,7 @@ rpolono = function(n, meanlog=0, sdlog=1) {
dtriangle = function(x, theta, lower=0, upper=1, log = FALSE) {
- if(!is.logical(log.arg <- log))
+ if (!is.logical(log.arg <- log))
stop("bad input for argument 'log'")
rm(log)
@@ -9810,16 +9836,16 @@ dtriangle = function(x, theta, lower=0, upper=1, log = FALSE) {
logdensity[lower >= upper] = NaN
logdensity[lower > theta] = NaN
logdensity[upper < theta] = NaN
- if(log.arg) logdensity else exp(logdensity)
+ if (log.arg) logdensity else exp(logdensity)
}
rtriangle = function(n, theta, lower=0, upper=1) {
- if(!is.Numeric(n, integ=TRUE,allow=1)) stop("bad input for argument 'n'")
- if(!is.Numeric(theta)) stop("bad input for argument 'theta'")
- if(!is.Numeric(lower)) stop("bad input for argument 'lower'")
- if(!is.Numeric(upper)) stop("bad input for argument 'upper'")
- if(!all(lower < theta & theta < upper))
+ if (!is.Numeric(n, integ=TRUE,allow=1)) stop("bad input for argument 'n'")
+ if (!is.Numeric(theta)) stop("bad input for argument 'theta'")
+ if (!is.Numeric(lower)) stop("bad input for argument 'lower'")
+ if (!is.Numeric(upper)) stop("bad input for argument 'upper'")
+ if (!all(lower < theta & theta < upper))
stop("lower < theta < upper values are required")
N = n
lower = rep(lower, len=N); upper = rep(upper, len=N);
@@ -9833,11 +9859,11 @@ rtriangle = function(n, theta, lower=0, upper=1) {
qtriangle = function(p, theta, lower=0, upper=1) {
- if(!is.Numeric(p, posit=TRUE)) stop("bad input for argument 'p'")
- if(!is.Numeric(theta)) stop("bad input for argument 'theta'")
- if(!is.Numeric(lower)) stop("bad input for argument 'lower'")
- if(!is.Numeric(upper)) stop("bad input for argument 'upper'")
- if(!all(lower < theta & theta < upper))
+ if (!is.Numeric(p, posit=TRUE)) stop("bad input for argument 'p'")
+ if (!is.Numeric(theta)) stop("bad input for argument 'theta'")
+ if (!is.Numeric(lower)) stop("bad input for argument 'lower'")
+ if (!is.Numeric(upper)) stop("bad input for argument 'upper'")
+ if (!all(lower < theta & theta < upper))
stop("lower < theta < upper values are required")
N = max(length(p), length(theta), length(lower), length(upper))
@@ -9845,7 +9871,7 @@ qtriangle = function(p, theta, lower=0, upper=1) {
theta = rep(theta, len=N)
bad = (p < 0) | (p > 1)
- if(any(bad))
+ if (any(bad))
stop("bad input for 'p'")
Neg = (p <= (theta - lower)/(upper - lower))
@@ -9854,7 +9880,7 @@ qtriangle = function(p, theta, lower=0, upper=1) {
ans[ Neg] = lower[ Neg] + sqrt(temp1[ Neg])
Pos = (p >= (theta - lower)/(upper - lower))
- if(any(Pos)) {
+ if (any(Pos)) {
pstar = (p - (theta-lower)/(upper-lower)) / (1 -
(theta-lower)/(upper-lower))
qstar = cbind(1 - sqrt(1-pstar), 1 + sqrt(1-pstar))
@@ -9867,11 +9893,11 @@ qtriangle = function(p, theta, lower=0, upper=1) {
ptriangle = function(q, theta, lower=0, upper=1) {
- if(!is.Numeric(q)) stop("bad input for argument 'q'")
- if(!is.Numeric(theta)) stop("bad input for argument 'theta'")
- if(!is.Numeric(lower)) stop("bad input for argument 'lower'")
- if(!is.Numeric(upper)) stop("bad input for argument 'upper'")
- if(!all(lower < theta & theta < upper))
+ 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))
@@ -9897,34 +9923,34 @@ ptriangle = function(q, theta, lower=0, upper=1) {
link="elogit", earg=if(link=="elogit")
list(min = lower, max = upper) else list(), itheta=NULL)
{
- if(!is.Numeric(lower)) stop("bad input for argument 'lower'")
- if(!is.Numeric(upper)) stop("bad input for argument 'upper'")
- if(!all(lower < upper))
+ if (!is.Numeric(lower)) stop("bad input for argument 'lower'")
+ if (!is.Numeric(upper)) stop("bad input for argument 'upper'")
+ if (!all(lower < upper))
stop("lower < upper values are required")
- if(length(itheta) && !is.Numeric(itheta))
+ if (length(itheta) && !is.Numeric(itheta))
stop("bad input for 'itheta'")
- if(mode(link) != "character" && mode(link) != "name")
+ if (mode(link) != "character" && mode(link) != "name")
link = as.character(substitute(link))
- if(!is.list(earg)) earg = list()
+ if (!is.list(earg)) earg = list()
new("vglmff",
- blurb=c(
+ 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)
+ if (ncol(cbind(y)) != 1)
stop("response must be a vector or a one-column matrix")
extra$lower = rep( .lower, len=n)
extra$upper = rep( .upper, len=n)
- if(any(y <= extra$lower | y >= extra$upper))
+ 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 {
+ if (!length(etastart)) {
+ Theta.init = if (length( .itheta)) .itheta else {
weighted.mean(y, w)
}
Theta.init = rep(Theta.init, length=n)
@@ -9942,7 +9968,7 @@ ptriangle = function(q, theta, lower=0, upper=1) {
upper^3 / 6) / (upper - Theta))) * 2 / (upper-lower)
mu
}, list( .link=link, .earg=earg ))),
- last=eval(substitute(expression({
+ last = eval(substitute(expression({
misc$link = c(theta = .link)
misc$earg = list(theta = .earg)
misc$expected = TRUE
@@ -9952,7 +9978,7 @@ ptriangle = function(q, theta, lower=0, upper=1) {
Theta = eta2theta(eta, .link, earg= .earg )
lower = extra$lower
upper = extra$upper
- if(residuals) stop("loglikelihood residuals not implemented yet") else {
+ if (residuals) stop("loglikelihood residuals not implemented yet") else {
sum(w * dtriangle(x=y, theta=Theta, lower=lower,
upper=upper, log=TRUE))
}
@@ -10007,33 +10033,32 @@ loglaplace1.control <- function(maxit=300, ...)
minquantile = 0, maxquantile = Inf,
method.init=1, zero=NULL) {
- print("loglaplace1 20090406 a")
- if(length(minquantile) != 1)
+ if (length(minquantile) != 1)
stop("bad input for argument 'minquantile'")
- if(length(maxquantile) != 1)
+ if (length(maxquantile) != 1)
stop("bad input for argument 'maxquantile'")
- if(!is.Numeric(rep0, posit=TRUE, allow=1) || rep0 > 1)
+ if (!is.Numeric(rep0, posit=TRUE, allow=1) || rep0 > 1)
stop("bad input for argument 'rep0'")
- if(!is.Numeric(kappa, posit=TRUE))
+ if (!is.Numeric(kappa, posit=TRUE))
stop("bad input for argument 'kappa'")
- if(length(tau) && max(abs(kappa - sqrt(tau/(1-tau)))) > 1.0e-6)
+ 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")
+ if (mode(llocation) != "character" && mode(llocation) != "name")
llocation = as.character(substitute(llocation))
- if(!is.Numeric(method.init, allow=1, integ=TRUE, posit=TRUE) ||
+ if (!is.Numeric(method.init, allow=1, integ=TRUE, posit=TRUE) ||
method.init > 4) stop("argument 'method.init' must be 1, 2 or ... 4")
- if(!is.list(elocation)) elocation = list()
- if(!is.Numeric(shrinkage.init, allow=1) || shrinkage.init < 0 ||
+ if (!is.list(elocation)) elocation = list()
+ if (!is.Numeric(shrinkage.init, allow=1) || shrinkage.init < 0 ||
shrinkage.init > 1) stop("bad input for argument 'shrinkage.init'")
- if(length(zero) &&
+ if (length(zero) &&
!(is.Numeric(zero, integer=TRUE, posit=TRUE) || is.character(zero )))
stop("bad input for argument 'zero'")
- if(!is.Numeric(Scale.arg, posit=TRUE))
+ if (!is.Numeric(Scale.arg, posit=TRUE))
stop("bad input for argument 'Scale.arg'")
- if(!is.logical(parallelLocation) || length(parallelLocation) != 1)
+ if (!is.logical(parallelLocation) || length(parallelLocation) != 1)
stop("bad input for argument 'parallelLocation'")
fittedMean = FALSE
- if(!is.logical(fittedMean) || length(fittedMean) != 1)
+ if (!is.logical(fittedMean) || length(fittedMean) != 1)
stop("bad input for argument 'fittedMean'")
mystring0 = namesof("location", llocation, earg=elocation)
@@ -10042,8 +10067,8 @@ loglaplace1.control <- function(maxit=300, ...)
mystring1 = paste(mychars, collapse="")
new("vglmff",
- blurb=c("One-parameter ",
- if(llocation=="loge") "log-Laplace" else c(llocation, "-Laplace"),
+ blurb = c("One-parameter ",
+ if (llocation=="loge") "log-Laplace" else c(llocation, "-Laplace"),
" distribution\n\n",
"Links: ", mystring0, "\n", "\n",
"Quantiles: ", mystring1),
@@ -10058,7 +10083,7 @@ loglaplace1.control <- function(maxit=300, ...)
extra$Scale = rep( .Scale.arg, length=M)
extra$kappa = rep( .kappa, length=M)
extra$tau = extra$kappa^2 / (1 + extra$kappa^2)
- if(ncol(y <- cbind(y)) != 1)
+ if (ncol(y <- cbind(y)) != 1)
stop("response must be a vector or a one-column matrix")
extra$n = n
extra$y.names = y.names = paste("tau=", round(extra$tau, dig=.digt),
@@ -10068,28 +10093,26 @@ loglaplace1.control <- function(maxit=300, ...)
.llocation, earg=.elocation, tag=FALSE)
- if(FALSE) {
- if(min(y) < 0) stop("negative response values detected")
- if((prop.0. <- weighted.mean(1*(y == 0), w)) >= min(extra$tau))
+ if (FALSE) {
+ if (min(y) < 0) stop("negative response values detected")
+ if ((prop.0. <- weighted.mean(1*(y == 0), w)) >= min(extra$tau))
stop("sample proportion of 0s == ", round(prop.0., dig=4),
" > minimum 'tau' value. Choose larger values for 'tau'.")
- if(.rep0 == 0.5 &&
+ if (.rep0 == 0.5 &&
(ave.tau <- (weighted.mean(1*(y <= 0), w) +
weighted.mean(1*(y <= 1), w))/2) >= min(extra$tau))
warning("the minimum 'tau' value should be greater than ",
round(ave.tau, dig=4))
}
- print("extra$tau")
- print( extra$tau )
- if(!length(etastart)) {
- if( .method.init == 1) {
+ if (!length(etastart)) {
+ if ( .method.init == 1) {
location.init = quantile(rep(y, w), probs= extra$tau) + 1/16
- } else if( .method.init == 2) {
+ } else if ( .method.init == 2) {
location.init = weighted.mean(y, w)
- } else if( .method.init == 3) {
+ } else if ( .method.init == 3) {
location.init = median(y)
- } else if( .method.init == 4) {
+ } else if ( .method.init == 4) {
fit500 = vsmooth.spline(x=x[,min(ncol(x),2)], y=y, w=w,
df= .dfmu.init)
location.init = c(predict(fit500, x=x[,min(ncol(x),2)])$y)
@@ -10097,18 +10120,14 @@ loglaplace1.control <- function(maxit=300, ...)
use.this = weighted.mean(y, w)
location.init = (1- .sinit)*y + .sinit * use.this
}
- location.init = if(length(.ilocation)) rep(.ilocation, len=M) else
+ location.init = if (length(.ilocation)) rep(.ilocation, len=M) else
rep(location.init, len=M)
location.init = matrix(location.init, n, M, byrow=TRUE)
- if( .llocation == "loge")
+ if ( .llocation == "loge")
location.init = abs(location.init)
etastart =
cbind(theta2eta(location.init, .llocation, earg= .elocation))
}
- print("location.init[1:3,]")
- print( location.init[1:3,] )
- print("etastart[1:3,]")
- print( etastart[1:3,] )
}), list( .method.init=method.init,
.dfmu.init=dfmu.init, .rep0 = rep0,
.sinit=shrinkage.init, .digt=digt,
@@ -10117,13 +10136,13 @@ loglaplace1.control <- function(maxit=300, ...)
.ilocation=ilocation ))),
inverse=eval(substitute(function(eta, extra=NULL) {
location.y = eta2theta(eta, .llocation, earg= .elocation)
- if( .fittedMean) {
+ if ( .fittedMean) {
stop("Yet to do: handle 'fittedMean = TRUE'")
kappamat = matrix(extra$kappa, extra$n, extra$M, byrow=TRUE)
Scale = matrix(extra$Scale, extra$n, extra$M, byrow=TRUE)
location.y + Scale * (1/kappamat - kappamat)
} else {
- if(length(location.y) > extra$n)
+ if (length(location.y) > extra$n)
dimnames(location.y) = list(dimnames(eta)[[1]], extra$y.names)
location.y
}
@@ -10134,7 +10153,7 @@ loglaplace1.control <- function(maxit=300, ...)
.minquantile = minquantile, .maxquantile = maxquantile,
.fittedMean=fittedMean, .Scale.arg=Scale.arg,
.kappa=kappa ))),
- last=eval(substitute(expression({
+ last = eval(substitute(expression({
misc$link = c(location= .llocation)
misc$earg = list(location= .elocation)
misc$expected = TRUE
@@ -10160,10 +10179,10 @@ loglaplace1.control <- function(maxit=300, ...)
ymat = matrix(y, extra$n, extra$M)
- if( .llocation == "loge")
+ if ( .llocation == "loge")
ymat = adjust0.loglaplace1(ymat=ymat, y=y, w=w, rep0= .rep0)
w.mat = theta2eta(ymat, .llocation, earg= .elocation) # e.g., logoff()
- if(residuals) stop("loglikelihood residuals not implemented yet") else {
+ if (residuals) stop("loglikelihood residuals not implemented yet") else {
ALDans =
sum(w * dalap(x=c(w.mat), location=c(eta),
scale=c(Scale.w), kappa=c(kappamat), log=TRUE))
@@ -10219,43 +10238,43 @@ loglaplace2.control <- function(save.weight=TRUE, ...)
method.init=1, zero="(1 + M/2):M") {
warning("it is best to use loglaplace1()")
- if(length(nsimEIM) &&
+ if (length(nsimEIM) &&
(!is.Numeric(nsimEIM, allow=1, integ=TRUE) || nsimEIM <= 10))
stop("'nsimEIM' should be an integer greater than 10")
- if(!is.Numeric(rep0, posit=TRUE, allow=1) || rep0 > 1)
+ if (!is.Numeric(rep0, posit=TRUE, allow=1) || rep0 > 1)
stop("bad input for argument 'rep0'")
- if(!is.Numeric(kappa, posit=TRUE))
+ if (!is.Numeric(kappa, posit=TRUE))
stop("bad input for argument 'kappa'")
- if(length(tau) && max(abs(kappa - sqrt(tau/(1-tau)))) > 1.0e-6)
+ 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")
+ if (mode(llocation) != "character" && mode(llocation) != "name")
llocation = as.character(substitute(llocation))
- if(mode(lscale) != "character" && mode(lscale) != "name")
+ if (mode(lscale) != "character" && mode(lscale) != "name")
lscale = as.character(substitute(lscale))
- if(!is.Numeric(method.init, allow=1, integ=TRUE, posit=TRUE) ||
+ if (!is.Numeric(method.init, allow=1, integ=TRUE, posit=TRUE) ||
method.init > 4) stop("argument 'method.init' must be 1, 2 or ... 4")
- if(length(iscale) && !is.Numeric(iscale, posit=TRUE))
+ if (length(iscale) && !is.Numeric(iscale, posit=TRUE))
stop("bad input for argument 'iscale'")
- if(!is.list(elocation)) elocation = list()
- if(!is.list(escale)) escale = list()
- if(!is.Numeric(shrinkage.init, allow=1) || shrinkage.init < 0 ||
+ if (!is.list(elocation)) elocation = list()
+ if (!is.list(escale)) escale = list()
+ if (!is.Numeric(shrinkage.init, allow=1) || shrinkage.init < 0 ||
shrinkage.init > 1) stop("bad input for argument 'shrinkage.init'")
- if(length(zero) &&
+ if (length(zero) &&
!(is.Numeric(zero, integer=TRUE, posit=TRUE) || is.character(zero )))
stop("bad input for argument 'zero'")
- if(!is.logical(sameScale) || length(sameScale) != 1)
+ if (!is.logical(sameScale) || length(sameScale) != 1)
stop("bad input for argument 'sameScale'")
- if(!is.logical(parallelLocation) || length(parallelLocation) != 1)
+ if (!is.logical(parallelLocation) || length(parallelLocation) != 1)
stop("bad input for argument 'parallelLocation'")
fittedMean = FALSE
- if(!is.logical(fittedMean) || length(fittedMean) != 1)
+ if (!is.logical(fittedMean) || length(fittedMean) != 1)
stop("bad input for argument 'fittedMean'")
- if(llocation != "loge")
+ if (llocation != "loge")
stop("argument 'llocation' must be \"loge\"")
new("vglmff",
- blurb=c("Two-parameter log-Laplace distribution\n\n",
+ blurb = c("Two-parameter log-Laplace distribution\n\n",
"Links: ",
namesof("location", llocation, earg=elocation), ", ",
namesof("scale", lscale, earg=escale),
@@ -10265,24 +10284,24 @@ loglaplace2.control <- function(save.weight=TRUE, ...)
"Variance: zz scale^2 * (1 + kappa^4) / (2 * kappa^2)"),
constraints=eval(substitute(expression({
.ZERO = .zero
- if(is.character(.ZERO)) .ZERO = eval(parse(text = .ZERO))
+ if (is.character(.ZERO)) .ZERO = eval(parse(text = .ZERO))
.PARALLEL = .parallelLocation
- parHmat = if(is.logical(.PARALLEL) && .PARALLEL)
+ parHmat = if (is.logical(.PARALLEL) && .PARALLEL)
matrix(1, M/2, 1) else diag(M/2)
- scaleHmat = if(is.logical(.sameScale) && .sameScale)
+ scaleHmat = if (is.logical(.sameScale) && .sameScale)
matrix(1, M/2, 1) else diag(M/2)
mycmatrix = cbind(rbind(parHmat, 0*parHmat),
rbind(0*scaleHmat, scaleHmat))
constraints=cm.vgam(mycmatrix, x, .PARALLEL, constraints, int=FALSE)
constraints = cm.zero.vgam(constraints, x, .ZERO, M)
- if(.PARALLEL && names(constraints)[1] == "(Intercept)") {
+ if (.PARALLEL && names(constraints)[1] == "(Intercept)") {
parHmat = diag(M/2)
mycmatrix = cbind(rbind(parHmat, 0*parHmat),
rbind(0*scaleHmat, scaleHmat))
constraints[["(Intercept)"]] = mycmatrix
}
- if(is.logical(.sameScale) && .sameScale &&
+ if (is.logical(.sameScale) && .sameScale &&
names(constraints)[1] == "(Intercept)") {
temp3 = constraints[["(Intercept)"]]
temp3 = cbind(temp3[,1:(M/2)], rbind(0*scaleHmat, scaleHmat))
@@ -10293,7 +10312,7 @@ loglaplace2.control <- function(save.weight=TRUE, ...)
initialize=eval(substitute(expression({
extra$kappa = .kappa
extra$tau = extra$kappa^2 / (1 + extra$kappa^2)
- if(ncol(y <- cbind(y)) != 1)
+ if (ncol(y <- cbind(y)) != 1)
stop("response must be a vector or a one-column matrix")
extra$M = M = 2 * length(extra$kappa)
extra$n = n
@@ -10305,18 +10324,18 @@ loglaplace2.control <- function(save.weight=TRUE, ...)
.llocation, earg=.elocation, tag=FALSE),
namesof(if(M==2) "scale" else paste("scale", 1:(M/2), sep=""),
.lscale, earg=.escale, tag=FALSE))
- if(weighted.mean(1*(y < 0.001), w) >= min(extra$tau))
+ if (weighted.mean(1*(y < 0.001), w) >= min(extra$tau))
stop("sample proportion of 0s > minimum 'tau' value. ",
"Choose larger values for 'tau'.")
- if(!length(etastart)) {
- if( .method.init == 1) {
+ if (!length(etastart)) {
+ if ( .method.init == 1) {
location.init.y = weighted.mean(y, w)
scale.init = sqrt(var(y) / 2)
- } else if( .method.init == 2) {
+ } else if ( .method.init == 2) {
location.init.y = median(y)
scale.init = sqrt(sum(w*abs(y-median(y))) / (sum(w) *2))
- } else if( .method.init == 3) {
+ } else if ( .method.init == 3) {
fit500 = vsmooth.spline(x=x[,min(ncol(x),2)], y=y, w=w,
df= .dfmu.init)
location.init.y = c(predict(fit500, x=x[,min(ncol(x),2)])$y)
@@ -10326,10 +10345,10 @@ loglaplace2.control <- function(save.weight=TRUE, ...)
location.init.y = (1- .sinit)*y + .sinit * use.this
scale.init = sqrt(sum(w*abs(y-median(y ))) / (sum(w) *2))
}
- location.init.y = if(length(.ilocation)) rep(.ilocation, len=n) else
+ location.init.y = if (length(.ilocation)) rep(.ilocation, len=n) else
rep(location.init.y, len=n)
location.init.y = matrix(location.init.y, n, M/2)
- scale.init = if(length(.iscale)) rep(.iscale, len=n) else
+ scale.init = if (length(.iscale)) rep(.iscale, len=n) else
rep(scale.init, len=n)
scale.init = matrix(scale.init, n, M/2)
etastart =
@@ -10345,7 +10364,7 @@ loglaplace2.control <- function(save.weight=TRUE, ...)
inverse=eval(substitute(function(eta, extra=NULL) {
location.y = eta2theta(eta[,1:(extra$M/2),drop=FALSE],
.llocation, earg= .elocation)
- if( .fittedMean) {
+ if ( .fittedMean) {
kappamat = matrix(extra$kappa, extra$n, extra$M/2, byrow=TRUE)
Scale.y = eta2theta(eta[,(1+extra$M/2):extra$M], .lscale, earg= .escale)
location.y + Scale.y * (1/kappamat - kappamat)
@@ -10356,7 +10375,7 @@ loglaplace2.control <- function(save.weight=TRUE, ...)
}, list( .elocation=elocation, .llocation=llocation,
.fittedMean=fittedMean, .escale=escale, .lscale=lscale,
.kappa=kappa ))),
- last=eval(substitute(expression({
+ last = eval(substitute(expression({
misc$link = c(location= .llocation, scale= .lscale)
misc$earg = list(location= .elocation, scale= .escale)
misc$expected = TRUE
@@ -10385,7 +10404,7 @@ loglaplace2.control <- function(save.weight=TRUE, ...)
scale.ald=c(Scale.w),
kappa=c(kappamat), log=TRUE)),
extra$n, extra$M/2)
- if(residuals) stop("loglikelihood residuals not implemented yet") else
+ if (residuals) stop("loglikelihood residuals not implemented yet") else
sum(w * ell.mat)
}, list( .elocation=elocation, .llocation=llocation,
.escale=escale, .lscale=lscale,
@@ -10418,7 +10437,7 @@ loglaplace2.control <- function(save.weight=TRUE, ...)
run.varcov = 0
ind1 = iam(NA, NA, M=M, both=TRUE, diag=TRUE)
dthetas.detas = cbind(dlocation.deta, dscale.deta)
- if(length( .nsimEIM )) {
+ if (length( .nsimEIM )) {
for(ii in 1:( .nsimEIM )) {
wsim = matrix(rloglap(n*M/2, loc=c(location.w),
sca=c(Scale.w),
@@ -10436,7 +10455,7 @@ loglaplace2.control <- function(save.weight=TRUE, ...)
run.varcov = ((ii-1) * run.varcov +
temp3[,ind1$row.index]*temp3[,ind1$col.index]) / ii
}
- wz = if(intercept.only)
+ wz = if (intercept.only)
matrix(colMeans(run.varcov),
n, ncol(run.varcov), byrow=TRUE) else run.varcov
@@ -10482,28 +10501,28 @@ adjust01.logitlaplace1 = function(ymat, y, w, rep01) {
rep01 = 0.5,
method.init=1, zero=NULL) {
- if(!is.Numeric(rep01, posit=TRUE, allow=1) || rep01 > 0.5)
+ if (!is.Numeric(rep01, posit=TRUE, allow=1) || rep01 > 0.5)
stop("bad input for argument 'rep01'")
- if(!is.Numeric(kappa, posit=TRUE))
+ if (!is.Numeric(kappa, posit=TRUE))
stop("bad input for argument 'kappa'")
- if(length(tau) && max(abs(kappa - sqrt(tau/(1-tau)))) > 1.0e-6)
+ 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")
+ if (mode(llocation) != "character" && mode(llocation) != "name")
llocation = as.character(substitute(llocation))
- if(!is.Numeric(method.init, allow=1, integ=TRUE, posit=TRUE) ||
+ if (!is.Numeric(method.init, allow=1, integ=TRUE, posit=TRUE) ||
method.init > 4) stop("argument 'method.init' must be 1, 2 or ... 4")
- if(!is.list(elocation)) elocation = list()
- if(!is.Numeric(shrinkage.init, allow=1) || shrinkage.init < 0 ||
+ if (!is.list(elocation)) elocation = list()
+ if (!is.Numeric(shrinkage.init, allow=1) || shrinkage.init < 0 ||
shrinkage.init > 1) stop("bad input for argument 'shrinkage.init'")
- if(length(zero) &&
+ if (length(zero) &&
!(is.Numeric(zero, integer=TRUE, posit=TRUE) || is.character(zero )))
stop("bad input for argument 'zero'")
- if(!is.Numeric(Scale.arg, posit=TRUE))
+ if (!is.Numeric(Scale.arg, posit=TRUE))
stop("bad input for argument 'Scale.arg'")
- if(!is.logical(parallelLocation) || length(parallelLocation) != 1)
+ if (!is.logical(parallelLocation) || length(parallelLocation) != 1)
stop("bad input for argument 'parallelLocation'")
fittedMean = FALSE
- if(!is.logical(fittedMean) || length(fittedMean) != 1)
+ if (!is.logical(fittedMean) || length(fittedMean) != 1)
stop("bad input for argument 'fittedMean'")
mystring0 = namesof("location", llocation, earg=elocation)
@@ -10512,8 +10531,8 @@ adjust01.logitlaplace1 = function(ymat, y, w, rep01) {
mystring1 = paste(mychars, collapse="")
new("vglmff",
- blurb=c("One-parameter ", llocation, "-Laplace distribution\n\n",
- "Links: ", mystring0, "\n", "\n",
+ blurb = c("One-parameter ", llocation, "-Laplace distribution\n\n",
+ "Links: ", mystring0, "\n", "\n",
"Quantiles: ", mystring1),
constraints=eval(substitute(expression({
constraints = cm.vgam(matrix(1,M,1), x, .parallelLocation,
@@ -10526,7 +10545,7 @@ adjust01.logitlaplace1 = function(ymat, y, w, rep01) {
extra$Scale = rep( .Scale.arg, length=M)
extra$kappa = rep( .kappa, length=M)
extra$tau = extra$kappa^2 / (1 + extra$kappa^2)
- if(ncol(y <- cbind(y)) != 1)
+ if (ncol(y <- cbind(y)) != 1)
stop("response must be a vector or a one-column matrix")
extra$n = n
extra$y.names = y.names = paste("tau=", round(extra$tau, dig=.digt),
@@ -10535,22 +10554,22 @@ adjust01.logitlaplace1 = function(ymat, y, w, rep01) {
predictors.names = namesof(paste("quantile(", y.names, ")", sep=""),
.llocation, earg=.elocation, tag=FALSE)
- if(all(y == 0 | y == 1)) stop("response cannot be all 0s or 1s")
- if(min(y) < 0) stop("negative response values detected")
- if(max(y) > 1) stop("response values greater than 1 detected")
- if((prop.0. <- weighted.mean(1*(y == 0), w)) >= min(extra$tau))
+ if (all(y == 0 | y == 1)) stop("response cannot be all 0s or 1s")
+ if (min(y) < 0) stop("negative response values detected")
+ if (max(y) > 1) stop("response values greater than 1 detected")
+ if ((prop.0. <- weighted.mean(1*(y == 0), w)) >= min(extra$tau))
stop("sample proportion of 0s == ", round(prop.0., dig=4),
" > minimum 'tau' value. Choose larger values for 'tau'.")
- if((prop.1. <- weighted.mean(1*(y == 1), w)) >= max(extra$tau))
+ if ((prop.1. <- weighted.mean(1*(y == 1), w)) >= max(extra$tau))
stop("sample proportion of 1s == ", round(prop.1., dig=4),
" < maximum 'tau' value. Choose smaller values for 'tau'.")
- if(!length(etastart)) {
- if( .method.init == 1) {
+ if (!length(etastart)) {
+ if ( .method.init == 1) {
location.init = quantile(rep(y, w), probs= extra$tau)
- } else if( .method.init == 2) {
+ } else if ( .method.init == 2) {
location.init = weighted.mean(y, w)
location.init = median(rep(y, w))
- } else if( .method.init == 3) {
+ } else if ( .method.init == 3) {
use.this = weighted.mean(y, w)
location.init = (1- .sinit)*y + use.this * .sinit
} else {
@@ -10558,17 +10577,13 @@ adjust01.logitlaplace1 = function(ymat, y, w, rep01) {
}
- location.init = if(length(.ilocation)) rep(.ilocation, len=M) else
+ location.init = if (length(.ilocation)) rep(.ilocation, len=M) else
rep(location.init, len=M)
location.init = matrix(location.init, n, M, byrow=TRUE)
location.init = abs(location.init)
etastart =
cbind(theta2eta(location.init, .llocation, earg= .elocation))
}
- print("location.init[1:3,]")
- print( location.init[1:3,] )
- print("etastart[1:3,]")
- print( etastart[1:3,] )
}), list( .method.init=method.init,
.dfmu.init=dfmu.init,
.sinit=shrinkage.init, .digt=digt,
@@ -10577,20 +10592,20 @@ adjust01.logitlaplace1 = function(ymat, y, w, rep01) {
.ilocation=ilocation ))),
inverse=eval(substitute(function(eta, extra=NULL) {
location.y = eta2theta(eta, .llocation, earg= .elocation)
- if( .fittedMean) {
+ if ( .fittedMean) {
stop("Yet to do: handle 'fittedMean = TRUE'")
kappamat = matrix(extra$kappa, extra$n, extra$M, byrow=TRUE)
Scale = matrix(extra$Scale, extra$n, extra$M, byrow=TRUE)
location.y + Scale * (1/kappamat - kappamat)
} else {
- if(length(location.y) > extra$n)
+ if (length(location.y) > extra$n)
dimnames(location.y) = list(dimnames(eta)[[1]], extra$y.names)
location.y
}
}, list( .elocation=elocation, .llocation=llocation,
.fittedMean=fittedMean, .Scale.arg=Scale.arg,
.kappa=kappa ))),
- last=eval(substitute(expression({
+ last = eval(substitute(expression({
misc$link = c(location= .llocation)
misc$earg = list(location= .elocation)
misc$expected = TRUE
@@ -10617,7 +10632,7 @@ adjust01.logitlaplace1 = function(ymat, y, w, rep01) {
ymat = matrix(y, extra$n, extra$M)
ymat = adjust01.logitlaplace1(ymat=ymat, y=y, w=w, rep01= .rep01)
w.mat = theta2eta(ymat, .llocation, earg= .elocation) # e.g., logit()
- if(residuals) stop("loglikelihood residuals not implemented yet") else {
+ if (residuals) stop("loglikelihood residuals not implemented yet") else {
ALDans =
sum(w * dalap(x=c(w.mat), location=c(eta),
scale=c(Scale.w), kappa=c(kappamat), log=TRUE))
diff --git a/R/family.vglm.q b/R/family.vglm.R
similarity index 68%
rename from R/family.vglm.q
rename to R/family.vglm.R
index 340ca92..9d2627f 100644
--- a/R/family.vglm.q
+++ b/R/family.vglm.R
@@ -1,5 +1,5 @@
# These functions are
-# Copyright (C) 1998-2009 T.W. Yee, University of Auckland. All rights reserved.
+# Copyright (C) 1998-2010 T.W. Yee, University of Auckland. All rights reserved.
@@ -9,15 +9,15 @@ family.vglm <- function(object, ...)
print.vfamily <- function(x, ...)
{
f <- x$vfamily
- if(is.null(f))
+ if (is.null(f))
stop("not a VGAM family function")
nn <- x$blurb
- if(is.null(nn))
+ if (is.null(nn))
invisible(return(x))
cat("Family: ", f[1], "\n")
- if(length(f)>1) cat("Classes:", paste(f, collapse=", "), "\n")
+ if (length(f)>1) cat("Classes:", paste(f, collapse=", "), "\n")
cat("\n")
for(i in 1:length(nn))
diff --git a/R/family.zeroinf.q b/R/family.zeroinf.R
similarity index 76%
rename from R/family.zeroinf.q
rename to R/family.zeroinf.R
index 8bead25..358279b 100644
--- a/R/family.zeroinf.q
+++ b/R/family.zeroinf.R
@@ -1,6 +1,5 @@
# These functions are
-# Copyright (C) 1998-2009 T.W. Yee, University of Auckland. All rights reserved.
-
+# Copyright (C) 1998-2010 T.W. Yee, University of Auckland. All rights reserved.
@@ -14,22 +13,24 @@ dzanegbin = function(x, p0, size, prob=NULL, munb=NULL, log=FALSE) {
stop("'prob' and 'munb' both specified")
prob <- size/(size + munb)
}
- 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)
- L = max(length(x), length(p0), length(prob), length(size))
- x = rep(x, len=L); p0 = rep(p0, len=L);
- prob = rep(prob, len=L); size = rep(size, len=L);
- ans = rep(0.0, len=L)
- if(!is.Numeric(p0) || any(p0 < 0) || any(p0 > 1))
+ LLL = max(length(x), length(p0), length(prob), length(size))
+ if (length(x) != LLL) x = rep(x, len=LLL)
+ if (length(p0) != LLL) p0 = rep(p0, 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(p0) || any(p0 < 0) || any(p0 > 1))
stop("'p0' must be in [0,1]")
- if(!is.Numeric(prob, posit=TRUE))
+ if (!is.Numeric(prob, posit=TRUE))
stop("'prob' must be in [0,Inf)")
- if(!is.Numeric(size, posit=TRUE))
+ if (!is.Numeric(size, posit=TRUE))
stop("'size' must be in [0,Inf)")
index0 = x==0
- if(log.arg) {
+ if (log.arg) {
ans[ index0] = log(p0[index0])
ans[!index0] = log1p(-p0[!index0]) +
dposnegbin(x[!index0], prob=prob[!index0],
@@ -50,12 +51,14 @@ pzanegbin = function(q, p0, size, prob=NULL, munb=NULL) {
stop("'prob' and 'munb' both specified")
prob <- size/(size + munb)
}
- L = max(length(q), length(p0), length(prob), length(size))
- q = rep(q, len=L); p0 = rep(p0, len=L);
- prob = rep(prob, len=L); size = rep(size, len=L);
- ans = rep(0.0, len=L)
-
- if(!is.Numeric(p0) || any(p0 < 0) || any(p0 > 1))
+ LLL = max(length(q), length(p0), length(prob), length(size))
+ if (length(q) != LLL) q = rep(q, len=LLL);
+ if (length(p0) != LLL) p0 = rep(p0, 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(p0) || any(p0 < 0) || any(p0 > 1))
stop("'p0' must be in [0,1]")
ans[q > 0] = p0[q > 0] + (1-p0[q > 0]) *
pposnegbin(q[q > 0], size=size[q > 0], prob=prob[q > 0])
@@ -70,12 +73,14 @@ qzanegbin = function(p, p0, size, prob=NULL, munb=NULL) {
stop("'prob' and 'munb' both specified")
prob <- size/(size + munb)
}
- L = max(length(p), length(p0), length(prob), length(size))
- p = rep(p, len=L); p0 = rep(p0, len=L);
- prob = rep(prob, len=L); size = rep(size, len=L);
- ans = rep(0.0, len=L)
-
- if(!is.Numeric(p0) || any(p0 < 0) || any(p0 > 1))
+ LLL = max(length(p), length(p0), length(prob), length(size))
+ if (length(p) != LLL) p = rep(p, len=LLL);
+ if (length(p0) != LLL) p0 = rep(p0, 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(p0) || any(p0 < 0) || any(p0 > 1))
stop("'p0' must be between 0 and 1 inclusive")
ans = p
ans[p <= p0] = 0
@@ -85,8 +90,8 @@ qzanegbin = function(p, p0, size, prob=NULL, munb=NULL) {
}
rzanegbin = function(n, p0, size, prob=NULL, munb=NULL) {
- use.n = if((length.n <- length(n)) > 1) length.n else
- if(!is.Numeric(n, integ=TRUE, allow=1, posit=TRUE))
+ use.n = if ((length.n <- length(n)) > 1) length.n else
+ if (!is.Numeric(n, integ=TRUE, allow=1, posit=TRUE))
stop("bad input for argument 'n'") else n
if (length(munb)) {
@@ -94,9 +99,9 @@ rzanegbin = function(n, p0, size, prob=NULL, munb=NULL) {
stop("'prob' and 'munb' both specified")
prob <- size/(size + munb)
}
- ans = rposnegbin(use.n, prob=prob, size=size)
- p0 = rep(p0, len=length(ans))
- if(!is.Numeric(p0) || any(p0 < 0) || any(p0 > 1))
+ ans = rposnegbin(n=use.n, prob=prob, size=size)
+ if (length(p0) != use.n) p0 = rep(p0, len=use.n)
+ if (!is.Numeric(p0) || any(p0 < 0) || any(p0 > 1))
stop("'p0' must be between 0 and 1 inclusive")
ifelse(runif(use.n) < p0, 0, ans)
}
@@ -106,17 +111,19 @@ rzanegbin = function(n, p0, size, prob=NULL, munb=NULL) {
dzapois = function(x, lambda, p0=0, 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)
- L = max(length(x), length(lambda), length(p0))
- x = rep(x, len=L); lambda = rep(lambda, len=L); p0 = rep(p0, len=L);
- ans = rep(0.0, len=L)
- if(!is.Numeric(p0) || any(p0 < 0) || any(p0 > 1))
- stop("'p0' must be in [0,1]")
- index0 = x==0
+ LLL = max(length(x), length(lambda), length(p0))
+ if (length(x) != LLL) x = rep(x, len=LLL);
+ if (length(lambda) != LLL) lambda = rep(lambda, len=LLL);
+ if (length(p0) != LLL) p0 = rep(p0, len=LLL);
+ ans = rep(0.0, len=LLL)
+ if (!is.Numeric(p0) || any(p0 < 0) || any(p0 > 1))
+ stop("argument 'p0' must be in [0,1]")
+ index0 = (x==0)
- if(log.arg) {
+ if (log.arg) {
ans[ index0] = log(p0[index0])
ans[!index0] = log1p(-p0[!index0]) +
dpospois(x[!index0], lambda[!index0], log=TRUE)
@@ -130,12 +137,14 @@ dzapois = function(x, lambda, p0=0, log=FALSE) {
pzapois = function(q, lambda, p0=0) {
- L = max(length(q), length(lambda), length(p0))
- q = rep(q, len=L); lambda = rep(lambda, len=L); p0 = rep(p0, len=L);
- ans = rep(0.0, len=L)
-
- if(!is.Numeric(p0) || any(p0 < 0) || any(p0 > 1))
- stop("'p0' must be in [0,1]")
+ LLL = max(length(q), length(lambda), length(p0))
+ if (length(q) != LLL) q = rep(q, len=LLL);
+ if (length(lambda) != LLL) lambda = rep(lambda, len=LLL);
+ if (length(p0) != LLL) p0 = rep(p0, len=LLL);
+ ans = rep(0.0, len=LLL)
+
+ if (!is.Numeric(p0) || any(p0 < 0) || any(p0 > 1))
+ stop("argument 'p0' must be in [0,1]")
ans[q > 0] = p0[q > 0] + (1-p0[q > 0]) * ppospois(q[q > 0], lambda[q > 0])
ans[q < 0] = 0
ans[q == 0] = p0[q == 0]
@@ -144,25 +153,29 @@ pzapois = function(q, lambda, p0=0) {
qzapois = function(p, lambda, p0=0) {
- nn = max(length(p), length(lambda), length(p0))
- p = rep(p, len=nn); lambda = rep(lambda, len=nn); p0 = rep(p0, len=nn)
- if(!is.Numeric(p0) || any(p0 < 0) || any(p0 > 1))
- stop("'p0' must be between 0 and 1 inclusive")
+ LLL = max(length(p), length(lambda), length(p0))
+ if (length(p) != LLL) p = rep(p, len=LLL);
+ if (length(lambda) != LLL) lambda = rep(lambda, len=LLL);
+ if (length(p0) != LLL) p0 = rep(p0, len=LLL);
+
+ if (!is.Numeric(p0) || any(p0 < 0) || any(p0 > 1))
+ stop("argument 'p0' must be between 0 and 1 inclusive")
ans = p
- ans[p<=p0] = 0
- ans[p>p0] = qpospois((p[p>p0]-p0[p>p0])/(1-p0[p>p0]), lam=lambda[p>p0])
+ ind4 = (p > p0)
+ ans[!ind4] = 0
+ ans[ ind4] = qpospois((p[ind4]-p0[ind4])/(1-p0[ind4]), lam=lambda[ind4])
ans
}
rzapois = function(n, lambda, p0=0) {
- use.n = if((length.n <- length(n)) > 1) length.n else
- if(!is.Numeric(n, integ=TRUE, allow=1, posit=TRUE))
+ use.n = if ((length.n <- length(n)) > 1) length.n else
+ if (!is.Numeric(n, integ=TRUE, allow=1, posit=TRUE))
stop("bad input for argument 'n'") else n
ans = rpospois(use.n, lambda)
- p0 = rep(p0, len=length(ans))
- if(!is.Numeric(p0) || any(p0 < 0) || any(p0 > 1))
- stop("p0 must be between 0 and 1 inclusive")
+ if (length(p0) != use.n) p0 = rep(p0, len=use.n)
+ if (!is.Numeric(p0) || any(p0 < 0) || any(p0 > 1))
+ stop("argument 'p0' must be between 0 and 1 inclusive")
ifelse(runif(use.n) < p0, 0, ans)
}
@@ -171,24 +184,26 @@ rzapois = function(n, lambda, p0=0) {
dzipois = function(x, lambda, phi=0, 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)
- L = max(length(x), length(lambda), length(phi))
- x = rep(x, len=L); lambda = rep(lambda, len=L); phi = rep(phi, len=L);
- ans = rep(0.0, len=L)
- if(!is.Numeric(phi) || any(phi < 0) || any(phi > 1))
+ LLL = max(length(x), length(lambda), length(phi))
+ if (length(x) != LLL) x = rep(x, len=LLL);
+ if (length(lambda) != LLL) lambda = rep(lambda, len=LLL);
+ if (length(phi) != LLL) phi = rep(phi, len=LLL);
+ ans = rep(0.0, len=LLL)
+ if (!is.Numeric(phi) || any(phi < 0) || any(phi > 1))
stop("'phi' must be between 0 and 1 inclusive")
- index0 = x==0
- if(log.arg) {
- ans[ index0] = log(phi[index0] + (1-phi[index0]) *
- dpois(x[index0], lambda[index0]))
+ index0 = (x==0)
+ if (log.arg) {
+ ans[ index0] = log(phi[ index0] + (1-phi[ index0]) *
+ dpois(x[ index0], lambda[ index0]))
ans[!index0] = log1p(-phi[!index0]) +
dpois(x[!index0], lambda[!index0], log=TRUE)
} else {
- ans[ index0] = phi[index0] + (1-phi[index0]) *
- dpois(x[index0], lambda[index0])
+ ans[ index0] = phi[ index0] + (1-phi[ index0]) *
+ dpois(x[ index0], lambda[ index0])
ans[!index0] = (1-phi[!index0]) * dpois(x[!index0], lambda[!index0])
}
ans
@@ -196,9 +211,10 @@ dzipois = function(x, lambda, phi=0, log=FALSE) {
pzipois = function(q, lambda, phi=0) {
ans = ppois(q, lambda)
- LL = max(length(phi), length(ans))
- phi = rep(phi, length=LL)
- ans = rep(ans, length=LL)
+ LLL = max(length(phi), length(ans))
+ if (length(phi) != LLL) phi = rep(phi, len=LLL);
+ if (length(ans) != LLL) ans = rep(ans, len=LLL);
+
ans = ifelse(q<0, 0, phi + (1-phi) * ans)
ans[phi < 0] = NaN
ans[phi > 1] = NaN
@@ -206,10 +222,10 @@ pzipois = function(q, lambda, phi=0) {
}
qzipois = function(p, lambda, phi=0) {
- LL = max(length(p), length(lambda), length(phi))
- ans = p = rep(p, len=LL)
- lambda = rep(lambda, len=LL)
- phi = rep(phi, len=LL)
+ LLL = max(length(p), length(lambda), length(phi))
+ ans = p = rep(p, len=LLL)
+ lambda = rep(lambda, len=LLL)
+ phi = rep(phi, len=LLL)
ans[p<=phi] = 0
ans[p>phi] = qpois((p[p>phi]-phi[p>phi])/(1-phi[p>phi]), lam=lambda[p>phi])
ans[phi < 0] = NaN
@@ -218,8 +234,8 @@ qzipois = function(p, lambda, phi=0) {
}
rzipois = function(n, lambda, phi=0) {
- use.n = if((length.n <- length(n)) > 1) length.n else
- if(!is.Numeric(n, integ=TRUE, allow=1, posit=TRUE))
+ use.n = if ((length.n <- length(n)) > 1) length.n else
+ if (!is.Numeric(n, integ=TRUE, allow=1, posit=TRUE))
stop("bad input for argument 'n'") else n
ans = rpois(use.n, lambda)
@@ -233,7 +249,7 @@ rzipois = function(n, lambda, phi=0) {
yip88 = function(link.lambda="loge", n.arg=NULL)
{
- if(mode(link.lambda) != "character" && mode(link.lambda) != "name")
+ if (mode(link.lambda) != "character" && mode(link.lambda) != "name")
link.lambda = as.character(substitute(link.lambda))
new("vglmff",
@@ -242,10 +258,10 @@ rzipois = function(n, lambda, phi=0) {
"Variance: (1-phi)*lambda"),
first=eval(substitute(expression({
zero <- y==0
- if(any(zero)) {
- if(length(extra)) extra$sumw = sum(w) else
+ if (any(zero)) {
+ if (length(extra)) extra$sumw = sum(w) else
extra = list(sumw=sum(w))
- if(is.numeric(.n.arg) && extra$sumw != .n.arg)
+ if (is.numeric(.n.arg) && extra$sumw != .n.arg)
stop("value of 'n.arg' conflicts with data ",
"(it need not be specified anyway)")
warning("trimming out the zero observations")
@@ -256,21 +272,21 @@ rzipois = function(n, lambda, phi=0) {
w = w[!zero]
y = y[!zero]
} else
- if(!is.numeric(.n.arg))
+ if (!is.numeric(.n.arg))
stop("n.arg must be supplied")
}), list( .n.arg=n.arg ))),
initialize=eval(substitute(expression({
- narg = if(is.numeric(.n.arg)) .n.arg else extra$sumw
- if(sum(w) > narg)
+ narg = if (is.numeric(.n.arg)) .n.arg else extra$sumw
+ if (sum(w) > narg)
stop("sum(w) > narg")
predictors.names = namesof("lambda", .link.lambda, tag=FALSE)
- if(!length(etastart)) {
+ if (!length(etastart)) {
lambda.init = rep(median(y), length=length(y))
etastart = theta2eta(lambda.init, .link.lambda)
}
- if(length(extra)) {
+ if (length(extra)) {
extra$sumw = sum(w)
extra$narg = narg # For @inverse
} else
@@ -280,17 +296,17 @@ rzipois = function(n, lambda, phi=0) {
lambda = eta2theta(eta, .link.lambda)
temp5 = exp(-lambda)
phi = (1 - temp5 - extra$sumw/extra$narg) / (1 - temp5)
- if(any(phi <= 0))
+ if (any(phi <= 0))
stop("non-positive value(s) of phi")
(1-phi) * lambda
}, list( .link.lambda=link.lambda ))),
last=eval(substitute(expression({
misc$link = c(lambda = .link.lambda)
- if(ncol(x)==1 && dimnames(x)[[2]]=="(Intercept)") {
+ if (ncol(x)==1 && dimnames(x)[[2]]=="(Intercept)") {
suma = extra$sumw
phi = (1 - temp5[1] - suma/narg) / (1 - temp5[1])
- phi = if(phi < 0 || phi>1) NA else phi # phi is a probability
+ phi = if (phi < 0 || phi>1) NA else phi # phi is a probability
misc$phi = phi
}
}), list( .link.lambda=link.lambda ))),
@@ -299,7 +315,7 @@ rzipois = function(n, lambda, phi=0) {
lambda = eta2theta(eta, .link.lambda)
temp5 = exp(-lambda)
phi = (1 - temp5 - extra$sumw/extra$narg) / (1 - temp5)
- if(residuals) stop("loglikelihood residuals not implemented yet") else {
+ if (residuals) stop("loglikelihood residuals not implemented yet") else {
sum(w * dzipois(x=y, phi=phi, lambda=lambda, log=TRUE))
}
}, list( .link.lambda=link.lambda ))),
@@ -325,12 +341,12 @@ rzipois = function(n, lambda, phi=0) {
ep0=list(), elambda=list(),
zero=NULL)
{
- if(mode(lp0) != "character" && mode(lp0) != "name")
+ if (mode(lp0) != "character" && mode(lp0) != "name")
lp0 = as.character(substitute(lp0))
- if(mode(llambda) != "character" && mode(llambda) != "name")
+ if (mode(llambda) != "character" && mode(llambda) != "name")
llambda = as.character(substitute(llambda))
- if(!is.list(ep0)) ep0 = list()
- if(!is.list(elambda)) elambda = list()
+ if (!is.list(ep0)) ep0 = list()
+ if (!is.list(elambda)) elambda = list()
new("vglmff",
blurb=c(
@@ -341,27 +357,27 @@ rzipois = function(n, lambda, phi=0) {
"\n"),
constraints=eval(substitute(expression({
temp752 = .zero
- if(length(temp752) && all(temp752 == -1))
+ if (length(temp752) && all(temp752 == -1))
temp752 = 2*(1:ncol(y)) - 1
constraints = cm.zero.vgam(constraints, x, temp752, M)
}), list( .zero=zero ))),
initialize=eval(substitute(expression({
y = as.matrix(y)
- if(any(y != round(y )))
+ if (any(y != round(y )))
stop("the response must be integer-valued")
- if(any(y < 0))
+ if (any(y < 0))
stop("the response must not have negative values")
extra$y0 = y0 = ifelse(y==0, 1, 0)
extra$NOS = NOS = ncoly = ncol(y) # Number of species
extra$skip.these = skip.these = matrix(as.logical(y0), n, NOS)
- mynames1 = if(ncoly==1) "p0" else paste("p0", 1:ncoly, sep="")
- mynames2 = if(ncoly==1) "lambda" else paste("lambda", 1:ncoly, sep="")
+ mynames1 = if (ncoly==1) "p0" else paste("p0", 1:ncoly, sep="")
+ mynames2 = if (ncoly==1) "lambda" else paste("lambda", 1:ncoly, sep="")
predictors.names =
c(namesof(mynames1, .lp0, earg= .ep0, tag=FALSE),
namesof(mynames2, .llambda, earg= .elambda, tag=FALSE))
- if(!length(etastart)) {
+ if (!length(etastart)) {
etastart = cbind(theta2eta((0.5+w*y0)/(1+w), .lp0, earg= .ep0 ),
matrix(1, n, NOS)) # 1 here is any old value
for(spp. in 1:NOS)
@@ -392,7 +408,7 @@ rzipois = function(n, lambda, phi=0) {
NOS = extra$NOS
p0 = cbind(eta2theta(eta[,1:NOS], .lp0, earg= .ep0))
lambda = cbind(eta2theta(eta[,NOS+(1:NOS)], .llambda, earg= .elambda ))
- if(residuals) stop("loglikelihood residuals not implemented yet") else {
+ if (residuals) stop("loglikelihood residuals not implemented yet") else {
sum(w * dzapois(x=y, p0=p0, lambda=lambda, log=TRUE))
}
}, list( .lp0=lp0, .llambda=llambda, .ep0= ep0, .elambda= elambda ))),
@@ -408,7 +424,7 @@ rzipois = function(n, lambda, phi=0) {
dl.dlambda[skip[,spp.],spp.] = 0
dlambda.deta = dtheta.deta(lambda, .llambda, earg= .ep0)
mup0 = p0
- temp3 = if(.lp0 == "logit") {
+ temp3 = if (.lp0 == "logit") {
w * (y0 - mup0)
} else
w * dtheta.deta(mup0, link=.lp0, earg= .ep0) * (y0/mup0 - 1) / (1-mup0)
@@ -427,14 +443,14 @@ rzipois = function(n, lambda, phi=0) {
}
tmp100 = mup0*(1-mup0)
- tmp200 = if( .lp0 == "logit") {
+ tmp200 = if ( .lp0 == "logit") {
cbind(w * tmp100)
} else {
cbind(w * dtheta.deta(mup0, link= .lp0, earg= .ep0)^2 / tmp100)
}
for(ii in 1:NOS) {
index200 = abs(tmp200[,ii]) < .Machine$double.eps
- if(any(index200)) {
+ if (any(index200)) {
tmp200[index200,ii] = 10.0 * .Machine$double.eps^(3/4)
}
}
@@ -454,27 +470,27 @@ rzipois = function(n, lambda, phi=0) {
- if(!is.Numeric(cutoff, positiv=TRUE, allow=1) || cutoff<0.8 || cutoff>=1)
- stop("range error in the argument cutoff")
- if(length(ipnb0) && (!is.Numeric(ipnb0, positiv=TRUE) ||
+ if (!is.Numeric(cutoff, positiv=TRUE, allow=1) || cutoff<0.8 || cutoff>=1)
+ stop("range error in the argument 'cutoff'")
+ if (length(ipnb0) && (!is.Numeric(ipnb0, positiv=TRUE) ||
max(ipnb0) >= 1))
- stop("If given, ipnb0 must contain values in (0,1) only")
- if(length(ik) && !is.Numeric(ik, positiv=TRUE))
- stop("If given, ik must contain positive values only")
- if(!is.Numeric(method.init, allow=1, integ=TRUE, posit=TRUE) ||
+ stop("If given, 'ipnb0' must contain values in (0,1) only")
+ if (length(ik) && !is.Numeric(ik, positiv=TRUE))
+ stop("If given, 'ik' must contain positive values only")
+ if (!is.Numeric(method.init, allow=1, integ=TRUE, posit=TRUE) ||
method.init > 2) stop("argument 'method.init' must be 1 or 2")
- if(!is.Numeric(shrinkage.init, allow=1) || shrinkage.init < 0 ||
+ if (!is.Numeric(shrinkage.init, allow=1) || shrinkage.init < 0 ||
shrinkage.init > 1) stop("bad input for argument 'shrinkage.init'")
- if(mode(lmunb) != "character" && mode(lmunb) != "name")
+ if (mode(lmunb) != "character" && mode(lmunb) != "name")
lmunb = as.character(substitute(lmunb))
- if(mode(lk) != "character" && mode(lk) != "name")
+ if (mode(lk) != "character" && mode(lk) != "name")
lk = as.character(substitute(lk))
- if(mode(lp0) != "character" && mode(lp0) != "name")
+ if (mode(lp0) != "character" && mode(lp0) != "name")
lp0 = as.character(substitute(lp0))
- if(!is.list(ep0)) ep0 = list()
- if(!is.list(emunb)) emunb = list()
- if(!is.list(ek)) ek = list()
+ if (!is.list(ep0)) ep0 = list()
+ if (!is.list(emunb)) emunb = list()
+ if (!is.list(ek)) ek = list()
new("vglmff",
blurb=c("Zero-altered negative binomial (binomial and\n",
@@ -486,7 +502,7 @@ rzipois = function(n, lambda, phi=0) {
"Mean: (1-p0) * munb / [1 - (k/(k+munb))^k]"),
constraints=eval(substitute(expression({
temp752 = .zero
- if(length(temp752) && all(temp752 == -3))
+ if (length(temp752) && all(temp752 == -3))
temp752 = 3*(1:ncol(y))
constraints = cm.zero.vgam(constraints, x, temp752, M)
}), list( .zero=zero ))),
@@ -494,14 +510,14 @@ rzipois = function(n, lambda, phi=0) {
y = as.matrix(y)
extra$NOS = NOS = ncoly = ncol(y) # Number of species
M = 3 * ncoly #
- if(any(y != round(y)))
+ if (any(y != round(y)))
stop("the response must be integer-valued")
- if(any(y < 0))
+ if (any(y < 0))
stop("the response must not have negative values")
- mynames1 = if(NOS==1) "p0" else paste("p0", 1:NOS, sep="")
- mynames2 = if(NOS==1) "munb" else paste("munb", 1:NOS, sep="")
- mynames3 = if(NOS==1) "k" else paste("k", 1:NOS, sep="")
+ mynames1 = if (NOS==1) "p0" else paste("p0", 1:NOS, sep="")
+ mynames2 = if (NOS==1) "munb" else paste("munb", 1:NOS, sep="")
+ mynames3 = if (NOS==1) "k" else paste("k", 1:NOS, sep="")
predictors.names =
c(namesof(mynames1, .lp0, earg= .ep0, tag= FALSE),
namesof(mynames2, .lmunb, earg= .emunb, tag= FALSE),
@@ -510,11 +526,11 @@ rzipois = function(n, lambda, phi=0) {
extra$y0 = y0 = ifelse(y==0, 1, 0)
extra$skip.these = skip.these = matrix(as.logical(y0), n, NOS)
- if(!length(etastart)) {
+ if (!length(etastart)) {
mu.init = y
for(iii in 1:ncol(y)) {
index.posy = (y[,iii] > 0)
- use.this = if( .method.init == 2) {
+ use.this = if ( .method.init == 2) {
weighted.mean(y[index.posy,iii], w[index.posy])
} else {
median(rep(y[index.posy,iii], w[index.posy])) + 1/2
@@ -524,7 +540,7 @@ rzipois = function(n, lambda, phi=0) {
mu.init[!index.posy,iii] = use.this
max.use.this = 7 * use.this + 10
vecTF = (mu.init[,iii] > max.use.this)
- if(any(vecTF))
+ if (any(vecTF))
mu.init[vecTF,iii] = max.use.this
}
@@ -532,14 +548,14 @@ rzipois = function(n, lambda, phi=0) {
pnb0 = matrix(if(length( .ipnb0)) .ipnb0 else -1,
nr=n, nc=NOS, byrow=TRUE)
for(spp. in 1:NOS) {
- if(any(pnb0[,spp.] < 0)) {
+ if (any(pnb0[,spp.] < 0)) {
index.y0 = y[,spp.] < 0.5
pnb0[,spp.] = max(min(sum(index.y0)/n, 0.97), 0.03)
}
}
- if( is.Numeric( .ik )) {
+ if ( is.Numeric( .ik )) {
kmat0 = matrix( .ik, nr=n, nc=ncoly, byrow=TRUE)
} else {
posnegbinomial.Loglikfun = function(kmat, y, x, w, extraargs) {
@@ -601,7 +617,7 @@ rzipois = function(n, lambda, phi=0) {
p0 = eta2theta(eta[,3*(1:NOS)-2,drop=FALSE], .lp0, earg= .ep0 )
munb = eta2theta(eta[,3*(1:NOS)-1,drop=FALSE], .lmunb, earg= .emunb )
kmat = eta2theta(eta[,3*(1:NOS),drop=FALSE], .lk, earg= .ek )
- if(residuals) stop("loglikelihood residuals not implemented yet") else {
+ if (residuals) stop("loglikelihood residuals not implemented yet") else {
sum(w * dzanegbin(x=y, p0=p0, munb=munb, size=kmat, log=TRUE))
}
}, list( .lp0=lp0, .lmunb=lmunb, .lk=lk,
@@ -640,7 +656,7 @@ rzipois = function(n, lambda, phi=0) {
myderiv = w * cbind(dl.dmunb * dmunb.deta, dl.dk * dk.deta)
mup0 = p0
- temp3 = if( .lp0 == "logit") {
+ temp3 = if ( .lp0 == "logit") {
w * (y0 - mup0)
} else
w * dtheta.deta(mup0, link= .lp0, earg= .ep0 ) *
@@ -666,7 +682,7 @@ rzipois = function(n, lambda, phi=0) {
as.double(kmat/(munb+kmat)), as.double(.cutoff),
as.integer(n), ok=as.integer(1), as.integer(NOS),
sumpdf=double(1), macheps=as.double(.Machine$double.eps))
- if(fred$ok != 1)
+ if (fred$ok != 1)
stop("error in Fortran subroutine exnbin")
dim(fred$ans) = c(n, NOS)
ed2l.dk2 = -fred$ans/(1-pnb0) - 1/kmat + 1/(kmat+munb) -
@@ -677,14 +693,14 @@ rzipois = function(n, lambda, phi=0) {
tmp100 = mup0*(1-mup0)
- tmp200 = if(.lp0 == "logit") {
+ tmp200 = if (.lp0 == "logit") {
cbind(w * tmp100)
} else {
cbind(w * dtheta.deta(mup0, link= .lp0, earg= .ep0 )^2 / tmp100)
}
for(ii in 1:NOS) {
index200 = abs(tmp200[,ii]) < .Machine$double.eps
- if(any(index200)) {
+ if (any(index200)) {
tmp200[index200,ii] = .Machine$double.eps # Diagonal 0's are bad
}
}
@@ -703,13 +719,13 @@ rzipois = function(n, lambda, phi=0) {
-if(FALSE)
+ if (FALSE)
rposnegbin = function(n, munb, k) {
- if(!is.Numeric(k, posit=TRUE))
+ if (!is.Numeric(k, posit=TRUE))
stop("argument 'k' must be positive")
- if(!is.Numeric(munb, posit=TRUE))
+ if (!is.Numeric(munb, posit=TRUE))
stop("argument 'munb' must be positive")
- if(!is.Numeric(n, posit=TRUE, integ=TRUE, allow=1))
+ if (!is.Numeric(n, posit=TRUE, integ=TRUE, allow=1))
stop("argument 'n' must be a positive integer")
ans = rnbinom(n=n, mu=munb, size=k)
munb = rep(munb, len=n)
@@ -725,16 +741,16 @@ rposnegbin = function(n, munb, k) {
-if(FALSE)
+ if (FALSE)
dposnegbin = function(x, munb, k, log=FALSE) {
- if(!is.Numeric(k, posit=TRUE))
+ if (!is.Numeric(k, posit=TRUE))
stop("argument 'k' must be positive")
- if(!is.Numeric(munb, posit=TRUE))
+ if (!is.Numeric(munb, posit=TRUE))
stop("argument 'munb' must be positive")
ans = dnbinom(x=x, mu=munb, size=k, log=log)
ans0 = dnbinom(x=0, mu=munb, size=k, log=FALSE)
- ans = if(log) ans - log1p(-ans0) else ans/(1-ans0)
- ans[x == 0] = if(log) -Inf else 0
+ ans = if (log) ans - log1p(-ans0) else ans/(1-ans0)
+ ans[x == 0] = if (log) -Inf else 0
ans
}
@@ -745,18 +761,18 @@ dposnegbin = function(x, munb, k, log=FALSE) {
iphi=NULL, method.init=1,
shrinkage.init=0.8, zero=NULL)
{
- if(mode(lphi) != "character" && mode(lphi) != "name")
+ if (mode(lphi) != "character" && mode(lphi) != "name")
lphi = as.character(substitute(lphi))
- if(mode(llambda) != "character" && mode(llambda) != "name")
+ if (mode(llambda) != "character" && mode(llambda) != "name")
llambda = as.character(substitute(llambda))
- if(is.Numeric(iphi))
- if(!is.Numeric(iphi, allow=1, posit=TRUE) || iphi >= 1)
- stop("iphi must be a single number inside the interval (0,1)")
- if(!is.list(ephi)) ephi = list()
- if(!is.list(elambda)) elambda = list()
- if(!is.Numeric(method.init, allow=1, integ=TRUE, posit=TRUE) ||
+ if (is.Numeric(iphi))
+ if (!is.Numeric(iphi, posit=TRUE) || any(iphi >= 1))
+ stop("'iphi' values must be inside the interval (0,1)")
+ if (!is.list(ephi)) ephi = list()
+ if (!is.list(elambda)) elambda = list()
+ if (!is.Numeric(method.init, allow=1, integ=TRUE, posit=TRUE) ||
method.init > 2) stop("argument 'method.init' must be 1 or 2")
- if(!is.Numeric(shrinkage.init, allow=1) || shrinkage.init < 0 ||
+ if (!is.Numeric(shrinkage.init, allow=1) || shrinkage.init < 0 ||
shrinkage.init > 1) stop("bad input for argument 'shrinkage.init'")
new("vglmff",
@@ -768,19 +784,19 @@ dposnegbin = function(x, munb, k, log=FALSE) {
constraints <- cm.zero.vgam(constraints, x, .zero, M)
}), list( .zero=zero ))),
initialize=eval(substitute(expression({
- if(ncol(as.matrix(y)) != 1) stop("multivariate responses not allowed")
- if(any(round(y) != y))
+ if (ncol(as.matrix(y)) != 1) stop("multivariate responses not allowed")
+ if (any(round(y) != y))
stop("integer-valued responses only allowed for the zipoisson family")
predictors.names = c(
namesof("phi", .lphi, earg= .ephi, tag=FALSE),
namesof("lambda", .llambda, earg= .ephi, tag=FALSE))
- if(!length(etastart)) {
- phi.init = if(length( .iphi)) .iphi else {
+ if (!length(etastart)) {
+ phi.init = if (length( .iphi)) .iphi else {
sum(w[y==0]) / sum(w)
}
phi.init[phi.init <= 0.02] = 0.02 # Last resort
phi.init[phi.init >= 0.98] = 0.98 # Last resort
- if( .method.init == 2) {
+ if ( .method.init == 2) {
mymean = weighted.mean(y[y>0], w[y>0]) + 1/16
lambda.init = (1- .sinit) * (y+1/8) + .sinit * mymean
} else {
@@ -792,8 +808,8 @@ dposnegbin = function(x, munb, k, log=FALSE) {
}
}), list( .lphi=lphi, .llambda=llambda,
.ephi=ephi, .elambda=elambda,
- .method.init=method.init,
.iphi=iphi,
+ .method.init=method.init,
.sinit=shrinkage.init ))),
inverse=eval(substitute(function(eta, extra=NULL) {
phi = eta2theta(eta[,1], .lphi, earg= .ephi )
@@ -804,7 +820,7 @@ dposnegbin = function(x, munb, k, log=FALSE) {
last=eval(substitute(expression({
misc$link <- c("phi" = .lphi, "lambda" = .llambda)
misc$earg <- list("phi" = .ephi, "lambda" = .elambda)
- if(intercept.only) {
+ if (intercept.only) {
phi = eta2theta(eta[1,1], .lphi, earg= .ephi )
lambda = eta2theta(eta[1,2], .llambda, earg= .elambda )
misc$prob0 = phi + (1-phi) * exp(-lambda) # P(Y=0)
@@ -818,7 +834,7 @@ dposnegbin = function(x, munb, k, log=FALSE) {
phi = pmax(phi, smallno)
phi = pmin(phi, 1.0-smallno)
lambda = eta2theta(eta[,2], .llambda, earg= .elambda )
- if(residuals) stop("loglikelihood residuals not implemented yet") else {
+ if (residuals) stop("loglikelihood residuals not implemented yet") else {
sum(w * dzipois(x=y, phi=phi, lambda=lambda, log=TRUE))
}
}, list( .lphi=lphi, .llambda=llambda,
@@ -839,7 +855,7 @@ dposnegbin = function(x, munb, k, log=FALSE) {
dphi.deta = dtheta.deta(phi, .lphi, earg= .ephi)
dlambda.deta = dtheta.deta(lambda, .llambda, earg= .elambda )
ans = w * cbind(dl.dphi * dphi.deta, dl.dlambda * dlambda.deta)
- if(.llambda == "loge" && (any(lambda[!index0] < .Machine$double.eps))) {
+ if (.llambda == "loge" && (any(lambda[!index0] < .Machine$double.eps))) {
ans[!index0,2] = w[!index0] * (y[!index0] - lambda[!index0])
}
ans
@@ -853,9 +869,9 @@ dposnegbin = function(x, munb, k, log=FALSE) {
wz[,iam(1,1,M)] = d2l.dphi2 * dphi.deta^2
wz[,iam(2,2,M)] = d2l.dlambda2 * dlambda.deta^2
wz[,iam(1,2,M)] = d2l.dphilambda * dphi.deta * dlambda.deta
- if(.llambda == "loge" && (any(lambda[!index0] < .Machine$double.eps))) {
+ if (.llambda == "loge" && (any(lambda[!index0] < .Machine$double.eps))) {
ind5 = !index0 & (lambda < .Machine$double.eps)
- if(any(ind5))
+ if (any(ind5))
wz[ind5,iam(2,2,M)] = (1-phi[ind5]) * .Machine$double.eps
}
w * wz
@@ -866,19 +882,19 @@ dposnegbin = function(x, munb, k, log=FALSE) {
zibinomial = function(lphi="logit", lmu="logit",
- ephi=list(), emu=list(),
+ ephi=list(), emu=list(),
iphi=NULL, zero=1, mv=FALSE)
{
- if(as.logical(mv)) stop("argument 'mv' must be FALSE")
- if(mode(lphi) != "character" && mode(lphi) != "name")
+ if (as.logical(mv)) stop("argument 'mv' must be FALSE")
+ if (mode(lphi) != "character" && mode(lphi) != "name")
lphi = as.character(substitute(lphi))
- if(mode(lmu) != "character" && mode(lmu) != "name")
+ if (mode(lmu) != "character" && mode(lmu) != "name")
lmu = as.character(substitute(lmu))
- if(is.Numeric(iphi))
- if(!is.Numeric(iphi, allow=1, posit=TRUE) || iphi >= 1)
- stop("iphi must be a single number inside the interval (0,1)")
- if(!is.list(ephi)) ephi = list()
- if(!is.list(emu)) emu = list()
+ if (is.Numeric(iphi))
+ if (!is.Numeric(iphi, posit=TRUE) || any(iphi >= 1))
+ stop("'iphi' values must be inside the interval (0,1)")
+ if (!is.list(ephi)) ephi = list()
+ if (!is.list(emu)) emu = list()
new("vglmff",
blurb=c("Zero-inflated binomial\n\n",
@@ -891,20 +907,20 @@ dposnegbin = function(x, munb, k, log=FALSE) {
initialize=eval(substitute(expression({
{
NCOL = function (x)
- if(is.array(x) && length(dim(x)) > 1 ||
+ if (is.array(x) && length(dim(x)) > 1 ||
is.data.frame(x)) ncol(x) else as.integer(1)
- if(NCOL(y) == 1) {
- if(is.factor(y)) y = y != levels(y)[1]
+ if (NCOL(y) == 1) {
+ if (is.factor(y)) y = y != levels(y)[1]
nn = rep(1, n)
- if(!all(y >= 0 & y <= 1))
+ if (!all(y >= 0 & y <= 1))
stop("response values must be in [0, 1]")
mustart = (0.5 + w * y) / (1 + w)
no.successes = w * y
- if(any(abs(no.successes - round(no.successes)) > 0.001))
+ if (any(abs(no.successes - round(no.successes)) > 0.001))
stop("Number of successes must be integer-valued")
- } else if(NCOL(y) == 2) {
- if(any(abs(y - round(y)) > 0.001))
+ } 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)
@@ -916,10 +932,11 @@ dposnegbin = function(x, munb, k, log=FALSE) {
predictors.names = c( namesof("phi", .lphi, earg= .ephi, tag=FALSE),
namesof("mu", .lmu, earg= .emu, tag=FALSE))
- phi.init = if(length( .iphi)) .iphi else {
+ phi.init = if (length( .iphi)) .iphi else {
sum(w[y==0]) / sum(w)
}
- if(phi.init <= 0 || phi.init >=1) phi.init = 0.1 # Last resort
+ phi.init[phi.init <= 0.0] = 0.1 # Last resort
+ phi.init[phi.init >= 1.0] = 0.1 # Last resort
mustart = cbind(rep(phi.init, len=n), mustart) # 1st coln not a real mu
}), list( .lphi=lphi, .lmu=lmu,
.ephi=ephi, .emu=emu,
@@ -931,9 +948,9 @@ dposnegbin = function(x, munb, k, log=FALSE) {
}, list( .lphi=lphi, .lmu=lmu,
.ephi=ephi, .emu=emu ))),
last=eval(substitute(expression({
- misc$link <- c("phi" = .lphi, "mu" = .lmu)
- misc$earg <- list("phi" = .ephi, "mu" = .emu )
- if(intercept.only && all(w==w[1])) {
+ misc$link = c("phi" = .lphi, "mu" = .lmu)
+ misc$earg = list("phi" = .ephi, "mu" = .emu )
+ if (intercept.only && all(w==w[1])) {
phi = eta2theta(eta[1,1], .lphi, earg= .ephi )
mubin = eta2theta(eta[1,2], .lmu, earg= .emu )
misc$p0 = phi + (1-phi) * (1-mubin)^w[1] # P(Y=0)
@@ -949,7 +966,7 @@ dposnegbin = function(x, munb, k, log=FALSE) {
function(mu,y,w,residuals=FALSE, eta, extra=NULL) {
phi = eta2theta(eta[,1], .lphi, earg= .ephi )
mubin = eta2theta(eta[,2], .lmu, earg= .emu )
- if(residuals) stop("loglikelihood residuals not implemented yet") else {
+ if (residuals) stop("loglikelihood residuals not implemented yet") else {
sum(dzibinom(x=round(w*y), size=w, prob=mubin, log=TRUE, phi=phi))
}
}, list( .lphi=lphi, .lmu=lmu,
@@ -969,7 +986,7 @@ dposnegbin = function(x, munb, k, log=FALSE) {
dphi.deta = dtheta.deta(phi, .lphi, earg= .ephi )
dmubin.deta = dtheta.deta(mubin, .lmu, earg= .emu )
ans = cbind(dl.dphi * dphi.deta, dl.dmubin * dmubin.deta)
- if(.lmu == "logit") {
+ if (.lmu == "logit") {
ans[!index,2] = w[!index] * (y[!index] - mubin[!index])
}
ans
@@ -984,9 +1001,9 @@ dposnegbin = function(x, munb, k, log=FALSE) {
wz[,iam(1,1,M)] = d2l.dphi2 * dphi.deta^2
wz[,iam(2,2,M)] = d2l.dmubin2 * dmubin.deta^2
wz[,iam(1,2,M)] = d2l.dphimubin * dphi.deta * dmubin.deta
- if(TRUE) {
- ind6 = wz[,iam(2,2,M)] < .Machine$double.eps
- if(any(ind6))
+ if (TRUE) {
+ ind6 = (wz[,iam(2,2,M)] < .Machine$double.eps)
+ if (any(ind6))
wz[ind6,iam(2,2,M)] = .Machine$double.eps
}
wz
@@ -997,27 +1014,29 @@ dposnegbin = function(x, munb, k, log=FALSE) {
dzibinom = function(x, size, prob, log = FALSE, phi=0) {
- 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)
- L = max(length(x), length(size), length(prob), length(phi))
- x = rep(x, len=L); size = rep(size, len=L);
- prob = rep(prob, len=L); phi = rep(phi, len=L);
+ LLL = max(length(x), length(size), length(prob), length(phi))
+ 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(phi) != LLL) phi = rep(phi, len=LLL);
ans = dbinom(x=x, size=size, prob=prob, log=TRUE)
- if(!is.Numeric(phi) || any(phi < 0) || any(phi > 1))
- stop("phi must be between 0 and 1 inclusive")
- if(log.arg) {
+ if (!is.Numeric(phi) || any(phi < 0) || any(phi > 1))
+ stop("'phi' must be between 0 and 1 inclusive")
+ if (log.arg) {
ifelse(x==0, log(phi + (1-phi) * exp(ans)), log1p(-phi) + ans)
} else {
- ifelse(x==0, phi + (1-phi) * exp(ans), (1-phi) * exp(ans))
+ ifelse(x==0, phi + (1-phi) * exp(ans) , (1-phi) * exp(ans))
}
}
pzibinom = function(q, size, prob, lower.tail = TRUE, log.p = FALSE, phi=0) {
ans = pbinom(q, size, prob, lower.tail = lower.tail, log.p = log.p)
phi = rep(phi, length=length(ans))
- if(!is.Numeric(phi) || any(phi < 0) || any(phi > 1))
- stop("phi must be between 0 and 1 inclusive")
+ if (!is.Numeric(phi) || any(phi < 0) || any(phi > 1))
+ stop("'phi' must be between 0 and 1 inclusive")
phi + (1-phi) * ans
}
@@ -1027,8 +1046,8 @@ qzibinom = function(p, size, prob, lower.tail = TRUE, log.p = FALSE, phi=0) {
size = rep(size, len=nn)
prob = rep(prob, len=nn)
phi = rep(phi, len=nn)
- if(!is.Numeric(phi) || any(phi < 0) || any(phi > 1))
- stop("phi must be between 0 and 1 inclusive")
+ if (!is.Numeric(phi) || any(phi < 0) || any(phi > 1))
+ stop("'phi' must be between 0 and 1 inclusive")
ans = p
ans[p<=phi] = 0
ans[p>phi] = qbinom((p[p>phi]-phi[p>phi])/(1-phi[p>phi]), size[p>phi],
@@ -1037,12 +1056,12 @@ qzibinom = function(p, size, prob, lower.tail = TRUE, log.p = FALSE, phi=0) {
}
rzibinom = function(n, size, prob, phi=0) {
- if(!is.Numeric(n, positive=TRUE, integer=TRUE, allow=1))
+ if (!is.Numeric(n, positive=TRUE, integer=TRUE, allow=1))
stop("n must be a single positive integer")
ans = rbinom(n, size, prob)
phi = rep(phi, len=length(ans))
- if(!is.Numeric(phi) || any(phi < 0) || any(phi > 1))
- stop("phi must be between 0 and 1 inclusive")
+ if (!is.Numeric(phi) || any(phi < 0) || any(phi > 1))
+ stop("'phi' must be between 0 and 1 inclusive")
ifelse(runif(n) < phi, 0, ans)
}
@@ -1061,16 +1080,16 @@ dzinegbin = function(x, phi, size, prob=NULL, munb=NULL, log=FALSE) {
stop("'prob' and 'munb' both specified")
prob <- size/(size + munb)
}
- 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(!is.logical(log.arg) || length(log.arg) != 1)
+ if (!is.logical(log.arg) || length(log.arg) != 1)
stop("bad input for 'log.arg'")
ans = dnbinom(x=x, size=size, prob=prob, log = log.arg)
- if(!is.Numeric(phi) || any(phi < 0) || any(phi > 1))
+ if (!is.Numeric(phi) || any(phi < 0) || any(phi > 1))
stop("'phi' must be between 0 and 1 inclusive")
phi = rep(phi, length=length(ans))
- if(log.arg) ifelse(x==0, log(phi+(1-phi)*exp(ans)), log1p(-phi) + ans) else
- ifelse(x==0, phi + (1-phi) * ans, (1-phi) * ans)
+ if (log.arg) ifelse(x==0, log(phi+(1-phi)*exp(ans)), log1p(-phi) + ans) else
+ ifelse(x==0, phi+(1-phi)* ans, (1-phi) * ans)
}
pzinegbin = function(q, phi, size, prob=NULL, munb=NULL) {
@@ -1080,7 +1099,7 @@ pzinegbin = function(q, phi, size, prob=NULL, munb=NULL) {
prob <- size/(size + munb)
}
ans = pnbinom(q=q, size=size, prob=prob)
- if(!is.Numeric(phi) || any(phi < 0) || any(phi > 1))
+ if (!is.Numeric(phi) || any(phi < 0) || any(phi > 1))
stop("'phi' must be between 0 and 1 inclusive")
phi + (1-phi) * ans
}
@@ -1091,17 +1110,19 @@ qzinegbin = function(p, phi, size, prob=NULL, munb=NULL) {
stop("'prob' and 'munb' both specified")
prob <- size/(size + munb)
}
- nn = max(length(p), length(prob), length(phi), length(size))
- p = rep(p, len=nn)
- phi = rep(phi, len=nn)
- prob = rep(prob, len=nn)
- size = rep(size, len=nn)
- if(!is.Numeric(phi) || any(phi < 0) || any(phi > 1))
+ LLL = max(length(p), length(prob), length(phi), length(size))
+ if (length(p) != LLL) p = rep(p, len=LLL)
+ if (length(phi) != LLL) phi = rep(phi, len=LLL);
+ if (length(prob) != LLL) prob = rep(prob, len=LLL)
+ if (length(size) != LLL) size = rep(size, len=LLL);
+
+ if (!is.Numeric(phi) || any(phi < 0) || any(phi > 1))
stop("'phi' must be between 0 and 1 inclusive")
ans = p
- ans[p<=phi] = 0
- ans[p>phi] = qnbinom(p=(p[p>phi]-phi[p>phi])/(1-phi[p>phi]),
- size=size[p>phi], prob=prob[p>phi])
+ ind4 = (p > phi)
+ ans[!ind4] = 0
+ ans[ ind4] = qnbinom(p = (p[ind4]-phi[ind4])/(1-phi[ind4]),
+ size=size[ind4], prob=prob[ind4])
ans
}
@@ -1111,13 +1132,16 @@ rzinegbin = function(n, phi, size, prob=NULL, munb=NULL) {
stop("'prob' and 'munb' both specified")
prob <- size/(size + munb)
}
- if(!is.Numeric(n, positive=TRUE, integer=TRUE, allow=1))
- stop("'n' must be a single positive integer")
- ans = rnbinom(n=n, size=size, prob=prob)
- if(!is.Numeric(phi) || any(phi < 0) || any(phi > 1))
+
+ use.n = if ((length.n <- length(n)) > 1) length.n else
+ if (!is.Numeric(n, integ=TRUE, allow=1, posit=TRUE))
+ stop("bad input for argument 'n'") else n
+
+ ans = rnbinom(n=use.n, size=size, prob=prob)
+ if (!is.Numeric(phi) || any(phi < 0) || any(phi > 1))
stop("'phi' must be between 0 and 1 inclusive")
phi = rep(phi, len=length(ans))
- ifelse(runif(n) < phi, rep(0, n), ans)
+ ifelse(runif(use.n) < phi, rep(0, use.n), ans)
}
@@ -1138,28 +1162,28 @@ zinegbinomial.control <- function(save.weight=TRUE, ...)
{
- if(length(iphi) && (!is.Numeric(iphi, positiv=TRUE) || any(iphi >= 1)))
+ if (length(iphi) && (!is.Numeric(iphi, positiv=TRUE) || any(iphi >= 1)))
stop("'iphi' must contain values in (0,1)")
- if(length(ik) && !is.Numeric(ik, positiv=TRUE))
+ if (length(ik) && !is.Numeric(ik, positiv=TRUE))
stop("'ik' must contain positive values only")
- if(!is.Numeric(method.init, allow=1, integ=TRUE, posit=TRUE) ||
+ if (!is.Numeric(method.init, allow=1, integ=TRUE, posit=TRUE) ||
method.init > 3) stop("argument 'method.init' must be 1, 2 or 3")
- if(!is.Numeric(nsimEIM, allow=1, integ=TRUE))
+ if (!is.Numeric(nsimEIM, allow=1, integ=TRUE))
stop("'nsimEIM' must be a positive integer")
- if(nsimEIM <= 10)
+ if (nsimEIM <= 10)
warning("'nsimEIM' should be greater than 10, say")
- if(!is.Numeric(shrinkage.init, allow=1) || shrinkage.init < 0 ||
+ if (!is.Numeric(shrinkage.init, allow=1) || shrinkage.init < 0 ||
shrinkage.init > 1) stop("bad input for argument 'shrinkage.init'")
- if(mode(lmunb) != "character" && mode(lmunb) != "name")
+ if (mode(lmunb) != "character" && mode(lmunb) != "name")
lmunb = as.character(substitute(lmunb))
- if(mode(lk) != "character" && mode(lk) != "name")
+ if (mode(lk) != "character" && mode(lk) != "name")
lk = as.character(substitute(lk))
- if(mode(lphi) != "character" && mode(lphi) != "name")
+ if (mode(lphi) != "character" && mode(lphi) != "name")
lphi = as.character(substitute(lphi))
- if(!is.list(ephi)) ephi = list()
- if(!is.list(emunb)) emunb = list()
- if(!is.list(ek)) ek = list()
+ if (!is.list(ephi)) ephi = list()
+ if (!is.list(emunb)) emunb = list()
+ if (!is.list(ek)) ek = list()
new("vglmff",
blurb=c("Zero-inflated negative binomial\n\n",
@@ -1170,39 +1194,39 @@ zinegbinomial.control <- function(save.weight=TRUE, ...)
"Mean: (1-phi) * munb"),
constraints=eval(substitute(expression({
temp752 = .zero
- if(length(temp752) && all(temp752 == -3))
+ if (length(temp752) && all(temp752 == -3))
temp752 = 3*(1:ncol(y))
constraints = cm.zero.vgam(constraints, x, temp752, M)
}), list( .zero=zero ))),
initialize=eval(substitute(expression({
y = as.matrix(y)
extra$NOS = NOS = ncoly = ncol(y) # Number of species
- if(length(dimnames(y)))
+ if (length(dimnames(y)))
extra$dimnamesy2 = dimnames(y)[[2]]
- mynames1 = if(NOS==1) "phi" else paste("phi", 1:NOS, sep="")
- mynames2 = if(NOS==1) "munb" else paste("munb", 1:NOS, sep="")
- mynames3 = if(NOS==1) "k" else paste("k", 1:NOS, sep="")
+ mynames1 = if (NOS==1) "phi" else paste("phi", 1:NOS, sep="")
+ mynames2 = if (NOS==1) "munb" else paste("munb", 1:NOS, sep="")
+ mynames3 = if (NOS==1) "k" else paste("k", 1:NOS, sep="")
predictors.names =
c(namesof(mynames1, .lphi, earg= .ephi, tag= FALSE),
namesof(mynames2, .lmunb, earg= .emunb, tag= FALSE),
namesof(mynames3, .lk, earg= .ek, tag= FALSE))
predictors.names = predictors.names[interleave.VGAM(3*NOS, M=3)]
- if(!length(etastart)) {
- mu.init = if( .method.init == 3) {
+ if (!length(etastart)) {
+ mu.init = if ( .method.init == 3) {
y + 1/16
} else {
mu.init = y
for(iii in 1:ncol(y)) {
index = (y[,iii] > 0)
- mu.init[,iii] = if( .method.init == 2)
+ mu.init[,iii] = if ( .method.init == 2)
weighted.mean(y[index,iii], w=w[index]) else
median(rep(y[index,iii], w[index])) + 1/8
}
(1- .sinit) * (y+1/16) + .sinit * mu.init
}
- phi.init = if(length( .iphi))
+ phi.init = if (length( .iphi))
matrix( .iphi, n, ncoly, byrow=TRUE) else {
phi.init = y
for(iii in 1:ncol(y))
@@ -1213,7 +1237,7 @@ zinegbinomial.control <- function(save.weight=TRUE, ...)
}
kay.init =
- if( is.Numeric( .ik )) {
+ if ( is.Numeric( .ik )) {
matrix( .ik, nr=n, nc=ncoly, byrow=TRUE)
} else {
zinegbin.Loglikfun = function(kval, y, x, w, extraargs) {
@@ -1244,16 +1268,17 @@ zinegbinomial.control <- function(save.weight=TRUE, ...)
theta2eta(kay.init, .lk, earg= .ek))
etastart = etastart[,interleave.VGAM(ncol(etastart),M=3)]
}
- }), list( .lphi=lphi, .lmunb=lmunb, .lk=lk, .iphi=iphi, .ik=ik,
- .sinit=shrinkage.init,
+ }), list( .lphi=lphi, .lmunb=lmunb, .lk=lk,
+ .iphi=iphi, .ik=ik,
.ephi=ephi, .emunb=emunb, .ek=ek,
+ .sinit=shrinkage.init,
.method.init=method.init ))),
inverse=eval(substitute(function(eta, extra=NULL) {
NOS = extra$NOS
phi = eta2theta(eta[,3*(1:NOS)-2,drop=FALSE], .lphi, earg= .ephi )
munb = eta2theta(eta[,3*(1:NOS)-1,drop=FALSE], .lmunb, earg= .emunb )
fv.matrix = (1 - phi) * munb
- if(length(extra$dimnamesy2))
+ if (length(extra$dimnamesy2))
dimnames(fv.matrix) = list(dimnames(phi)[[1]], extra$dimnamesy2)
fv.matrix
}, list( .lphi=lphi, .lk=lk, .lmunb=lmunb,
@@ -1274,7 +1299,7 @@ zinegbinomial.control <- function(save.weight=TRUE, ...)
misc$method.init = .method.init
misc$nsimEIM = .nsimEIM
misc$expected = TRUE
- if(intercept.only) {
+ if (intercept.only) {
phi = eta2theta(eta[1,3*(1:NOS)-2], .lphi, earg= .ephi)
munb = eta2theta(eta[1,3*(1:NOS)-1], .lmunb, earg= .emunb )
kval = eta2theta(eta[1,3*(1:NOS)], .lk, earg= .ek)
@@ -1289,7 +1314,7 @@ zinegbinomial.control <- function(save.weight=TRUE, ...)
phi = eta2theta(eta[,3*(1:NOS)-2,drop=FALSE], .lphi, earg= .ephi )
munb = eta2theta(eta[,3*(1:NOS)-1,drop=FALSE], .lmunb, earg= .emunb )
kmat = eta2theta(eta[,3*(1:NOS), drop=FALSE], .lk, earg= .ek )
- if(residuals) stop("loglikelihood residuals not implemented yet") else {
+ if (residuals) stop("loglikelihood residuals not implemented yet") else {
sum(w*dzinegbin(x=y, phi=phi, munb=munb, size=kmat, log=TRUE))
}
}, list( .lphi=lphi, .lmunb=lmunb, .lk=lk,
@@ -1311,7 +1336,7 @@ zinegbinomial.control <- function(save.weight=TRUE, ...)
dl.dthetas = matrix(0, n, M) # M=3*NOS; for all species
for(spp. in 1:NOS) {
index = (y[,spp.] == 0)
- if(!sum(index) || !sum(!index))
+ if (!sum(index) || !sum(!index))
stop("must have some 0s AND some positive counts in the data")
yvec. = y[index,spp.]
@@ -1370,7 +1395,7 @@ zinegbinomial.control <- function(save.weight=TRUE, ...)
run.varcov = ((ii-1) * run.varcov +
temp3[,ind1$row.index]*temp3[,ind1$col.index]) / ii
}
- wz1 = if(intercept.only)
+ wz1 = if (intercept.only)
matrix(colMeans(run.varcov),
nr=n, nc=ncol(run.varcov), byrow=TRUE) else run.varcov
diff --git a/R/fitted.vlm.q b/R/fitted.vlm.R
similarity index 76%
rename from R/fitted.vlm.q
rename to R/fitted.vlm.R
index e6b7289..7a09e5e 100644
--- a/R/fitted.vlm.q
+++ b/R/fitted.vlm.R
@@ -1,5 +1,5 @@
# These functions are
-# Copyright (C) 1998-2009 T.W. Yee, University of Auckland. All rights reserved.
+# Copyright (C) 1998-2010 T.W. Yee, University of Auckland. All rights reserved.
@@ -7,19 +7,19 @@ fitted.vlm <- function(object, matrix.arg=TRUE, ...)
{
answer =
- if(matrix.arg)
+ if (matrix.arg)
object at fitted.values else
{
- if(!is.matrix(object at fitted.values) || !length(object at fitted.values))
+ if (!is.matrix(object at fitted.values) || !length(object at fitted.values))
stop("object at fitted.values is not a matrix or is empty")
- if(ncol(object at fitted.values) == 1)
+ if (ncol(object at fitted.values) == 1)
c(object at fitted.values) else {
warning("ncol(object at fitted.values) is not 1")
c(object at fitted.values)
}
}
- if(length(answer) && length(object at na.action)) {
+ if (length(answer) && length(object at na.action)) {
napredict(object at na.action[[1]], answer)
} else {
answer
@@ -46,19 +46,19 @@ setMethod("fitted", "vglm",
predictors.vglm <- function(object, matrix=TRUE, ...)
{
answer =
- if(matrix)
+ if (matrix)
object at predictors else
{
- if(!is.matrix(object at predictors) || !length(object at predictors))
+ if (!is.matrix(object at predictors) || !length(object at predictors))
stop("object at predictors is not a matrix or is empty")
- if(ncol(object at predictors) == 1)
+ if (ncol(object at predictors) == 1)
c(object at predictors) else {
warning("ncol(object at predictors) is not 1")
c(object at predictors)
}
}
- if(length(answer) && length(object at na.action)) {
+ if (length(answer) && length(object at na.action)) {
napredict(object at na.action[[1]], answer)
} else {
answer
diff --git a/R/formula.vlm.q b/R/formula.vlm.q
index 26bd76b..3c099bd 100644
--- a/R/formula.vlm.q
+++ b/R/formula.vlm.q
@@ -1,5 +1,5 @@
# These functions are
-# Copyright (C) 1998-2009 T.W. Yee, University of Auckland. All rights reserved.
+# Copyright (C) 1998-2010 T.W. Yee, University of Auckland. All rights reserved.
@@ -8,14 +8,14 @@
formulavlm = function(x, fnumber=1, ...) {
- if(!is.Numeric(fnumber, integ=TRUE, allow=1, posit=TRUE) ||
+ if (!is.Numeric(fnumber, integ=TRUE, allow=1, posit=TRUE) ||
fnumber > 2)
stop("argument 'fnumber' must be 1 or 2")
- if(!any(slotNames(x) == "misc"))
+ if (!any(slotNames(x) == "misc"))
stop("cannot find slot 'misc'")
- if(fnumber == 1) x at misc$formula else x at misc$form2
+ if (fnumber == 1) x at misc$formula else x at misc$form2
}
@@ -65,15 +65,15 @@ setMethod("formula", "grc",
variable.namesvlm <- function(object, full = FALSE, ...) {
qrslot <- object at qr
- if(!length(qrslot$qr)) {
+ if (!length(qrslot$qr)) {
use.this <- object at x
- if(!length(use.this))
+ if (!length(use.this))
stop("argument 'object' has empty 'qr' and 'x' slots.")
} else {
use.this = qrslot$qr
}
- if(full) dimnames(use.this)[[2]] else
- if(object at rank) dimnames(use.this)[[2]][seq_len(object at rank)] else
+ if (full) dimnames(use.this)[[2]] else
+ if (object at rank) dimnames(use.this)[[2]][seq_len(object at rank)] else
character(0)
}
@@ -83,9 +83,9 @@ variable.namesvlm <- function(object, full = FALSE, ...) {
variable.namesrrvglm <- function(object, ...) {
qrslot <- object at qr
- if(!length(qrslot$qr)) {
+ if (!length(qrslot$qr)) {
use.this <- object at x
- if(!length(use.this))
+ if (!length(use.this))
stop("argument 'object' has empty 'qr' and 'x' slots.")
} else {
use.this = qrslot$qr
@@ -102,14 +102,14 @@ variable.namesrrvglm <- function(object, ...) {
case.namesvlm <- function(object, full = FALSE, ...) {
w <- weights(object, type="prior")
use.this <- residuals(object, type="working")
- if(!length(use.this))
+ if (!length(use.this))
use.this <- object at x
- if(!length(use.this))
+ if (!length(use.this))
use.this <- object at y
- if(!length(use.this))
+ if (!length(use.this))
stop("argument 'object' has empty 'x' and 'y' slots.")
dn <- dimnames(use.this)[[1]]
- if(full || is.null(w) || ncol(cbind(w)) != 1) dn else dn[w!=0]
+ if (full || is.null(w) || ncol(cbind(w)) != 1) dn else dn[w!=0]
}
diff --git a/R/generic.q b/R/generic.q
index 884c489..057ff49 100644
--- a/R/generic.q
+++ b/R/generic.q
@@ -1,5 +1,5 @@
# These functions are
-# Copyright (C) 1998-2009 T.W. Yee, University of Auckland. All rights reserved.
+# Copyright (C) 1998-2010 T.W. Yee, University of Auckland. All rights reserved.
add1.vgam <- function(...)
diff --git a/R/links.q b/R/links.q
index 4336647..86b3738 100644
--- a/R/links.q
+++ b/R/links.q
@@ -1,5 +1,5 @@
# These functions are
-# Copyright (C) 1998-2009 T.W. Yee, University of Auckland. All rights reserved.
+# Copyright (C) 1998-2010 T.W. Yee, University of Auckland. All rights reserved.
@@ -18,7 +18,8 @@
TypicalVGAMfamilyFunction <- function(lsigma="loge", esigma=list(),
isigma=NULL, parallel=TRUE,
- shrinkage.init = 0.95, method.init=1,
+ shrinkage.init = 0.95,
+ nointercept = NULL, method.init=1,
nsimEIM=100, zero=NULL) {
NULL
}
@@ -55,25 +56,25 @@ theta2eta <- function(theta, link, earg=list()) {
eta2theta <- function(theta, link="identity", earg=list()) {
- if(is.null(link))
+ if (is.null(link))
link <- "identity"
llink <- length(link)
- if(llink == 1) {
+ if (llink == 1) {
string <- paste(link, "(theta=theta, earg=earg, inverse=TRUE)", sep="")
calls <- parse(text=string)[[1]]
return(eval(calls))
} else
- if(llink > 1) {
- if(is.matrix(theta) && llink == ncol(theta)) {
+ if (llink > 1) {
+ if (is.matrix(theta) && llink == ncol(theta)) {
ans <- NULL
for(iii in 1:llink) {
- use.earg = if(is.list(earg) && length(earg)==llink &&
+ use.earg = if (is.list(earg) && length(earg)==llink &&
is.list(earg[[iii]])) earg[[iii]] else earg
string = paste(link[iii],
"(theta=theta[,iii], earg=use.earg, inverse=TRUE)",
@@ -82,10 +83,10 @@ eta2theta <- function(theta, link="identity", earg=list()) {
ans <- cbind(ans, eval(calls))
}
} else {
- if(length(theta) < llink)
+ if (length(theta) < llink)
theta = rep(theta, len=llink)
- if(length(theta) != llink)
+ if (length(theta) != llink)
stop("length of theta and link don't match")
ans <- NULL
@@ -135,18 +136,18 @@ d2theta.deta2 <- function(theta, link, earg=list())
loglog <- function(theta, earg=list(), inverse=FALSE, deriv=0,
short=TRUE, tag=FALSE)
{
- if(is.character(theta)) {
- string <- if(short)
+ if (is.character(theta)) {
+ string <- if (short)
paste("loglog(",theta,")", sep="") else
paste("log(log(",theta,"))", sep="")
- if(tag)
+ if (tag)
string <- paste("Log-Log:", string)
return(string)
}
- if(!inverse && is.list(earg) && length(earg$bval))
+ if (!inverse && is.list(earg) && length(earg$bval))
theta[theta <= 1.0] <- earg$bval
- if(inverse) {
- if(deriv>0) {
+ if (inverse) {
+ if (deriv>0) {
1 / Recall(theta=theta, earg=earg, inverse=FALSE, deriv=deriv)
} else {
exp(exp(theta))
@@ -168,20 +169,20 @@ loglog <- function(theta, earg=list(), inverse=FALSE, deriv=0,
cloglog <- function(theta, earg=list(), inverse=FALSE, deriv=0,
short=TRUE, tag=FALSE)
{
- if(is.character(theta)) {
- string <- if(short)
+ if (is.character(theta)) {
+ string <- if (short)
paste("cloglog(",theta,")", sep="") else
paste("log(-log(1-",theta,"))", sep="")
- if(tag)
+ if (tag)
string <- paste("Complementary log-log:", string)
return(string)
}
- if(!inverse && is.list(earg) && length(earg$bval)) {
+ if (!inverse && is.list(earg) && length(earg$bval)) {
theta[theta <= 0.0] <- earg$bval
theta[theta >= 1.0] <- 1.0 - earg$bval
}
- if(inverse) {
- if(deriv>0) {
+ if (inverse) {
+ if (deriv>0) {
1 / Recall(theta=theta, earg=earg, inverse=FALSE, deriv=deriv)
} else {
junk <- exp(theta)
@@ -204,36 +205,36 @@ cloglog <- function(theta, earg=list(), inverse=FALSE, deriv=0,
probit <- function(theta, earg=list(), inverse=FALSE, deriv=0,
short=TRUE, tag=FALSE)
{
- if(is.character(theta)) {
- string <- if(short)
+ if (is.character(theta)) {
+ string <- if (short)
paste("probit(",theta,")", sep="") else
paste("qnorm(", theta, ")", sep="")
- if(tag)
+ if (tag)
string <- paste("Probit:", string)
return(string)
}
- if(!inverse && is.list(earg) && length(earg$bval)) {
+ if (!inverse && is.list(earg) && length(earg$bval)) {
theta[theta <= 0.0] <- earg$bval
theta[theta >= 1.0] <- 1-earg$bval
}
- if(inverse) {
- if(deriv>0) {
+ if (inverse) {
+ if (deriv>0) {
1/Recall(theta=theta, earg=earg, inverse=FALSE, deriv=deriv)
} else {
ans <- pnorm(theta)
- if(is.matrix(theta))
+ if (is.matrix(theta))
dim(ans) <- dim(theta)
ans
}
} else {
switch(deriv+1,{
ans <- qnorm(theta)
- if(is.matrix(theta))
+ if (is.matrix(theta))
dim(ans) <- dim(theta)
ans
},
{
- if(is.matrix(theta)) {
+ if (is.matrix(theta)) {
ans <- dnorm(qnorm(theta))
dim(ans) <- dim(theta)
ans
@@ -242,8 +243,8 @@ probit <- function(theta, earg=list(), inverse=FALSE, deriv=0,
{
junk <- qnorm(theta)
ans <- -junk * dnorm(junk)
- if(is.vector(theta)) ans else
- if(is.matrix(theta)) {
+ if (is.vector(theta)) ans else
+ if (is.matrix(theta)) {
dim(ans) <- dim(theta)
ans
} else {
@@ -264,18 +265,18 @@ probit <- function(theta, earg=list(), inverse=FALSE, deriv=0,
loge <- function(theta, earg=list(), inverse=FALSE, deriv=0,
short=TRUE, tag=FALSE)
{
- if(is.character(theta)) {
- string <- if(short)
+ if (is.character(theta)) {
+ string <- if (short)
paste("log(",theta,")", sep="") else
paste("log(", theta, ")", sep="")
- if(tag)
+ if (tag)
string <- paste("Log:", string)
return(string)
}
- if(!inverse && is.list(earg) && length(earg$bval))
+ if (!inverse && is.list(earg) && length(earg$bval))
theta[theta <= 0.0] <- earg$bval
- if(inverse) {
- if(deriv>0) {
+ if (inverse) {
+ if (deriv>0) {
1/Recall(theta=theta, earg=earg, inverse=FALSE, deriv=deriv)
} else {
exp(theta)
@@ -294,14 +295,14 @@ loge <- function(theta, earg=list(), inverse=FALSE, deriv=0,
identity <- function(theta, earg=list(), inverse=FALSE, deriv=0,
short=TRUE, tag=FALSE)
{
- if(is.character(theta)) {
+ if (is.character(theta)) {
string <- theta
- if(tag)
+ if (tag)
string <- paste("Identity:", string)
return(string)
}
- if(inverse) {
- if(deriv>0) {
+ if (inverse) {
+ if (deriv>0) {
1 / Recall(theta=theta, earg=earg, inverse=FALSE, deriv=deriv)
} else {
theta
@@ -317,14 +318,14 @@ identity <- function(theta, earg=list(), inverse=FALSE, deriv=0,
nidentity <- function(theta, earg=list(), inverse=FALSE, deriv=0,
short=TRUE, tag=FALSE)
{
- if(is.character(theta)) {
+ if (is.character(theta)) {
string <- paste("-", theta, sep="")
- if(tag)
+ if (tag)
string <- paste("Negative-Identity:", string)
return(string)
}
- if(inverse) {
- if(deriv>0) {
+ if (inverse) {
+ if (deriv>0) {
1 / Recall(theta=theta, earg=earg, inverse=FALSE, deriv=deriv)
} else {
-theta
@@ -341,16 +342,16 @@ nidentity <- function(theta, earg=list(), inverse=FALSE, deriv=0,
reciprocal <- function(theta, earg=list(), inverse.arg=FALSE, deriv=0,
short=TRUE, tag=FALSE)
{
- if(is.character(theta)) {
+ if (is.character(theta)) {
string <- paste("1/",theta, sep="")
- if(tag)
+ if (tag)
string <- paste("Reciprocal:", string)
return(string)
}
- if(!inverse.arg && is.list(earg) && length(earg$bval))
+ if (!inverse.arg && is.list(earg) && length(earg$bval))
theta[theta == 0.0] <- earg$bval
- if(inverse.arg) {
- if(deriv>0) {
+ if (inverse.arg) {
+ if (deriv>0) {
1 / Recall(theta=theta, earg=earg, inverse.arg=FALSE, deriv=deriv)
} else {
1/theta
@@ -367,18 +368,18 @@ reciprocal <- function(theta, earg=list(), inverse.arg=FALSE, deriv=0,
nloge <- function(theta, earg=list(), inverse=FALSE, deriv=0,
short=TRUE, tag=FALSE)
{
- if(is.character(theta)) {
- string <- if(short)
+ if (is.character(theta)) {
+ string <- if (short)
paste("-log(",theta,")", sep="") else
paste("-log(", theta, ")", sep="")
- if(tag)
+ if (tag)
string <- paste("Negative log:", string)
return(string)
}
- if(!inverse && is.list(earg) && length(earg$bval))
+ if (!inverse && is.list(earg) && length(earg$bval))
theta[theta <= 0.0] <- earg$bval
- if(inverse) {
- if(deriv>0) {
+ if (inverse) {
+ if (deriv>0) {
1/Recall(theta=theta, earg=earg, inverse=FALSE, deriv=deriv)
} else {
exp(-theta)
@@ -396,16 +397,16 @@ nloge <- function(theta, earg=list(), inverse=FALSE, deriv=0,
nreciprocal <- function(theta, earg=list(), inverse.arg=FALSE, deriv=0,
short=TRUE, tag=FALSE)
{
- if(is.character(theta)) {
+ if (is.character(theta)) {
string <- paste("-1/",theta, sep="")
- if(tag)
+ if (tag)
string <- paste("Negative reciprocal:", string)
return(string)
}
- if(!inverse.arg && is.list(earg) && length(earg$bval))
+ if (!inverse.arg && is.list(earg) && length(earg$bval))
theta[theta == 0.0] <- earg$bval
- if(inverse.arg) {
- if(deriv>0) {
+ if (inverse.arg) {
+ if (deriv>0) {
1 / nreciprocal(theta, earg=earg, inverse.arg=FALSE, deriv)
} else {
-1/theta
@@ -423,14 +424,14 @@ natural.ig <- function(theta, earg=list(), inverse=FALSE, deriv=0,
short=TRUE, tag=FALSE)
{
- if(is.character(theta)) {
+ if (is.character(theta)) {
string <- paste("-1/",theta, sep="")
- if(tag)
+ if (tag)
string <- paste("Negative inverse:", string)
return(string)
}
- if(inverse) {
- if(deriv>0) {
+ if (inverse) {
+ if (deriv>0) {
1 / nreciprocal(theta, earg=earg, inverse=FALSE, deriv)
} else {
1/ sqrt(-2*theta)
@@ -450,24 +451,24 @@ natural.ig <- function(theta, earg=list(), inverse=FALSE, deriv=0,
rhobit <- function(theta, earg=list(), inverse=FALSE, deriv=0,
short=TRUE, tag=FALSE)
{
- if(is.character(theta)) {
- string <- if(short)
+ if (is.character(theta)) {
+ string <- if (short)
paste("rhobit(",theta,")", sep="") else
paste("log((1+", theta, ")/(1-", theta, "))", sep="")
- if(tag)
+ if (tag)
string <- paste("Rhobit:", string)
return(string)
}
- if(!inverse && is.list(earg) && length(earg)) {
- bminvalue = if(length(earg$bminval)) earg$bminval else NULL
- bmaxvalue = if(length(earg$bmaxval)) earg$bmaxval else NULL
- if(!inverse && length(bminvalue)) theta[theta <= -1.0] <- bminvalue
- if(!inverse && length(bmaxvalue)) theta[theta >= 1.0] <- bmaxvalue
+ if (!inverse && is.list(earg) && length(earg)) {
+ bminvalue = if (length(earg$bminval)) earg$bminval else NULL
+ bmaxvalue = if (length(earg$bmaxval)) earg$bmaxval else NULL
+ if (!inverse && length(bminvalue)) theta[theta <= -1.0] <- bminvalue
+ if (!inverse && length(bmaxvalue)) theta[theta >= 1.0] <- bmaxvalue
}
- if(inverse) {
- if(deriv>0) {
+ if (inverse) {
+ if (deriv>0) {
1/Recall(theta=theta, earg=earg, inverse=FALSE, deriv=deriv)
} else {
junk <- exp(theta)
@@ -486,24 +487,24 @@ rhobit <- function(theta, earg=list(), inverse=FALSE, deriv=0,
fisherz <- function(theta, earg=list(), inverse=FALSE, deriv=0,
short=TRUE, tag=FALSE)
{
- if(is.character(theta)) {
- string <- if(short)
+ if (is.character(theta)) {
+ string <- if (short)
paste("fisherz(",theta,")", sep="") else
paste("(1/2)log((1+", theta, ")/(1-", theta, "))", sep="")
- if(tag)
+ if (tag)
string <- paste("Fisher's Z transformation:", string)
return(string)
}
- if(!inverse && is.list(earg) && length(earg)) {
- bminvalue = if(length(earg$bminval)) earg$bminval else NULL
- bmaxvalue = if(length(earg$bmaxval)) earg$bmaxval else NULL
- if(!inverse && length(bminvalue)) theta[theta <= -1.0] <- bminvalue
- if(!inverse && length(bmaxvalue)) theta[theta >= 1.0] <- bmaxvalue
+ if (!inverse && is.list(earg) && length(earg)) {
+ bminvalue = if (length(earg$bminval)) earg$bminval else NULL
+ bmaxvalue = if (length(earg$bmaxval)) earg$bmaxval else NULL
+ if (!inverse && length(bminvalue)) theta[theta <= -1.0] <- bminvalue
+ if (!inverse && length(bmaxvalue)) theta[theta >= 1.0] <- bmaxvalue
}
- if(inverse) {
- if(deriv>0) {
+ if (inverse) {
+ if (deriv>0) {
1/Recall(theta=theta, earg=earg, inverse=FALSE, deriv=deriv)
} else {
junk <- exp(2*theta)
@@ -524,39 +525,39 @@ fsqrt <- function(theta, earg=list(min=0, max=1, mux=sqrt(2)),
inverse=FALSE, deriv=0, short=TRUE, tag=FALSE)
{
min=0; max=1; mux=sqrt(2)
- if(!is.list(earg)) stop("earg must be a list")
- if(is.Numeric(earg$min)) min = earg$min
- if(is.Numeric(earg$max)) max = earg$max
- if(is.Numeric(earg$mux)) mux = earg$mux
- if(!is.Numeric(min,allow=1)) stop("bad input for 'min' component")
- if(!is.Numeric(max,allow=1)) stop("bad input for 'max' component")
- if(!is.Numeric(mux,allow=1,posit=TRUE)) stop("bad input for 'mux' component")
- if(min >= max) stop("'min' >= 'max' is not allowed")
-
- if(is.character(theta)) {
- string <- if(short)
+ if (!is.list(earg)) stop("earg must be a list")
+ if (is.Numeric(earg$min)) min = earg$min
+ if (is.Numeric(earg$max)) max = earg$max
+ if (is.Numeric(earg$mux)) mux = earg$mux
+ if (!is.Numeric(min,allow=1)) stop("bad input for 'min' component")
+ if (!is.Numeric(max,allow=1)) stop("bad input for 'max' component")
+ if (!is.Numeric(mux,allow=1,posit=TRUE)) stop("bad input for 'mux' component")
+ if (min >= max) stop("'min' >= 'max' is not allowed")
+
+ if (is.character(theta)) {
+ string <- if (short)
paste("fsqrt(",theta,")", sep="") else {
- if(abs(mux-sqrt(2)) < 1.0e-10)
+ if (abs(mux-sqrt(2)) < 1.0e-10)
paste("sqrt(2*",theta,") - sqrt(2*(1-",theta,"))", sep="") else
paste(as.character(mux),
" * (sqrt(",theta,"-",min,") - sqrt(",max,"-",theta,"))", sep="")
}
- if(tag)
+ if (tag)
string <- paste("Folded Square Root:", string)
return(string)
}
- if(inverse) {
- if(deriv>0) {
+ if (inverse) {
+ if (deriv>0) {
1/Recall(theta=theta, earg=earg, inverse=FALSE, deriv=deriv)
} else {
mid = (min + max) / 2
boundary = mux * sqrt(max - min)
temp = pmax(0, (theta/mux)^2 * (2*(max-min) - (theta/mux)^2))
ans = theta
- if(any(ind5 <- theta < 0))
+ if (any(ind5 <- theta < 0))
ans[ind5] = mid - 0.5 * sqrt(temp[ind5])
- if(any(ind5 <- theta >= 0))
+ if (any(ind5 <- theta >= 0))
ans[ind5] = mid + 0.5 * sqrt(temp[ind5])
ans[theta < -boundary] <- NA
ans[theta > boundary] <- NA
@@ -576,25 +577,25 @@ powl <- function(theta, earg=list(power=1), inverse=FALSE, deriv=0,
short=TRUE, tag=FALSE)
{
- if(!length(earg) || is.list(earg)) {
- exponent = if(length(earg$power)) earg$power else 1
- if(exponent == 0)
+ if (!length(earg) || is.list(earg)) {
+ exponent = if (length(earg$power)) earg$power else 1
+ if (exponent == 0)
stop("use the 'loge' link")
} else {
stop("'earg' must be a list or NULL")
}
- if(is.character(theta)) {
- string <- if(short)
+ if (is.character(theta)) {
+ string <- if (short)
paste("powl(",theta,", earg=list(power=", as.character(exponent),
"))", sep="") else
paste(theta, "^(", as.character(exponent), ")", sep="")
- if(tag)
+ if (tag)
string <- paste("Power:", string)
return(string)
}
- if(inverse) {
- if(deriv>0) {
+ if (inverse) {
+ if (deriv>0) {
1/Recall(theta=theta, earg=earg, inverse=FALSE, deriv=deriv)
} else {
theta^(1/exponent)
@@ -617,33 +618,33 @@ powl <- function(theta, earg=list(power=1), inverse=FALSE, deriv=0,
elogit <- function(theta, earg=list(min=0, max=1), inverse=FALSE, deriv=0,
short=TRUE, tag=FALSE)
{
- if(!length(earg) || is.list(earg)) {
- A = if(length(earg$min)) earg$min else 0
- B = if(length(earg$max)) earg$max else 1
- bminvalue = if(length(earg$bminval)) earg$bminval else NULL
- bmaxvalue = if(length(earg$bmaxval)) earg$bmaxval else NULL
- if(!inverse && length(bminvalue)) theta[theta <= A] <- bminvalue
- if(!inverse && length(bmaxvalue)) theta[theta >= B] <- bmaxvalue
+ if (!length(earg) || is.list(earg)) {
+ A = if (length(earg$min)) earg$min else 0
+ B = if (length(earg$max)) earg$max else 1
+ bminvalue = if (length(earg$bminval)) earg$bminval else NULL
+ bmaxvalue = if (length(earg$bmaxval)) earg$bmaxval else NULL
+ if (!inverse && length(bminvalue)) theta[theta <= A] <- bminvalue
+ if (!inverse && length(bmaxvalue)) theta[theta >= B] <- bmaxvalue
} else {
stop("'earg' must be a list or NULL")
}
- if(is.character(theta)) {
- string <- if(short) {
- if(A != 0 || B != 1)
+ if (is.character(theta)) {
+ string <- if (short) {
+ if (A != 0 || B != 1)
paste("elogit(",theta,", earg=list(min=",A,
", max=",B,"))",sep="") else
paste("elogit(",theta,")",sep="")
} else
paste("log((",theta,"-min)/(max-",theta,"))", sep="")
- if(tag)
+ if (tag)
string <- paste("Extended logit:", string)
return(string)
}
- if(inverse) {
- if(deriv>0) {
+ if (inverse) {
+ if (deriv>0) {
1/Recall(theta=theta, earg=earg, inverse=FALSE, deriv=deriv)
} else {
- junk <- if(is.R()) care.exp(theta) else care.exp(theta)
+ junk <- if (is.R()) care.exp(theta) else care.exp(theta)
(A + B*junk) / (1.0 + junk)
}
} else {
@@ -661,20 +662,20 @@ elogit <- function(theta, earg=list(min=0, max=1), inverse=FALSE, deriv=0,
logit <- function(theta, earg=list(), inverse=FALSE, deriv=0,
short=TRUE, tag=FALSE)
{
- if(is.character(theta)) {
- string <- if(short)
+ if (is.character(theta)) {
+ string <- if (short)
paste("logit(",theta,")", sep="") else
paste("log(",theta,"/(1-",theta,"))", sep="")
- if(tag)
+ if (tag)
string <- paste("Logit:", string)
return(string)
}
- if(!inverse && is.list(earg) && length(earg$bval)) {
+ if (!inverse && is.list(earg) && length(earg$bval)) {
theta[theta <= 0.0] <- earg$bval;
theta[theta >= 1.0] <- 1.0 - earg$bval;
}
- if(inverse) {
- if(deriv>0) {
+ if (inverse) {
+ if (deriv>0) {
1/Recall(theta=theta, earg=earg, inverse=FALSE, deriv=deriv)
} else {
eta <- care.exp(theta)
@@ -683,7 +684,7 @@ elogit <- function(theta, earg=list(min=0, max=1), inverse=FALSE, deriv=0,
} else {
switch(deriv+1, {
temp2 = log(theta) - log1p(-theta)
- if(any(near0.5 <- (abs(theta - 0.5) < 0.000125)))
+ if (any(near0.5 <- (abs(theta - 0.5) < 0.000125)))
temp2[near0.5] = log(theta[near0.5] / (1-theta[near0.5]))
temp2
},
@@ -696,21 +697,21 @@ elogit <- function(theta, earg=list(min=0, max=1), inverse=FALSE, deriv=0,
logc <- function(theta, earg=list(), inverse=FALSE, deriv=0,
short=TRUE, tag=FALSE)
{
- if(is.character(theta)) {
- string <- if(short)
+ if (is.character(theta)) {
+ string <- if (short)
paste("logc(",theta,")", sep="") else
paste("log(1-",theta,")", sep="")
- if(tag)
+ if (tag)
string <- paste("Log Complementary:", string)
return(string)
}
- if(!inverse && is.list(earg) && length(earg$bval)) {
+ if (!inverse && is.list(earg) && length(earg$bval)) {
theta[theta >= 1.0] <- earg$bval;
}
- if(inverse) {
- if(deriv>0) {
+ if (inverse) {
+ if (deriv>0) {
1 / Recall(theta=theta, earg=earg, inverse=FALSE, deriv=deriv)
} else {
-expm1(theta)
@@ -728,26 +729,26 @@ logc <- function(theta, earg=list(), inverse=FALSE, deriv=0,
logoff <- function(theta, earg=list(offset=0), inverse=FALSE, deriv=0,
short=TRUE, tag=FALSE)
{
- if(!length(earg) || is.list(earg)) {
- offset = if(length(earg$offset)) earg$offset else 0
+ if (!length(earg) || is.list(earg)) {
+ offset = if (length(earg$offset)) earg$offset else 0
} else {
stop("'earg' must be a list or NULL")
}
- if(!is.Numeric(offset))
+ if (!is.Numeric(offset))
stop("bad input for argument 'earg'")
- if(is.character(theta)) {
- string <- if(short)
+ if (is.character(theta)) {
+ string <- if (short)
paste("logoff(",theta,
", list(offset=",as.character(offset),"))", sep="") else
paste("log(", as.character(offset), "+", theta, ")", sep="")
- if(tag)
+ if (tag)
string <- paste("Log with offset:", string)
return(string)
}
- if(inverse) {
- if(deriv>0) {
+ if (inverse) {
+ if (deriv>0) {
1/Recall(theta=theta, earg=earg, inverse=FALSE, deriv=deriv)
} else {
exp(theta) - offset
@@ -766,18 +767,18 @@ nlogoff <- function(theta, earg=0, inverse=FALSE, deriv=0,
short=TRUE, tag=FALSE)
{
offset = earg
- if(!is.Numeric(offset))
+ if (!is.Numeric(offset))
stop("bad input for argument earg")
- if(is.character(theta)) {
- string <- if(short)
+ if (is.character(theta)) {
+ string <- if (short)
paste("nlogoff(",theta,",",as.character(offset),")", sep="") else
paste("log(", as.character(offset), "-", theta, ")", sep="")
- if(tag)
+ if (tag)
string <- paste("Negative-log with offset:", string)
return(string)
}
- if(inverse) {
- if(deriv>0) {
+ if (inverse) {
+ if (deriv>0) {
1/Recall(theta=theta, earg=earg, inverse=FALSE, deriv=deriv)
} else {
offset - exp(theta)
@@ -796,20 +797,20 @@ cauchit <- function(theta, earg=list(bvalue= .Machine$double.eps),
inverse=FALSE, deriv=0,
short=TRUE, tag=FALSE)
{
- if(is.character(theta)) {
- string <- if(short)
+ if (is.character(theta)) {
+ string <- if (short)
paste("cauchit(",theta,")", sep="") else
paste("tan(pi*(",theta,"-0.5))", sep="")
- if(tag)
+ if (tag)
string <- paste("Cauchit:", string)
return(string)
}
- if(!inverse && is.list(earg) && length(earg$bval)) {
+ if (!inverse && is.list(earg) && length(earg$bval)) {
theta[theta <= 0.0] <- earg$bval
theta[theta >= 1.0] <- 1.0 - earg$bval
}
- if(inverse) {
- if(deriv>0) {
+ if (inverse) {
+ if (deriv>0) {
1/Recall(theta=theta, earg=earg, inverse=FALSE, deriv=deriv)
} else {
0.5 + atan(theta)/pi
@@ -830,66 +831,66 @@ golf <- function(theta, earg=list(lambda=1), inverse=FALSE, deriv=0,
cutpoint = lambda = NULL
- if(!length(earg)) {
+ if (!length(earg)) {
lambda = 1
cutpoint = NULL
- } else if(is.list(earg)) {
+ } else if (is.list(earg)) {
lambda = earg$lambda
cutpoint = earg$cutpoint # Optional; if so then is a NULL
} else
stop("'earg' must be a list")
- if(!is.Numeric(lambda, posit=TRUE))
+ if (!is.Numeric(lambda, posit=TRUE))
stop('could not determine lambda or lambda has negative values')
- if(is.Numeric(cutpoint))
- if(any(cutpoint < 0) || !is.Numeric(cutpoint, integer=TRUE))
+ if (is.Numeric(cutpoint))
+ if (any(cutpoint < 0) || !is.Numeric(cutpoint, integer=TRUE))
warning("'cutpoint' should contain non-negative integer values")
- if(is.character(theta)) {
- string <- if(short) {
+ if (is.character(theta)) {
+ string <- if (short) {
lenl = length(lambda) > 1
lenc = length(cutpoint) > 1
paste("golf(",theta,", earg=list(lambda=",
- if(lenl) "c(" else "",
+ if (lenl) "c(" else "",
ToString(lambda),
- if(lenl) ")" else "",
- if(is.Numeric(cutpoint))
+ if (lenl) ")" else "",
+ if (is.Numeric(cutpoint))
paste(", cutpoint=",
- if(lenc) "c(" else "",
+ if (lenc) "c(" else "",
ToString(cutpoint),
- if(lenc) ")" else "",
+ if (lenc) ")" else "",
sep="") else "",
"))", sep="") } else {
- if(is.Numeric(cutpoint)) {
+ if (is.Numeric(cutpoint)) {
paste("-3*log(1-qnorm(",theta,")/(3*sqrt(lambda)))",
" + log(cutpoint)", sep="")
} else {
paste("-3*log(1-qnorm(",theta,")/(3*sqrt(lambda)))", sep="")
}
}
- if(tag)
+ if (tag)
string <- paste("Gamma-ordinal link function:", string)
return(string)
}
thmat = cbind(theta)
lambda = rep(lambda, len=ncol(thmat)) # Allow recycling for lambda
- if(is.Numeric(cutpoint)) cutpoint = rep(cutpoint, len=ncol(thmat))
- if(ncol(thmat) > 1) {
+ if (is.Numeric(cutpoint)) cutpoint = rep(cutpoint, len=ncol(thmat))
+ if (ncol(thmat) > 1) {
answer = thmat
for(ii in 1:ncol(thmat))
answer[,ii] = Recall(theta=thmat[,ii],
earg=list(lambda=lambda[ii],
- cutpoint=if(is.Numeric(cutpoint)) cutpoint[ii] else NULL),
- inverse=inverse, deriv=deriv)
+ cutpoint = if (is.Numeric(cutpoint)) cutpoint[ii] else NULL),
+ inverse=inverse, deriv=deriv)
return(answer)
}
answer =
- if(inverse) {
- if(deriv>0) {
+ if (inverse) {
+ if (deriv>0) {
1 / Recall(theta=theta, earg=earg, inverse=FALSE, deriv=deriv)
} else {
- if(is.Numeric(cutpoint)) {
+ if (is.Numeric(cutpoint)) {
pnorm((1-care.exp(-(theta-log(cutpoint))/3)) * 3 * sqrt(lambda))
} else {
pnorm((1-care.exp(-theta/3)) * 3 * sqrt(lambda))
@@ -904,12 +905,12 @@ golf <- function(theta, earg=list(lambda=1), inverse=FALSE, deriv=0,
switch(deriv+1, {
temp = Ql / (3*sqrt(lambda))
temp = pmin(temp, 1.0 - smallno) # 100 / .Machine$double.eps
- -3*log(1-temp) + if(is.Numeric(cutpoint)) log(cutpoint) else 0},
+ -3*log(1-temp) + if (is.Numeric(cutpoint)) log(cutpoint) else 0},
(1 - Ql / (3*sqrt(lambda))) * sqrt(lambda) * dnorm(Ql),
{ stop('cannot handle deriv=2') },
stop("'deriv' unmatched"))
}
- if(!is.Numeric(answer)) stop("the answer contains some NAs")
+ if (!is.Numeric(answer)) stop("the answer contains some NAs")
answer
}
@@ -918,32 +919,32 @@ polf <- function(theta, earg=stop("'earg' must be given"),
inverse=FALSE, deriv=0, short=TRUE, tag=FALSE)
{
cutpoint = NULL
- if(is.Numeric(earg)) cutpoint = earg
- if(is.list(earg)) cutpoint = earg$cutpoint
- if(!is.Numeric(cutpoint))
+ if (is.Numeric(earg)) cutpoint = earg
+ if (is.list(earg)) cutpoint = earg$cutpoint
+ if (!is.Numeric(cutpoint))
stop('could not determine the cutpoint')
- if(any(cutpoint < 0) || !is.Numeric(cutpoint, integer=TRUE))
+ if (any(cutpoint < 0) || !is.Numeric(cutpoint, integer=TRUE))
warning("'cutpoint' should contain non-negative integer values")
- if(is.character(theta)) {
- string <- if(short) {
+ if (is.character(theta)) {
+ string <- if (short) {
lenc = length(cutpoint) > 1
paste("polf(",theta,", earg=list(cutpoint=",
- if(lenc) "c(" else "",
+ if (lenc) "c(" else "",
ToString(cutpoint),
- if(lenc) ")" else "",
+ if (lenc) ")" else "",
"))", sep="")
} else
paste("2*log(0.5*qnorm(",theta,") + sqrt(cutpoint+7/8))", sep="")
- if(tag)
+ if (tag)
string <- paste("Poisson-ordinal link function:", string)
return(string)
}
thmat = cbind(theta)
- if(ncol(thmat) > 1) {
+ if (ncol(thmat) > 1) {
answer = thmat
cutpoint = rep(cutpoint, len=ncol(thmat)) # Reqd for the for loop
for(ii in 1:ncol(thmat))
@@ -953,18 +954,18 @@ polf <- function(theta, earg=stop("'earg' must be given"),
}
answer =
- if(inverse) {
- if(deriv>0) {
+ if (inverse) {
+ if (deriv>0) {
1 / Recall(theta=theta, earg=earg, inverse=FALSE, deriv=deriv)
} else {
- if(cutpoint == 0) {
+ if (cutpoint == 0) {
cloglog(theta=theta, earg=earg, inverse=inverse, deriv=deriv)
} else {
pnorm(2 * exp(theta/2) - 2 * sqrt(cutpoint + 7/8))
}
}
} else {
- if(cutpoint == 0) {
+ if (cutpoint == 0) {
cloglog(theta=theta, earg=earg, inverse=inverse, deriv=deriv)
} else {
smallno = 1 * .Machine$double.eps
@@ -982,7 +983,7 @@ polf <- function(theta, earg=stop("'earg' must be given"),
stop("'deriv' unmatched"))
}
}
- if(!is.Numeric(answer)) stop("the answer contains some NAs")
+ if (!is.Numeric(answer)) stop("the answer contains some NAs")
answer
}
@@ -992,34 +993,34 @@ nbolf <- function(theta, earg=stop("'earg' must be given"),
{
cutpoint = kay = NULL
- if(is.list(earg)) {
+ if (is.list(earg)) {
cutpoint = earg$cutpoint
kay = earg$k
}
- if(!is.Numeric(kay, positive=TRUE))
+ if (!is.Numeric(kay, positive=TRUE))
stop("could not determine 'k' or it is not positive-valued")
- if(!is.Numeric(cutpoint))
+ if (!is.Numeric(cutpoint))
stop("could not determine the cutpoint")
- if(any(cutpoint < 0) || !is.Numeric(cutpoint, integer=TRUE))
+ if (any(cutpoint < 0) || !is.Numeric(cutpoint, integer=TRUE))
warning("'cutpoint' should contain non-negative integer values")
- if(is.character(theta)) {
- string <- if(short) {
+ if (is.character(theta)) {
+ string <- if (short) {
lenc = length(cutpoint) > 1
lenk = length(kay) > 1
paste("nbolf(",theta,", earg=list(cutpoint=",
- if(lenc) "c(" else "",
+ if (lenc) "c(" else "",
ToString(cutpoint),
- if(lenc) ")" else "",
+ if (lenc) ")" else "",
", k=",
- if(lenk) "c(" else "",
+ if (lenk) "c(" else "",
ToString(kay),
- if(lenk) ")" else "",
+ if (lenk) ")" else "",
"))", sep="")
} else
paste("2*log(sqrt(k) * sinh(qnorm(",theta,")/(2*sqrt(k)) + ",
"asinh(sqrt(cutpoint/k))))", sep="")
- if(tag)
+ if (tag)
string <- paste("Negative binomial-ordinal link function:", string)
return(string)
}
@@ -1027,7 +1028,7 @@ nbolf <- function(theta, earg=stop("'earg' must be given"),
thmat = cbind(theta)
kay = rep(kay, len=ncol(thmat)) # Allow recycling for kay
cutpoint = rep(cutpoint, len=ncol(thmat)) # Allow recycling for cutpoint
- if(ncol(thmat) > 1) {
+ if (ncol(thmat) > 1) {
answer = thmat
for(ii in 1:ncol(thmat))
answer[,ii] = Recall(theta=thmat[,ii],
@@ -1037,11 +1038,11 @@ nbolf <- function(theta, earg=stop("'earg' must be given"),
}
answer =
- if(inverse) {
- if(deriv>0) {
+ if (inverse) {
+ if (deriv>0) {
1 / Recall(theta=theta, earg=earg, inverse=FALSE, deriv=deriv)
} else {
- if(cutpoint == 0) {
+ if (cutpoint == 0) {
1.0 - (kay / (kay + care.exp(theta)))^kay
} else {
pnorm((asinh(exp(theta/2)/sqrt(kay)) -
@@ -1054,7 +1055,7 @@ nbolf <- function(theta, earg=stop("'earg' must be given"),
Theta = theta
Theta = pmin(Theta, 1 - smallno) # Since theta==1 is a possibility
Theta = pmax(Theta, smallno) # Since theta==0 is a possibility
- if(cutpoint == 0) {
+ if (cutpoint == 0) {
switch(deriv+1, {
temp = (1 - Theta)^(-1/kay) - 1
temp = pmax(temp, SMALLNO)
@@ -1075,7 +1076,7 @@ nbolf <- function(theta, earg=stop("'earg' must be given"),
stop("'deriv' unmatched"))
}
}
- if(!is.Numeric(answer)) stop("the answer contains some NAs")
+ if (!is.Numeric(answer)) stop("the answer contains some NAs")
answer
}
@@ -1088,40 +1089,40 @@ nbolf2 <- function(theta, earg=stop("'earg' must be given"),
{
cutpoint = kay = NULL
- if(is.list(earg)) {
+ if (is.list(earg)) {
cutpoint = earg$cutpoint
kay = earg$k
}
- if(!is.Numeric(kay, positive=TRUE))
+ if (!is.Numeric(kay, positive=TRUE))
stop("could not determine 'k' or it is not positive-valued")
- if(!is.Numeric(cutpoint))
+ if (!is.Numeric(cutpoint))
stop("could not determine the cutpoint")
- if(any(cutpoint < 0) || !is.Numeric(cutpoint, integer=TRUE))
+ if (any(cutpoint < 0) || !is.Numeric(cutpoint, integer=TRUE))
warning("'cutpoint' should contain non-negative integer values")
- if(is.character(theta)) {
- string <- if(short) {
+ if (is.character(theta)) {
+ string <- if (short) {
lenc = length(cutpoint) > 1
lenk = length(kay) > 1
paste("nbolf2(",theta,", earg=list(cutpoint=",
- if(lenc) "c(" else "",
+ if (lenc) "c(" else "",
ToString(cutpoint),
- if(lenc) ")" else "",
+ if (lenc) ")" else "",
", k=",
- if(lenk) "c(" else "",
+ if (lenk) "c(" else "",
ToString(kay),
- if(lenk) ")" else "",
+ if (lenk) ")" else "",
"))", sep="")
} else
paste("3*log(<a complicated expression>)", sep="")
- if(tag)
+ if (tag)
string = paste("Negative binomial-ordinal link function 2:", string)
return(string)
}
thmat = cbind(theta)
kay = rep(kay, len=ncol(thmat)) # Allow recycling for kay
- if(ncol(thmat) > 1) {
+ if (ncol(thmat) > 1) {
answer = thmat
for(ii in 1:ncol(thmat))
answer[,ii] = Recall(theta=thmat[,ii],
@@ -1131,11 +1132,11 @@ nbolf2 <- function(theta, earg=stop("'earg' must be given"),
}
answer =
- if(inverse) {
- if(deriv>0) {
+ if (inverse) {
+ if (deriv>0) {
1 / Recall(theta=theta, earg=earg, inverse=FALSE, deriv=deriv)
} else {
- if(cutpoint == 0) {
+ if (cutpoint == 0) {
1.0 - (kay / (kay + care.exp(theta)))^kay
} else {
@@ -1156,7 +1157,7 @@ nbolf2 <- function(theta, earg=stop("'earg' must be given"),
}
rankmat = t(apply(abs(theta2 - theta), 1, rank))
for(ii in 2:4) {
- if(any(index4 <- (rankmat[,ii] == 1))) {
+ if (any(index4 <- (rankmat[,ii] == 1))) {
invfun[index4,1] = invfun[index4,ii]
}
}
@@ -1169,7 +1170,7 @@ nbolf2 <- function(theta, earg=stop("'earg' must be given"),
Theta = theta
Theta = pmin(Theta, 1 - smallno) # Since theta==1 is a possibility
Theta = pmax(Theta, smallno) # Since theta==0 is a possibility
- if(cutpoint == 0) {
+ if (cutpoint == 0) {
switch(deriv+1, {
temp = (1 - Theta)^(-1/kay) - 1
temp = pmax(temp, SMALLNO)
@@ -1201,7 +1202,7 @@ nbolf2 <- function(theta, earg=stop("'earg' must be given"),
stop("'deriv' unmatched"))
}
}
- if(!is.Numeric(answer)) stop("the answer contains some NAs")
+ if (!is.Numeric(answer)) stop("the answer contains some NAs")
answer
}
@@ -1213,13 +1214,13 @@ Cut = function(y, breaks=c(-Inf, quantile(c(y), prob = (1:4)/4))) {
temp = cut(y, breaks=breaks, labels=FALSE)
temp = c(temp) # integer vector of integers
- if(any(is.na(temp))) stop("there are NAs")
- answer = if(ncol(y) > 1) matrix(temp, nrow(y), ncol(y)) else temp
- if(ncol(y) > 1) {
+ if (any(is.na(temp))) stop("there are NAs")
+ answer = if (ncol(y) > 1) matrix(temp, nrow(y), ncol(y)) else temp
+ if (ncol(y) > 1) {
ynames = dimnames(y)[[2]]
- if(!length(ynames)) ynames = paste("Y", 1:ncol(y), sep="")
+ if (!length(ynames)) ynames = paste("Y", 1:ncol(y), sep="")
xnames = dimnames(y)[[1]]
- if(!length(xnames)) xnames = as.character(1:nrow(y))
+ if (!length(xnames)) xnames = as.character(1:nrow(y))
dimnames(answer) = list(xnames, ynames)
}
attr(answer, "breaks") = breaks
@@ -1228,14 +1229,14 @@ Cut = function(y, breaks=c(-Inf, quantile(c(y), prob = (1:4)/4))) {
checkCut = function(y) {
- if(!is.Numeric(y, posi=TRUE, integ=TRUE))
+ if (!is.Numeric(y, posi=TRUE, integ=TRUE))
stop("'y' must contain positive integers only")
uy = unique(y)
L = max(uy)
oklevels = 1:L
- if(L == 1) stop("only one unique value")
+ if (L == 1) stop("only one unique value")
for(ii in oklevels) {
- if(all(ii != uy)) stop("there is no ", ii, " value")
+ if (all(ii != uy)) stop("there is no ", ii, " value")
}
TRUE
}
diff --git a/R/logLik.vlm.q b/R/logLik.vlm.q
index 0e682fe..3e8faef 100644
--- a/R/logLik.vlm.q
+++ b/R/logLik.vlm.q
@@ -1,12 +1,12 @@
# These functions are
-# Copyright (C) 1998-2009 T.W. Yee, University of Auckland. All rights reserved.
+# Copyright (C) 1998-2010 T.W. Yee, University of Auckland. All rights reserved.
logLik.vlm <- function(object, ...)
object at criterion$loglikelihood
-if(!isGeneric("logLik"))
+if (!isGeneric("logLik"))
setGeneric("logLik", function(object, ...) standardGeneric("logLik"))
setMethod("logLik", "vlm", function(object, ...)
@@ -20,12 +20,12 @@ setMethod("logLik", "vgam", function(object, ...)
-if(TRUE) {
+if (TRUE) {
constraints.vlm <- function(object, all=TRUE, which, ...)
- if(all) slot(object, "constraints") else
+ if (all) slot(object, "constraints") else
slot(object, "constraints")[[which]]
-if(!isGeneric("constraints"))
+if (!isGeneric("constraints"))
setGeneric("constraints", function(object, ...) standardGeneric("constraints"))
setMethod("constraints", "vlm", function(object, ...)
constraints.vlm(object, ...))
diff --git a/R/model.matrix.vglm.q b/R/model.matrix.vglm.q
index f9fba4d..e25ca7e 100644
--- a/R/model.matrix.vglm.q
+++ b/R/model.matrix.vglm.q
@@ -1,5 +1,5 @@
# These functions are
-# Copyright (C) 1998-2009 T.W. Yee, University of Auckland. All rights reserved.
+# Copyright (C) 1998-2010 T.W. Yee, University of Auckland. All rights reserved.
@@ -12,13 +12,13 @@
attrassigndefault = function(mmat, tt) {
- if(!inherits(tt, "terms"))
+ if (!inherits(tt, "terms"))
stop("need terms object")
aa = attr(mmat, "assign")
- if(is.null(aa))
+ if (is.null(aa))
stop("argument is not really a model matrix")
ll = attr(tt, "term.labels")
- if(attr(tt, "intercept") > 0)
+ if (attr(tt, "intercept") > 0)
ll = c("(Intercept)", ll)
aaa = factor(aa, labels = ll)
split(order(aa), aaa)
@@ -32,11 +32,11 @@
vlabel = function(xn, ncolBlist, M, separator=":") {
- if(length(xn) != length(ncolBlist))
+ if (length(xn) != length(ncolBlist))
stop("length of first two arguments not equal")
n1 = rep(xn, ncolBlist)
- if(M == 1)
+ if (M == 1)
return(n1)
n2 = as.list(ncolBlist)
n2 = lapply(n2, seq)
@@ -56,32 +56,32 @@
- if(length(Blist) != ncol(x))
+ if (length(Blist) != ncol(x))
stop("length(Blist) != ncol(x)")
- if(length(xij)) {
- if(inherits(xij, "formula"))
+ if (length(xij)) {
+ if (inherits(xij, "formula"))
xij = list(xij)
- if(!is.list(xij))
+ if (!is.list(xij))
stop("'xij' is not a list of formulae")
}
- if(!is.numeric(M))
+ if (!is.numeric(M))
M = nrow(Blist[[1]])
nrow_X_lm = nrow(x)
- if(all(trivial.constraints(Blist) == 1)) {
- X_vlm = if(M > 1) kronecker(x, diag(M)) else x
+ if (all(trivial.constraints(Blist) == 1)) {
+ X_vlm = if (M > 1) kronecker(x, diag(M)) else x
ncolBlist = rep(M, ncol(x))
} else {
allB = matrix(unlist(Blist), nrow=M)
ncolBlist = unlist(lapply(Blist, ncol))
Rsum = sum(ncolBlist)
- X1 = rep(c(t(x)), rep(ncolBlist,nrow_X_lm))
+ X1 = rep(c(t(x)), rep(ncolBlist, nrow_X_lm))
dim(X1) = c(Rsum, nrow_X_lm)
- X_vlm = kronecker(t(X1), matrix(1,M,1)) *
- kronecker(matrix(1,nrow_X_lm,1), allB)
+ X_vlm = kronecker(t(X1), matrix(1, M, 1)) *
+ kronecker(matrix(1, nrow_X_lm, 1), allB)
rm(X1)
}
@@ -91,7 +91,7 @@
dimnames(X_vlm) = list(vlabel(yn, rep(M, nrow_X_lm), M),
vlabel(xn, ncolBlist, M))
- if(assign.attributes) {
+ if (assign.attributes) {
attr(X_vlm, "contrasts") = attr(x, "contrasts")
attr(X_vlm, "factors") = attr(x, "factors")
attr(X_vlm, "formula") = attr(x, "formula")
@@ -106,7 +106,7 @@
nasgn[[ii]] = (lowind+1):(lowind+mylen)
lowind = lowind + mylen
} # End of ii
- if(lowind != ncol(X_vlm))
+ if (lowind != ncol(X_vlm))
stop("something gone wrong")
attr(X_vlm, "assign") = nasgn
@@ -125,10 +125,10 @@
attr(X_vlm, "vassign") = vasgn
attr(X_vlm, "constraints") = Blist
- } # End of if(assign.attributes)
+ } # End of if (assign.attributes)
- if(!length(xij)) return(X_vlm)
+ if (!length(xij)) return(X_vlm)
@@ -142,11 +142,11 @@
for(ii in 1:length(xij)) {
form.xij = xij[[ii]]
- if(length(form.xij) != 3)
+ if (length(form.xij) != 3)
stop("xij[[", ii, "]] is not a formula with a response")
tform.xij = terms(form.xij)
aterm.form = attr(tform.xij, "term.labels") # Does not include response
- if(length(aterm.form) != M)
+ if (length(aterm.form) != M)
stop("xij[[", ii, "]] does not contain ", M, " terms")
name.term.y = as.character(form.xij)[2]
@@ -176,7 +176,7 @@
} # End of bbb
} # End of for(ii in 1:length(xij))
- if(assign.attributes) {
+ if (assign.attributes) {
attr(X_vlm, "vassign") = vasgn
attr(X_vlm, "assign") = nasgn
attr(X_vlm, "xij") = xij
@@ -194,7 +194,7 @@
- if(mode(type) != "character" && mode(type) != "name")
+ if (mode(type) != "character" && mode(type) != "name")
type = as.character(substitute(type))
type = match.arg(type, c("vlm","lm","lm2","bothlmlm2"))[1]
@@ -203,10 +203,10 @@
x = slot(object, "x")
Xm2 = slot(object, "Xm2")
- if(!length(x)) {
+ if (!length(x)) {
data = model.frame(object, xlev=object at xlevels, ...)
- kill.con = if(length(object at contrasts)) object at contrasts else NULL
+ kill.con = if (length(object at contrasts)) object at contrasts else NULL
x = vmodel.matrix.default(object, data=data,
contrasts.arg = kill.con)
@@ -214,11 +214,11 @@
attr(x, "assign") = attrassigndefault(x, tt)
}
- if((type == "lm2" || type == "bothlmlm2") && !length(Xm2)) {
+ 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))
+ kill.con = if (length(object.copy2 at contrasts))
object.copy2 at contrasts else NULL
Xm2 = vmodel.matrix.default(object.copy2, data=data,
@@ -229,11 +229,11 @@
- if(type == "lm") {
+ if (type == "lm") {
return(x)
- } else if(type == "lm2") {
+ } else if (type == "lm2") {
return(Xm2)
- } else if(type == "bothlmlm2") {
+ } else if (type == "bothlmlm2") {
return(list(X=x, Xm2=Xm2))
} else {
M = object at misc$M
@@ -259,13 +259,13 @@ setMethod("model.matrix", "vlm", function(object, ...)
dots = list(...)
nargs = dots[match(c("data", "na.action", "subset"), names(dots), 0)]
- if(length(nargs) || !length(object at model)) {
+ 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)) {
+ if (setupsmart && length(object at smart.prediction)) {
setup.smart("read", smart.prediction=object at smart.prediction)
}
@@ -275,7 +275,7 @@ setMethod("model.matrix", "vlm", function(object, ...)
env = parent.frame()
ans = eval(fcall, env, parent.frame())
- if(wrapupsmart && length(object at smart.prediction)) {
+ if (wrapupsmart && length(object at smart.prediction)) {
wrapup.smart()
}
ans
@@ -283,7 +283,7 @@ setMethod("model.matrix", "vlm", function(object, ...)
}
-if(!isGeneric("model.frame"))
+if (!isGeneric("model.frame"))
setGeneric("model.frame", function(formula, ...)
standardGeneric("model.frame"))
diff --git a/R/mux.q b/R/mux.q
index 2361901..b92aafd 100644
--- a/R/mux.q
+++ b/R/mux.q
@@ -1,5 +1,5 @@
# These functions are
-# Copyright (C) 1998-2009 T.W. Yee, University of Auckland. All rights reserved.
+# Copyright (C) 1998-2010 T.W. Yee, University of Auckland. All rights reserved.
@@ -7,13 +7,13 @@
mux34 <- function(xmat, cc, symmetric=FALSE)
{
- if(!is.matrix(xmat))
+ if (!is.matrix(xmat))
xmat <- as.matrix(xmat)
d <- dim(xmat)
n <- d[1]
R <- d[2]
- if(length(cc) == 1) cc = matrix(cc, 1, 1)
- if(!is.matrix(cc)) stop("'cc' is not a matrix")
+ if (length(cc) == 1) cc = matrix(cc, 1, 1)
+ if (!is.matrix(cc)) stop("'cc' is not a matrix")
c(dotFortran(name="vgamf90mux34", as.double(xmat), as.double(cc),
as.integer(n), as.integer(R),
as.integer(symmetric), ans=as.double(rep(0.0, n)),
@@ -25,16 +25,16 @@ mux2 <- function(cc, xmat)
{
- if(!is.matrix(xmat))
+ if (!is.matrix(xmat))
xmat <- as.matrix(xmat)
d <- dim(xmat)
n <- d[1]
p <- d[2]
- if(is.matrix(cc))
+ if (is.matrix(cc))
cc <- array(cc, c(dim(cc),n))
d <- dim(cc)
M <- d[1]
- if(d[2] != p || d[3] != n)
+ if (d[2] != p || d[3] != n)
stop("dimension size inconformable")
ans <- rep(as.numeric(NA), n*M)
fred <- dotC(name="mux2", as.double(cc), as.double(t(xmat)),
@@ -58,7 +58,7 @@ mux22 <- function(cc, xmat, M, upper=FALSE, as.matrix=FALSE)
as.integer(index$row), as.integer(index$col),
as.integer(n), as.integer(M), wk=double(M*M),
as.integer(as.numeric(upper)), NAOK=TRUE)
- if(!as.matrix) fred$ans else {
+ if (!as.matrix) fred$ans else {
dim(fred$ans) <- c(M, n)
t(fred$ans)
}
@@ -75,24 +75,24 @@ mux5 <- function(cc, x, M, matrix.arg=FALSE)
dimcc <- dim(cc)
r <- dimx[2]
- if(matrix.arg) {
+ 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] ||
+ 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))
+ 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
+ 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),
@@ -102,10 +102,10 @@ mux5 <- function(cc, x, M, matrix.arg=FALSE)
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 (fred$ok3 == 0) stop("can only handle matrix.arg == 1")
- if(matrix.arg) {
+ if (matrix.arg) {
ans <- fred$ans
dim(ans) <- c(dimm(r), n)
t(ans)
@@ -120,7 +120,7 @@ mux55 <- function(evects, evals, M)
d <- dim(evects)
n <- ncol(evals)
- if(d[1]!=M || d[2]!=M || d[3]!=n || nrow(evals)!=M || ncol(evals)!=n)
+ if (d[1]!=M || d[2]!=M || d[3]!=n || nrow(evals)!=M || ncol(evals)!=n)
stop("input nonconformable")
MM12 <- M*(M+1)/2 # The answer is a full-matrix
index <- iam(NA, NA, M, both=TRUE, diag=TRUE)
@@ -140,13 +140,13 @@ mux7 <- function(cc, x)
dimx <- dim(x)
dimcc <- dim(cc)
- if(dimx[1]!=dimcc[2] || (length(dimx)==3 && dimx[3]!=dimcc[3]))
+ if (dimx[1]!=dimcc[2] || (length(dimx)==3 && dimx[3]!=dimcc[3]))
stop('input nonconformable')
M <- dimcc[1]
qq <- dimcc[2]
n <- dimcc[3]
r <- dimx[2]
- if(is.matrix(x))
+ if (is.matrix(x))
x <- array(x,c(qq,r,n))
ans <- array(NA, c(M,r,n))
@@ -161,12 +161,12 @@ mux7 <- function(cc, x)
mux9 <- function(cc, xmat)
{
- if(is.vector(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])
+ if (dimcc[1]!=dimcc[2] || dimxmat[1]!=dimcc[3] || dimxmat[2]!=dimcc[1])
stop('input nonconformable')
M <- dimcc[1]
n <- dimcc[3]
@@ -187,7 +187,7 @@ mux11 <- function(cc, xmat)
M <- dcc[1]
R <- d[2]
n <- dcc[3]
- if(M!=dcc[2] || d[1]!=n*M)
+ if (M!=dcc[2] || d[1]!=n*M)
stop("input inconformable")
Xmat <- array(c(t(xmat)), c(R,M,n))
@@ -228,9 +228,9 @@ mux15 <- function(cc, xmat)
{
n <- nrow(xmat)
M <- ncol(xmat)
- if(nrow(cc) != M || ncol(cc) != M)
+ if (nrow(cc) != M || ncol(cc) != M)
stop("input inconformable")
- if(max(abs(t(cc)-cc))>0.000001)
+ if (max(abs(t(cc)-cc))>0.000001)
stop("argument 'cc' is not symmetric")
ans <- rep(as.numeric(NA),n*M*M)
@@ -269,7 +269,7 @@ 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)
+ if (nrow(b)!=M || ncol(b)!=n)
stop("dimension size inconformable")
fred <- dotC(name="vbacksub", as.double(cc), b=as.double(b),
@@ -277,7 +277,7 @@ vbacksub <- function(cc, b, M, n)
as.integer(index$row), as.integer(index$col),
as.integer(dimm.value), NAOK=TRUE)
- if(M==1) fred$b else {
+ if (M==1) fred$b else {
dim(fred$b) <- c(M,n)
t(fred$b)
}
@@ -301,10 +301,10 @@ vchol <- function(cc, M, n, silent=FALSE)
NAOK=TRUE)
failed <- fred$ok != 1
- if((correction.needed <- any(failed))) {
+ if ((correction.needed <- any(failed))) {
index <- (1:n)[failed]
- if(!silent) {
- if(length(index) < 11)
+ if (!silent) {
+ if (length(index) < 11)
warning(paste("weight matri", ifelse(length(index)>1, "ces ","x "),
paste(index, collapse=", "), " not positive-definite", sep=""))
}
@@ -313,13 +313,13 @@ vchol <- function(cc, M, n, silent=FALSE)
ans <- fred$cc
dim(ans) <- c(MM, n)
- if(correction.needed) {
- temp <- cc[,index,drop=FALSE]
+ if (correction.needed) {
+ temp <- cc[, index, drop=FALSE]
tmp777 <- vchol.greenstadt(temp, M=M, silent=silent)
- if(length(index)==n) {
- ans=tmp777[1:nrow(ans),,drop=FALSE] # was tmp777 prior to 7/3/03
+ if (length(index) == n) {
+ ans = tmp777[1:nrow(ans),,drop=FALSE] # was tmp777 prior to 7/3/03
} else {
@@ -342,16 +342,16 @@ vchol.greenstadt <- function(cc, M, silent=FALSE)
MM <- dim(cc)[1]
n <- dim(cc)[2]
- if(!silent)
+ if (!silent)
cat(paste("Applying Greenstadt modification to", n, "matrices\n"))
temp <- veigen(cc, M=M) # , mat=TRUE)
- dim(temp$vectors) <- c(M,M,n) # Make sure (when M=1) for mux5
- dim(temp$values) <- c(M,n) # Make sure (when M=1) for mux5
+ dim(temp$vectors) <- c(M, M, n) # Make sure (when M=1) for mux5
+ dim(temp$values) <- c(M, n) # Make sure (when M=1) for mux5
- zero <- temp$values==0
- neg <- temp$values<0
- pos <- temp$values>0
+ zero <- temp$values == 0
+ neg <- temp$values < 0
+ pos <- temp$values > 0
temp$values <- abs(temp$values)
@@ -361,7 +361,7 @@ vchol.greenstadt <- function(cc, M, silent=FALSE)
temp3 <- mux55(temp$vectors, temp$values, M=M) # , matrix.arg=TRUE)
ans <- vchol(t(temp3), M=M, n=n, silent=silent) # , matrix.arg=TRUE)
- if(nrow(ans) == MM) ans else ans[1:MM,,drop=FALSE]
+ if (nrow(ans) == MM) ans else ans[1:MM, , drop=FALSE]
}
diff --git a/R/plot.vglm.q b/R/plot.vglm.q
index fedfa2c..def6e94 100644
--- a/R/plot.vglm.q
+++ b/R/plot.vglm.q
@@ -1,5 +1,5 @@
# These functions are
-# Copyright (C) 1998-2009 T.W. Yee, University of Auckland. All rights reserved.
+# Copyright (C) 1998-2010 T.W. Yee, University of Auckland. All rights reserved.
@@ -27,32 +27,32 @@ plotvgam = function(x, newdata=NULL, y=NULL, residuals=NULL, rugplot=TRUE,
na.act = x at na.action
x at na.action = list() # Don't want NAs returned from predict() or resid()
- if(!is.Numeric(varxij, integ=TRUE, allow=1, posit=TRUE))
+ if (!is.Numeric(varxij, integ=TRUE, allow=1, posit=TRUE))
stop("bad input for the 'varxij' argument")
- if(any(slotNames(x) == "control")) {
+ if (any(slotNames(x) == "control")) {
x at control$varxij = varxij
}
missing.type.residuals = missing(type.residuals)
- if(mode(type.residuals) != "character" && mode(type.residuals) != "name")
+ if (mode(type.residuals) != "character" && mode(type.residuals) != "name")
type.residuals <- as.character(substitute(type.residuals))
- if(!missing.type.residuals)
+ if (!missing.type.residuals)
type.residuals <- match.arg(type.residuals,
c("deviance","working","pearson","response"))[1]
- if(!is.Numeric(deriv.arg, integ=TRUE, allow=1) || deriv.arg<0)
+ if (!is.Numeric(deriv.arg, integ=TRUE, allow=1) || deriv.arg<0)
stop("bad input for the 'deriv' argument")
- if(se && deriv.arg>0) {
+ if (se && deriv.arg>0) {
warning("standard errors not available with derivatives. ",
"Setting 'se=FALSE'")
se = FALSE
}
preplot.object <- x at preplot
- if(!length(preplot.object)) {
+ if (!length(preplot.object)) {
preplot.object <- preplotvgam(x, newdata=newdata,
raw=raw, deriv=deriv.arg, se=se,
varxij=varxij)
@@ -61,14 +61,14 @@ plotvgam = function(x, newdata=NULL, y=NULL, residuals=NULL, rugplot=TRUE,
x at preplot = preplot.object
- if(!is.null(residuals) && length(residuals) == 1) {
- if(residuals) {
- if(missing.type.residuals) {
+ if (!is.null(residuals) && length(residuals) == 1) {
+ if (residuals) {
+ if (missing.type.residuals) {
for(rtype in type.residuals)
- if(!is.null(residuals <- resid(x, type=rtype))) break
+ if (!is.null(residuals <- resid(x, type=rtype))) break
} else {
residuals=resid(x,typ=type.residuals) #Get the prespecified type
- if(!length(residuals))
+ if (!length(residuals))
warning("residuals are NULL. Ignoring 'residuals=TRUE'")
}
} else {
@@ -76,14 +76,14 @@ plotvgam = function(x, newdata=NULL, y=NULL, residuals=NULL, rugplot=TRUE,
}
}
- if(!missing.control) {
+ if (!missing.control) {
control = c(plotvgam.control(.include.dots= FALSE, ...),
control, plotvgam.control(...))
}
x at post$plotvgam.control = control # Add it to the object
- if(plot.arg)
+ if (plot.arg)
plotpreplotvgam(preplot.object, residuals=residuals,
rugplot=rugplot, scale=scale, se=se,
offset.arg=offset.arg, deriv.arg=deriv.arg,
@@ -99,10 +99,10 @@ plotvgam = function(x, newdata=NULL, y=NULL, residuals=NULL, rugplot=TRUE,
ylim.scale <- function(ylim, scale=0) {
- if(length(ylim) != 2 || ylim[2] < ylim[1])
+ if (length(ylim) != 2 || ylim[2] < ylim[1])
stop("error in 'ylim'")
try <- ylim[2] - ylim[1]
- if(try > scale) ylim else
+ if (try > scale) ylim else
c(ylim[1]+ylim[2]-scale, ylim[1]+ylim[2]+scale) / 2
}
@@ -110,7 +110,7 @@ ylim.scale <- function(ylim, scale=0) {
getallresponses = function(xij) {
- if(!is.list(xij)) return("")
+ if (!is.list(xij)) return("")
allterms = lapply(xij, terms)
allres = NULL
@@ -137,7 +137,7 @@ headpreplotvgam = function(object, newdata=NULL,
terms <- sapply(terms, match.arg, all.terms)
Interactions <- aa$order > 1
- if(any(Interactions)) {
+ if (any(Interactions)) {
stop("cannot handle interactions")
}
@@ -147,13 +147,13 @@ headpreplotvgam = function(object, newdata=NULL,
modes <- sapply(xvars, mode)
for(term in terms[modes != "name"]) {
evars <- all.names(xvars[term], functions= FALSE, unique= TRUE)
- if(!length(evars))
+ if (!length(evars))
next
xnames[[term]] <- evars
evars <- parse(text=evars)
- if(length(evars) == 1) {
+ if (length(evars) == 1) {
evars <- evars[[1]]
- } else if( length(evars) > 1 &&
+ } else if ( length(evars) > 1 &&
any(getallresponses(object at control$xij) == names(xnames)) ) {
@@ -170,22 +170,22 @@ headpreplotvgam = function(object, newdata=NULL,
xvars <- c(as.name("list"), xvars)
mode(xvars) <- "call"
- if(length(newdata)) {
+ if (length(newdata)) {
xvars <- eval(xvars, newdata)
} else {
Call <- object at call
- if(!is.null(Call$subset) | !is.null(Call$na.action) |
+ if (!is.null(Call$subset) | !is.null(Call$na.action) |
!is.null(options("na.action")[[1]])) {
Rownames <- names(fitted(object))
- if(!(Rl <- length(Rownames)))
+ if (!(Rl <- length(Rownames)))
Rownames <- dimnames(fitted(object))[[1]]
- if(length(object at x) && !(Rl <- length(Rownames)))
+ if (length(object at x) && !(Rl <- length(Rownames)))
Rownames <- (dimnames(object at x))[[1]]
- if(length(object at y) && !(Rl <- length(Rownames)))
+ if (length(object at y) && !(Rl <- length(Rownames)))
Rownames <- (dimnames(object at y))[[1]]
- if(!(Rl <- length(Rownames)))
+ if (!(Rl <- length(Rownames)))
stop("need to have names for fitted.values ",
"when call has a 'subset' or 'na.action' argument")
@@ -226,18 +226,18 @@ preplotvgam = function(object, newdata=NULL,
- if(FALSE && !is.null(object at control$jix)) {
+ if (FALSE && !is.null(object at control$jix)) {
myxij = object at control$xij
- if(length(myxij)) {
+ if (length(myxij)) {
}
}
- pred <- if(length(newdata)) {
+ pred <- if (length(newdata)) {
predict(object, newdata, type="terms",
raw=raw, se.fit=se, deriv.arg=deriv.arg)
} else {
@@ -245,11 +245,12 @@ preplotvgam = function(object, newdata=NULL,
raw=raw, se.fit=se, deriv.arg=deriv.arg)
}
- fits <- if(is.atomic(pred)) NULL else pred$fit
- se.fit <- if(is.atomic(pred)) NULL else pred$se.fit
- if(is.null(fits))
+ fits <- if (is.atomic(pred)) NULL else pred$fit
+ se.fit <- if (is.atomic(pred)) NULL else pred$se.fit
+ if (is.null(fits))
fits <- pred
fred <- attr(fits, "vterm.assign") # NULL for M==1
+ Constant = attr(fits, "constant") # NULL if se=TRUE
gamplot <- xnames
@@ -257,18 +258,19 @@ preplotvgam = function(object, newdata=NULL,
for(term in loop.var) {
.VGAM.x <- xvars[[term]]
- myylab = if(all(substring(term, 1:nchar(term), 1:nchar(term)) != "("))
- paste("partial for", term) else term
+ myylab = if (all(substring(term, 1:nchar(term), 1:nchar(term)) != "("))
+ paste("partial for", term) else term
TT <- list(x = .VGAM.x,
y = fits[,(if(is.null(fred)) term else fred[[term]])],
- se.y = if(is.null(se.fit)) NULL else
+ se.y = if (is.null(se.fit)) NULL else
se.fit[,(if(is.null(fred)) term else fred[[term]])],
xlab = xnames[[term]],
ylab = myylab)
class(TT) <- "preplotvgam"
gamplot[[term]] <- TT
}
+ attr(gamplot, "Constant") = Constant
invisible(gamplot)
}
@@ -293,14 +295,14 @@ plotpreplotvgam <- function(x, y=NULL, residuals=NULL,
control=NULL)
{
listof <- inherits(x[[1]], "preplotvgam")
- if(listof) {
+ if (listof) {
TT <- names(x)
- if(is.null(which.term))
+ if (is.null(which.term))
which.term = TT # Plot them all
plot.no = 0
for(ii in TT) {
plot.no = plot.no + 1
- if((is.character(which.term) && any(which.term == ii)) ||
+ if ((is.character(which.term) && any(which.term == ii)) ||
(is.numeric(which.term) && any(which.term == plot.no)))
plotpreplotvgam(x[[ii]], y=NULL,
residuals, rugplot=rugplot, se=se, scale=scale,
@@ -340,7 +342,7 @@ vplot.default <- function(x, y, se.y=NULL, xlab="", ylab="",
logical=vplot.factor(factor(x), y, se.y, xlab, ylab, residuals,
rugplot, scale, se,
offset.arg=offset.arg, overlay=overlay, ...),
- if(is.numeric(x)) {
+ if (is.numeric(x)) {
vplot.numeric(as.vector(x), y, se.y, xlab, ylab,
residuals, rugplot, scale, se,
offset.arg=offset.arg, overlay=overlay, ...)
@@ -359,7 +361,7 @@ vplot.list <- function(x, y, se.y=NULL, xlab, ylab,
which.cf=NULL, ...)
{
- if(is.numeric(x[[1]])) {
+ if (is.numeric(x[[1]])) {
vplot.numeric(x[[1]], y, se.y, xlab, ylab,
residuals, rugplot, scale, se,
offset.arg=offset.arg, deriv.arg=deriv.arg,
@@ -369,7 +371,9 @@ vplot.list <- function(x, y, se.y=NULL, xlab, ylab,
}
-plotvgam.control = function(
+
+
+ plotvgam.control = function(
which.cf=NULL,
xlim=NULL, ylim=NULL,
llty=par()$lty,
@@ -400,7 +404,7 @@ plotvgam.control = function(
noxmean=noxmean,
one.at.a.time=one.at.a.time)
- if(.include.dots) {
+ if (.include.dots) {
c(list(...), ans)
} else {
default.vals = plotvgam.control()
@@ -411,10 +415,10 @@ plotvgam.control = function(
(is.logical(all.equal(ans[[ii]], default.vals[[ii]]))) &&
all.equal(ans[[ii]], default.vals[[ii]]))
- if(replace.val)
+ if (replace.val)
return.list[[ii]] = ans[[ii]]
}
- if(length(return.list)) {
+ if (length(return.list)) {
names(return.list) = names(return.list)
return.list
} else NULL
@@ -453,20 +457,20 @@ vplot.numeric <- function(x, y, se.y=NULL, xlab, ylab,
ylim0 <- ylim
- if(length(y)/length(x) != round(length(y)/length(x)))
+ if (length(y)/length(x) != round(length(y)/length(x)))
stop("length of 'x' and 'y' do not seem to match")
y <- as.matrix(y)
- if(!length(which.cf))
+ if (!length(which.cf))
which.cf = 1:ncol(y) # Added 7/8/04
- if(!is.null(se.y))
+ if (!is.null(se.y))
se.y <- as.matrix(se.y)
- if(!is.null(se.y) && any(is.na(se.y)))
+ if (!is.null(se.y) && any(is.na(se.y)))
se.y <- NULL
- if(!is.null(residuals)) {
+ if (!is.null(residuals)) {
residuals <- as.matrix(residuals)
- if(ncol(residuals) != ncol(y)) {
+ if (ncol(residuals) != ncol(y)) {
warning("ncol(residuals) != ncol(y) so residuals are not plotted")
residuals <- NULL
}
@@ -478,12 +482,12 @@ vplot.numeric <- function(x, y, se.y=NULL, xlab, ylab,
ylab <- add.hookey(ylab, deriv.arg)
- if(xmeanAdded <- (se && !is.null(se.y) && !noxmean &&
+ if (xmeanAdded <- (se && !is.null(se.y) && !noxmean &&
all(substring(ylab, 1:nchar(ylab), 1:nchar(ylab)) != "("))) {
x = c(x, mean(x))
y = rbind(y, 0 * y[1,])
se.y = rbind(se.y, 0 * se.y[1,])
- if(!is.null(residuals))
+ if (!is.null(residuals))
residuals = rbind(residuals, NA*residuals[1,]) # NAs not plotted
}
@@ -492,20 +496,20 @@ vplot.numeric <- function(x, y, se.y=NULL, xlab, ylab,
uy <- y[o,,drop= FALSE]
xlim <- range(xlim, ux)
ylim <- range(ylim, uy[,which.cf], na.rm= TRUE)
- if(rugplot) {
- usex = if(xmeanAdded) x[-length(x)] else x
+ if (rugplot) {
+ usex = if (xmeanAdded) x[-length(x)] else x
jx <- jitter(usex[!is.na(usex)])
xlim <- range(c(xlim, jx))
}
- if(se && !is.null(se.y)) {
+ if (se && !is.null(se.y)) {
se.upper <- uy + 2 * se.y[o,,drop= FALSE]
se.lower <- uy - 2 * se.y[o,,drop= FALSE]
ylim <- range(c(ylim, se.upper[,which.cf], se.lower[,which.cf]))
}
- if(!is.null(residuals)) {
- if(length(residuals) == length(y)) {
+ if (!is.null(residuals)) {
+ if (length(residuals) == length(y)) {
residuals <- as.matrix(y + residuals)
ylim <- range(c(ylim, residuals[,which.cf]), na.rm= TRUE)
} else {
@@ -518,30 +522,30 @@ vplot.numeric <- function(x, y, se.y=NULL, xlab, ylab,
all.missingy <- all(is.na(y))
- if(all.missingy)
+ if (all.missingy)
return()
ylim <- ylim.scale(ylim, scale)
- if(overlay) {
- if(!length(which.cf)) which.cf = 1:ncol(uy) # Added 7/8/04
- if(!add.arg) {
+ if (overlay) {
+ if (!length(which.cf)) which.cf = 1:ncol(uy) # Added 7/8/04
+ if (!add.arg) {
matplot(ux, uy[,which.cf], type="n",
xlim=xlim, ylim=ylim,
xlab=xlab, ylab=ylab, ...)
}
matlines(ux, uy[,which.cf],
lwd=llwd, col=lcol, lty=llty)
- if(!is.null(residuals))
- if(ncol(y) == 1) {
+ if (!is.null(residuals))
+ if (ncol(y) == 1) {
points(x, residuals, pch=pch, col=pcol, cex=pcex)
} else {
matpoints(x, residuals[,which.cf],
pch=pch, col=pcol, cex=pcex) # add.arg=TRUE,
}
- if(rugplot)
+ if (rugplot)
rug(jx, col=rcol)
- if(se && !is.null(se.y)) {
+ if (se && !is.null(se.y)) {
matlines(ux, se.upper[,which.cf], lty= slty, lwd=slwd, col=scol)
matlines(ux, se.lower[,which.cf], lty= slty, lwd=slwd, col=scol)
}
@@ -560,24 +564,24 @@ vplot.numeric <- function(x, y, se.y=NULL, xlab, ylab,
slwd = rep(slwd, len=ncol(uy))
for(ii in 1:ncol(uy)) {
- if(!length(which.cf) ||
+ if (!length(which.cf) ||
(length(which.cf) && any(which.cf == ii))) {
- if(is.Numeric(ylim0, allow=2)) {
+ if (is.Numeric(ylim0, allow=2)) {
ylim = ylim0
} else {
ylim <- range(ylim0, uy[,ii], na.rm= TRUE)
- if(se && !is.null(se.y))
+ if (se && !is.null(se.y))
ylim <- range(ylim0, se.lower[,ii], se.upper[,ii],
na.rm=TRUE)
- if(!is.null(residuals))
+ if (!is.null(residuals))
ylim <- range(c(ylim, residuals[,ii]), na.rm= TRUE)
ylim <- ylim.scale(ylim, scale)
}
- if(ncol(uy)>1 && length(separator))
+ if (ncol(uy)>1 && length(separator))
YLAB <- paste(ylab, separator, ii, sep="")
- if(!add.arg) {
- if(one.at.a.time) {
+ if (!add.arg) {
+ if (one.at.a.time) {
readline("Hit return for the next plot ")
}
plot(ux, uy[,ii], type="n",
@@ -586,13 +590,13 @@ vplot.numeric <- function(x, y, se.y=NULL, xlab, ylab,
}
lines(ux, uy[,ii],
lwd=llwd[ii], col=lcol[ii], lty=llty[ii])
- if(!is.null(residuals))
+ if (!is.null(residuals))
points(x, residuals[,ii], pch=pch[ii],
col=pcol[ii], cex=pcex[ii])
- if(rugplot)
+ if (rugplot)
rug(jx, col=rcol[ii])
- if(se && !is.null(se.y)) {
+ if (se && !is.null(se.y)) {
lines(ux, se.upper[,ii], lty=slty[ii], lwd=slwd[ii],
col=scol[ii])
lines(ux, se.lower[,ii], lty=slty[ii], lwd=slwd[ii],
@@ -615,17 +619,17 @@ vplot.matrix <- function(x, y, se.y=NULL, xlab, ylab,
add.hookey <- function(ch, deriv.arg=0) {
- if(!is.Numeric(deriv.arg, integ=TRUE, allow=1) || deriv.arg<0)
+ if (!is.Numeric(deriv.arg, integ=TRUE, allow=1) || deriv.arg<0)
stop("bad input for the 'deriv' argument")
- if(deriv.arg == 0)
+ if (deriv.arg == 0)
return(ch)
hookey <- switch(deriv.arg, "'", "''", "'''", "''''",
"'''''", stop("too high a derivative"))
nc <- nchar(ch)
sub <- substring(ch, 1:nc, 1:nc)
- if(nc >= 2 && sub[1] == "s" && sub[2] == "(") {
+ if (nc >= 2 && sub[1] == "s" && sub[2] == "(") {
paste("s", hookey, substring(ch, 2, nc), sep="", coll="")
} else {
paste(ch, hookey, sep="", collapse="")
@@ -640,28 +644,28 @@ vplot.factor <- function(x, y, se.y=NULL, xlab, ylab,
offset.arg=0, deriv.arg=0, overlay= FALSE,
which.cf=NULL, ...)
{
- if(deriv.arg>0)
+ if (deriv.arg>0)
return(NULL)
- if(length(y)/length(x) != round(length(y)/length(x)))
+ if (length(y)/length(x) != round(length(y)/length(x)))
stop("length of 'x' and 'y' do not seem to match")
y <- as.matrix(y)
- if(!is.null(se.y))
+ if (!is.null(se.y))
se.y <- as.matrix(se.y)
- if(!is.null(se.y) && any(is.na(se.y)))
+ if (!is.null(se.y) && any(is.na(se.y)))
se.y <- NULL
- if(!is.null(residuals)) {
+ if (!is.null(residuals)) {
residuals <- as.matrix(residuals)
- if(ncol(residuals) != ncol(y)) {
+ if (ncol(residuals) != ncol(y)) {
warning("ncol(residuals) != ncol(y) so residuals are not plotted")
residuals <- NULL
}
}
- if(overlay) {
+ if (overlay) {
vvplot.factor(x, y,
- se.y=if(is.null(se.y)) NULL else se.y,
+ se.y = if (is.null(se.y)) NULL else se.y,
xlab=xlab, ylab=ylab,
residuals=residuals,
rugplot=rugplot, scale=scale,
@@ -669,12 +673,12 @@ vplot.factor <- function(x, y, se.y=NULL, xlab, ylab,
} else {
for(ii in 1:ncol(y)) {
ylab <- rep(ylab, len=ncol(y))
- if(ncol(y) > 1)
+ if (ncol(y) > 1)
ylab <- dimnames(y)[[2]]
vvplot.factor(x, y[,ii,drop= FALSE],
- se.y=if(is.null(se.y)) NULL else se.y[,ii,drop= FALSE],
+ se.y = if (is.null(se.y)) NULL else se.y[,ii,drop= FALSE],
xlab=xlab, ylab=ylab[ii],
- residuals= if(is.null(residuals))
+ residuals= if (is.null(residuals))
NULL else residuals[,ii,drop= FALSE],
rugplot=rugplot, scale=scale,
se=se, xlim=xlim, ylim=ylim, ...)
@@ -711,15 +715,15 @@ vvplot.factor <- function(x, y, se.y=NULL, xlab, ylab,
jx <- runif(length(codex), (ux - delta)[codex], (ux + delta)[codex])
nnajx <- jx[!is.na(jx)]
- if(rugplot)
+ if (rugplot)
xlim <- range(c(xlim, nnajx))
- if(se && !is.null(se.y)) {
+ if (se && !is.null(se.y)) {
se.upper <- uy + 2 * se.y[o,,drop= FALSE]
se.lower <- uy - 2 * se.y[o,,drop= FALSE]
ylim <- range(c(ylim, se.upper, se.lower))
}
- if(!is.null(residuals)) {
- if(length(residuals) == length(y)) {
+ if (!is.null(residuals)) {
+ if (length(residuals) == length(y)) {
residuals <- y + residuals
ylim <- range(c(ylim, residuals))
} else {
@@ -730,7 +734,7 @@ vvplot.factor <- function(x, y, se.y=NULL, xlab, ylab,
}
ylim <- ylim.scale(ylim, scale)
Levels <- levels(x)
- if(!all(nn)) {
+ if (!all(nn)) {
keep <- nn > 0
nn <- nn[keep]
ux <- ux[keep]
@@ -742,7 +746,7 @@ vvplot.factor <- function(x, y, se.y=NULL, xlab, ylab,
about <- function(ux, M, Delta=1/M) {
- if(M == 1) return(cbind(ux))
+ if (M == 1) return(cbind(ux))
ans <- matrix(as.numeric(NA), length(ux), M)
grid <- seq(-Delta, Delta, len=M)
for(ii in 1:M) {
@@ -764,18 +768,18 @@ vvplot.factor <- function(x, y, se.y=NULL, xlab, ylab,
for(ii in 1:M)
segments(uxx[,ii] - 1.0 * delta, uy[,ii],
uxx[,ii] + 1.0 * delta, uy[,ii])
- if(!is.null(residuals)) {
+ if (!is.null(residuals)) {
for(ii in 1:M) {
jux <- uxx[,ii]
jux <- jux[codex]
jux <- jux + runif(length(jux), -0.7*min(delta), 0.7*min(delta))
- if(M == 1) points(jux, residuals[,ii]) else
+ if (M == 1) points(jux, residuals[,ii]) else
points(jux, residuals[,ii], pch=as.character(ii))
}
}
- if(rugplot)
+ if (rugplot)
rug(nnajx)
- if(se) {
+ if (se) {
for(ii in 1:M) {
segments(uxx[,ii]+0.5*delta, se.upper[,ii],
uxx[,ii]-0.5*delta, se.upper[,ii])
@@ -803,22 +807,21 @@ setMethod("vplot", "numeric", function(x, ...)
setMethod("plot", "vlm",
function(x, y, ...) {
- if(!missing(y)) stop("cannot process the 'y' argument")
+ if (!missing(y)) stop("cannot process the 'y' argument")
invisible(plotvlm(x, y, ...))})
setMethod("plot", "vglm",
function(x, y, ...) {
- if(!missing(y)) stop("cannot process the 'y' argument")
+ if (!missing(y)) stop("cannot process the 'y' argument")
invisible(plotvglm(x, y, ...))})
setMethod("plot", "vgam",
function(x, y, ...) {
- if(!missing(y)) stop("cannot process the 'y' argument")
+ if (!missing(y)) stop("cannot process the 'y' argument")
invisible(plotvgam(x, ...))})
-
plotqrrvglm = function(object,
rtype = c("pearson", "response", "deviance", "working"),
ask = FALSE,
@@ -833,7 +836,7 @@ plotqrrvglm = function(object,
rtype <- match.arg(rtype, c("pearson", "response", "deviance", "working"))[1]
res = resid(object, type=rtype)
- my.ylab = if(length(object at misc$ynames)) object at misc$ynames else
+ my.ylab = if (length(object at misc$ynames)) object at misc$ynames else
rep(" ", len=M)
Rtype = switch(rtype, pearson="Pearson", response="Response",
deviance="Deviance", working="Working")
@@ -842,11 +845,11 @@ plotqrrvglm = function(object,
for(rr in 1:Rank)
for(ii in 1:M) {
plot(Coef.object at lv[,rr], res[,ii],
- xlab=paste(xlab, if(Rank == 1) "" else rr, sep=""),
+ xlab=paste(xlab, if (Rank == 1) "" else rr, sep=""),
ylab=my.ylab[ii],
main = main, ...)
done = done + 1
- if(done >= prod(par()$mfrow) && ask && done != Rank*M) {
+ if (done >= prod(par()$mfrow) && ask && done != Rank*M) {
done = 0
readline("Hit return for the next plot: ")
}
diff --git a/R/predict.vgam.q b/R/predict.vgam.q
index d95cf9a..4c7792b 100644
--- a/R/predict.vgam.q
+++ b/R/predict.vgam.q
@@ -1,5 +1,5 @@
# These functions are
-# Copyright (C) 1998-2009 T.W. Yee, University of Auckland. All rights reserved.
+# Copyright (C) 1998-2010 T.W. Yee, University of Auckland. All rights reserved.
@@ -11,7 +11,7 @@ predict.vgam <- function(object, newdata=NULL,
untransform = FALSE,
dispersion=NULL, ...)
{
- if(missing(newdata)) {
+ if (missing(newdata)) {
newdata <- NULL
} else {
newdata <- as.data.frame(newdata)
@@ -21,29 +21,29 @@ predict.vgam <- function(object, newdata=NULL,
na.act = object at na.action
object at na.action = list()
- if(mode(type) != "character" && mode(type) != "name")
+ if (mode(type) != "character" && mode(type) != "name")
type <- as.character(substitute(type))
type <- match.arg(type, c("link", "response", "terms"))[1]
- if(untransform && (type!="link" || se.fit || deriv.arg != 0 || offset != 0))
+ if (untransform && (type!="link" || se.fit || deriv.arg != 0 || offset != 0))
stop("argument 'untransform=TRUE' only if type='link', ",
"se.fit=FALSE, deriv=0")
- if(raw && type!="terms")
+ if (raw && type!="terms")
stop("'raw=TRUE' only works when 'type=\"terms\"'")
- if(!is.numeric(deriv.arg) || deriv.arg<0 ||
+ if (!is.numeric(deriv.arg) || deriv.arg<0 ||
deriv.arg!=round(deriv.arg) || length(deriv.arg)>1)
stop("bad input for the 'deriv' argument")
- if(deriv.arg>0 && type!="terms")
+ if (deriv.arg>0 && type!="terms")
stop("'deriv>0' can only be specified if 'type=\"terms\"'")
- if(deriv.arg != 0 && !(type!="response" && !se.fit))
+ if (deriv.arg != 0 && !(type!="response" && !se.fit))
stop("'deriv=' only works with type!='response' and se.fit=FALSE")
- if(se.fit && length(newdata))
+ if (se.fit && length(newdata))
stop("cannot specify 'se.fit=TRUE' when 'newdata' is assigned")
@@ -52,38 +52,38 @@ predict.vgam <- function(object, newdata=NULL,
ttf <- attr(tt, "factors")
tto <- attr(tt, "order")
intercept <- attr(tt, "intercept")
- if(!intercept)
+ if (!intercept)
stop("an intercept is assumed")
M <- object at misc$M
Blist <- object at constraints
ncolBlist <- unlist(lapply(Blist, ncol))
- if(intercept)
+ if (intercept)
ncolBlist <- ncolBlist[-1]
- if(raw) {
+ if (raw) {
Blist <- canonical.Blist(Blist)
object at constraints <- Blist
}
- if(!length(newdata)) {
- if(type=="link") {
- if(se.fit) {
+ if (!length(newdata)) {
+ if (type=="link") {
+ if (se.fit) {
stop("cannot handle this option (se.fit=TRUE) currently")
} else {
- if(length(na.act)) {
+ if (length(na.act)) {
answer = napredict(na.act[[1]], object at predictors)
} else {
answer = object at predictors
}
- if(untransform) return(untransformVGAM(object, answer)) else
+ if (untransform) return(untransformVGAM(object, answer)) else
return(answer)
}
} else
- if(type=="response") {
- if(se.fit) {
+ if (type=="response") {
+ if (se.fit) {
stop("cannot handle this option (se.fit=TRUE) currently")
} else {
- if(length(na.act)) {
+ if (length(na.act)) {
return(napredict(na.act[[1]], object at fitted.values))
} else {
return(object at fitted.values)
@@ -104,7 +104,7 @@ predict.vgam <- function(object, newdata=NULL,
} else {
- temp.type <- if(type=="link") "response" else type
+ temp.type <- if (type=="link") "response" else type
predictor <- predict.vlm(object, newdata,
@@ -117,8 +117,8 @@ predict.vgam <- function(object, newdata=NULL,
}
- if(deriv.arg>0)
- if(se.fit) {
+ if (deriv.arg>0)
+ if (se.fit) {
predictor$fitted.values <- predictor$fitted.values * 0
predictor$se.fit <- predictor$se.fit * NA
} else {
@@ -126,7 +126,7 @@ predict.vgam <- function(object, newdata=NULL,
}
- if(length(s.xargument <- object at s.xargument)) {
+ if (length(s.xargument <- object at s.xargument)) {
@@ -135,22 +135,22 @@ predict.vgam <- function(object, newdata=NULL,
index1 <- match(s.xargument, dnames2, nomatch=FALSE)
index2 <- match(names(s.xargument), dnames2, nomatch=FALSE)
index <- index1 | index2
- if(!length(index) || any(!index))
+ if (!length(index) || any(!index))
stop("required variables not found in newdata")
- if(is.null(tmp6 <- attr(if(se.fit) predictor$fitted.values else
+ if (is.null(tmp6 <- attr(if(se.fit) predictor$fitted.values else
predictor, "vterm.assign"))) {
Blist <- subconstraints(object at misc$orig.assign,
object at constraints)
ncolBlist <- unlist(lapply(Blist, ncol))
- if(intercept)
+ if (intercept)
ncolBlist <- ncolBlist[-1]
- cs <- if(raw) cumsum(c(1, ncolBlist)) else
+ cs <- if (raw) cumsum(c(1, ncolBlist)) else
cumsum(c(1, M + 0*ncolBlist))
tmp6 <- vector("list", length(ncolBlist))
for(i in 1:length(tmp6))
@@ -162,7 +162,7 @@ predict.vgam <- function(object, newdata=NULL,
for(i in n.s.xargument) {
fred <- s.xargument[i]
- if(!any(dimnames(newdata)[[2]] == fred))
+ if (!any(dimnames(newdata)[[2]] == fred))
fred <- i
xx <- newdata[,fred] # [,s.xargument[i]] # [,nindex[i]]
@@ -174,17 +174,17 @@ predict.vgam <- function(object, newdata=NULL,
deriv=deriv.arg)$y
- eta.mat <- if(raw) rawMat else (rawMat %*% t(Blist[[i]]))
+ eta.mat <- if (raw) rawMat else (rawMat %*% t(Blist[[i]]))
- if(type=="terms") {
+ if (type=="terms") {
ii <- tmp6[[i]]
- if(se.fit) {
+ if (se.fit) {
predictor$fitted.values[,ii] =
predictor$fitted.values[,ii] + eta.mat
TS <- predictor$sigma^2
- temp.var <- if(raw) {
+ temp.var <- if (raw) {
iii <- object at misc$varassign
iii <- iii[[i]]
object at var[,iii,drop=FALSE]
@@ -197,7 +197,7 @@ predict.vgam <- function(object, newdata=NULL,
predictor[,ii] <- predictor[,ii] + eta.mat
}
} else {
- if(se.fit) {
+ if (se.fit) {
predictor$fitted.values <- predictor$fitted.values + eta.mat
TS <- 1 # out$residual.scale^2
@@ -215,42 +215,42 @@ predict.vgam <- function(object, newdata=NULL,
}
}
- if(type=="link") {
- if(no.newdata && length(na.act)) {
+ if (type=="link") {
+ if (no.newdata && length(na.act)) {
return(napredict(na.act[[1]], predictor))
} else {
return(predictor)
}
} else
- if(type=="response") {
+ if (type=="response") {
fv <- object at family@inverse(if(se.fit) predictor$fitted.values else
predictor, object at extra)
- if(is.matrix(fv) && is.matrix(object at fitted.values))
+ if (is.matrix(fv) && is.matrix(object at fitted.values))
dimnames(fv) <- list(dimnames(fv)[[1]],
dimnames(object at fitted.values)[[2]])
- if(is.matrix(fv) && ncol(fv)==1)
+ if (is.matrix(fv) && ncol(fv)==1)
fv <- c(fv)
- if(no.newdata && length(na.act)) {
- if(se.fit) {
+ if (no.newdata && length(na.act)) {
+ if (se.fit) {
fv = napredict(na.act[[1]], fv)
} else {
fv = napredict(na.act[[1]], fv)
}
}
- if(se.fit) {
+ if (se.fit) {
return(list(fit=fv, se.fit=fv*NA))
} else {
return(fv)
}
} else {
- if(deriv.arg >= 1)
- if(se.fit) {
+ if (deriv.arg >= 1)
+ if (se.fit) {
attr(predictor$fitted.values, "constant") <- NULL
} else {
attr(predictor, "constant") <- NULL
}
- if(deriv.arg >= 1) {
+ if (deriv.arg >= 1) {
v = attr(if(se.fit) predictor$fitted.values else
predictor, "vterm.assign")
is.lin <- is.linear.term(names(v))
@@ -260,28 +260,28 @@ predict.vgam <- function(object, newdata=NULL,
ord <- ord + 1
index <- v[[i]]
lindex <- length(index)
- if(is.lin[i]) {
- if(tto[ord]>1 || (length(ttf) && ttf[i,i])) {
- if(se.fit) {
+ if (is.lin[i]) {
+ if (tto[ord]>1 || (length(ttf) && ttf[i,i])) {
+ if (se.fit) {
predictor$fitted.values[,index] =
- if(tto[ord]>1) NA else NA
+ if (tto[ord]>1) NA else NA
} else {
- predictor[,index] <- if(tto[ord]>1) NA else NA
+ predictor[,index] <- if (tto[ord]>1) NA else NA
}
} else {
ans <- coefmat[i, 1:lindex]
- if(se.fit) {
- predictor$fitted.values[,index] = if(deriv.arg==1)
+ if (se.fit) {
+ predictor$fitted.values[,index] = if (deriv.arg==1)
matrix(ans, ncol=lindex, byrow=TRUE) else 0
} else {
- predictor[,index] <- if(deriv.arg==1)
+ predictor[,index] <- if (deriv.arg==1)
matrix(ans, ncol=lindex, byrow=TRUE) else 0
}
}
} else
- if(length(s.xargument) && any(n.s.xargument == i)) {
+ if (length(s.xargument) && any(n.s.xargument == i)) {
ans <- coefmat[i, 1:lindex]
- if(se.fit) {
+ if (se.fit) {
predictor$fitted.values[,index] =
predictor$fitted.values[,index] +
(if(deriv.arg==1)
@@ -295,7 +295,7 @@ predict.vgam <- function(object, newdata=NULL,
}
} else {
cat("Derivatives of term ", i, "are unknown\n")
- if(se.fit) {
+ if (se.fit) {
predictor$fitted.values[,index] <- NA
} else {
predictor[,index] <- NA
@@ -304,8 +304,8 @@ predict.vgam <- function(object, newdata=NULL,
}
}
- if(no.newdata && length(na.act)) {
- if(se.fit) {
+ if (no.newdata && length(na.act)) {
+ if (se.fit) {
predictor$fitted.values = napredict(na.act[[1]],
predictor$fitted.values)
predictor$se.fit = napredict(na.act[[1]], predictor$se.fit)
@@ -314,7 +314,7 @@ predict.vgam <- function(object, newdata=NULL,
}
}
- if(se.fit) {
+ if (se.fit) {
attr(predictor$fitted.values, "derivative") <- deriv.arg
} else {
attr(predictor, "derivative") <- deriv.arg
@@ -333,7 +333,7 @@ predict.vgam <- function(object, newdata=NULL,
varassign <- function(constraints, n.s.xargument) {
- if(!length(n.s.xargument))
+ if (!length(n.s.xargument))
stop("length(n.s.xargument) must be > 0")
ans <- vector("list", length(n.s.xargument))
diff --git a/R/predict.vglm.q b/R/predict.vglm.q
index 4c4e144..aa0a1d7 100644
--- a/R/predict.vglm.q
+++ b/R/predict.vglm.q
@@ -1,5 +1,5 @@
# These functions are
-# Copyright (C) 1998-2009 T.W. Yee, University of Auckland. All rights reserved.
+# Copyright (C) 1998-2010 T.W. Yee, University of Auckland. All rights reserved.
@@ -16,24 +16,24 @@ predict.vglm = function(object,
na.act = object at na.action
object at na.action = list()
- if(missing(extra)) {
+ if (missing(extra)) {
}
- if(deriv != 0)
+ if (deriv != 0)
stop("'deriv' must be 0 for predict.vglm()")
- if(mode(type) != "character" && mode(type) != "name")
+ if (mode(type) != "character" && mode(type) != "name")
type = as.character(substitute(type))
type = match.arg(type, c("link", "response", "terms"))[1]
- if(untransform && (type!="link" || se.fit || deriv != 0))
+ if (untransform && (type!="link" || se.fit || deriv != 0))
stop("argument 'untransform=TRUE' only if 'type=\"link\", ",
"se.fit=FALSE, deriv=0'")
- pred = if(se.fit) {
+ pred = if (se.fit) {
switch(type,
response = {
warning("'type=\"response\"' and 'se.fit=TRUE' not valid ",
@@ -59,7 +59,7 @@ predict.vglm = function(object,
deriv=deriv, dispersion=dispersion, ...)
}) # End of switch
} else {
- if(is.null(newdata)) {
+ if (is.null(newdata)) {
switch(type,
link = object at predictors,
response = object at fitted.values,
@@ -69,7 +69,7 @@ predict.vglm = function(object,
deriv=deriv, dispersion=dispersion, ...)
})
} else {
- if(!(length(object at offset) == 1 && object at offset == 0))
+ if (!(length(object at offset) == 1 && object at offset == 0))
warning("zero offset used")
switch(type,
response={
@@ -87,7 +87,7 @@ predict.vglm = function(object,
M = object at misc$M
fv = object at family@inverse(predictor, extra)
- if(M > 1 && is.matrix(fv)) {
+ if (M > 1 && is.matrix(fv)) {
dimnames(fv) = list(dimnames(fv)[[1]],
dimnames(object at fitted.values)[[2]])
} else {
@@ -113,8 +113,8 @@ predict.vglm = function(object,
}
}
- if(!length(newdata) && length(na.act)) {
- if(se.fit) {
+ 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)
} else {
@@ -122,7 +122,7 @@ predict.vglm = function(object,
}
}
- if(untransform) untransformVGAM(object, pred) else pred
+ if (untransform) untransformVGAM(object, pred) else pred
}
@@ -142,7 +142,7 @@ predict.rrvglm = function(object,
dispersion=NULL,
extra=object at extra, ...) {
- if(se.fit) {
+ if (se.fit) {
stop("11/8/03; predict.rrvglm(..., se.fit=TRUE) not complete yet")
pred =
switch(type,
@@ -180,8 +180,8 @@ predict.rrvglm = function(object,
na.act = object at na.action
- if(!length(newdata) && length(na.act)) {
- if(se.fit) {
+ 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)
} else {
@@ -201,7 +201,7 @@ setMethod("predict", "rrvglm", function(object, ...)
untransformVGAM = function(object, pred) {
M = object at misc$M
Links = object at misc$link
- if(length(Links) != M && length(Links) != 1)
+ if (length(Links) != M && length(Links) != 1)
stop("cannot obtain the link functions to untransform the object")
upred = pred
earg = object at misc$earg
@@ -212,8 +212,8 @@ untransformVGAM = function(object, pred) {
Theta = eval(newcall) # Theta, the untransformed parameter
upred[,ii] = Theta
}
- dmn2 = if(length(names(object at misc$link))) names(object at misc$link) else {
- if(length(object at misc$parameters)) object at misc$parameters else NULL
+ dmn2 = if (length(names(object at misc$link))) names(object at misc$link) else {
+ if (length(object at misc$parameters)) object at misc$parameters else NULL
}
dimnames(upred) = list(dimnames(upred)[[1]], dmn2)
upred
diff --git a/R/predict.vlm.q b/R/predict.vlm.q
index 3a101aa..110221b 100644
--- a/R/predict.vlm.q
+++ b/R/predict.vlm.q
@@ -1,5 +1,5 @@
# These functions are
-# Copyright (C) 1998-2009 T.W. Yee, University of Auckland. All rights reserved.
+# Copyright (C) 1998-2010 T.W. Yee, University of Auckland. All rights reserved.
@@ -17,19 +17,19 @@ predict.vlm = function(object,
Xm2 = NULL
xij.used = length(form2 <- object at misc$form2) || length(object at control$xij)
- if(mode(type) != "character" && mode(type) != "name")
+ if (mode(type) != "character" && mode(type) != "name")
type = as.character(substitute(type))
type = match.arg(type, c("response","terms"))[1]
na.act = object at na.action
object at na.action = list()
- if(raw && type != "terms")
+ if (raw && type != "terms")
stop("sorry, 'raw=TRUE' only works when 'type=\"terms\"'")
- if(!length(newdata) && type == "response" && !se.fit &&
+ if (!length(newdata) && type == "response" && !se.fit &&
length(object at fitted.values)) {
- if(length(na.act)) {
+ if (length(na.act)) {
return(napredict(na.act[[1]], object at fitted.values))
} else {
return(object at fitted.values)
@@ -39,10 +39,10 @@ predict.vlm = function(object,
ttob = terms(object) # 11/8/03; object at terms$terms
- if(!length(newdata)) {
+ if (!length(newdata)) {
offset = object at offset
- if(xij.used) {
+ if (xij.used) {
bothList = model.matrix(object, type="bothlmlm2")
X = bothList$X
Xm2 = bothList$Xm2
@@ -51,40 +51,40 @@ predict.vlm = function(object,
}
} else {
- if(is.smart(object) && length(object at smart.prediction)) {
+ if (is.smart(object) && length(object at smart.prediction)) {
setup.smart("read", smart.prediction=object at smart.prediction)
}
X = model.matrix(delete.response(ttob), newdata,
- contrasts=if(length(object at contrasts)) object at contrasts
- else NULL,
+ contrasts = if (length(object at contrasts))
+ object at contrasts else NULL,
xlev = object at xlevels)
- if(xij.used) {
+ if (xij.used) {
ttXm2 = terms(form2)
Xm2 = model.matrix(delete.response(ttXm2), newdata,
- contrasts = if(length(object at contrasts))
+ contrasts = if (length(object at contrasts))
object at contrasts else NULL,
xlev = object at xlevels)
}
- if(object at misc$intercept.only && nrow(X) != nrow(newdata)) {
+ if (object at misc$intercept.only && nrow(X) != nrow(newdata)) {
as.save = attr(X, "assign")
X = X[rep(1, nrow(newdata)),,drop=FALSE] # =matrix(1,nrow(newdata),1)
dimnames(X) = list(dimnames(newdata)[[1]], "(Intercept)")
attr(X, "assign") = as.save # Restored
}
- offset = if(!is.null(off.num <- attr(ttob, "offset"))) {
+ offset = if (!is.null(off.num <- attr(ttob, "offset"))) {
eval(attr(ttob, "variables")[[off.num+1]], newdata)
- } else if(!is.null(object at offset))
+ } else if (!is.null(object at offset))
eval(object at call$offset, newdata)
- if(is.smart(object) && length(object at smart.prediction)) {
+ if (is.smart(object) && length(object at smart.prediction)) {
wrapup.smart()
}
attr(X, "assign") = attrassigndefault(X, ttob)
- if(length(Xm2))
+ if (length(Xm2))
attr(Xm2, "assign") = attrassigndefault(Xm2, ttXm2)
}
@@ -95,20 +95,20 @@ predict.vlm = function(object,
M = object at misc$M
Blist = object at constraints
ncolBlist = unlist(lapply(Blist, ncol))
- if(hasintercept)
+ if (hasintercept)
ncolBlist = ncolBlist[-1]
xbar = x2bar = NULL
- if(type == "terms" && hasintercept) {
- if(length(object at control$xij)) {
+ if (type == "terms" && hasintercept) {
+ if (length(object at control$xij)) {
x2bar = colMeans(Xm2)
Xm2 = sweep(Xm2, 2, x2bar)
}
xbar = colMeans(X)
X = sweep(X, 2, xbar)
nac = is.na(object at coefficients)
- if(any(nac)) {
- if(length(object at control$xij))
+ if (any(nac)) {
+ if (length(object at control$xij))
stop("cannot handle 'xij' argument when ",
"there are NAs in the coefficients")
X = X[, !nac, drop=FALSE]
@@ -116,11 +116,11 @@ predict.vlm = function(object,
}
}
- if(!is.null(newdata) && !is.data.frame(newdata))
+ if (!is.null(newdata) && !is.data.frame(newdata))
newdata = as.data.frame(newdata)
- nn = if(!is.null(newdata)) nrow(newdata) else object at misc$n
- if(raw) {
+ nn = if (!is.null(newdata)) nrow(newdata) else object at misc$n
+ if (raw) {
Blist = canonical.Blist(Blist)
object at constraints = Blist
}
@@ -142,28 +142,28 @@ predict.vlm = function(object,
vasgn = attr(X_vlm, "vassign")
- if(type == "terms") {
+ if (type == "terms") {
nv = names(vasgn)
- if(hasintercept)
+ if (hasintercept)
nv = nv[-(1:ncol(object at constraints[["(Intercept)"]]))]
- terms.arg = if(is.null(terms.arg)) nv else terms.arg
+ terms.arg = if (is.null(terms.arg)) nv else terms.arg
index = charmatch(terms.arg, nv)
- if(all(index == 0)) {
+ if (all(index == 0)) {
warning("no match found; returning all terms")
index = 1:length(nv)
}
vasgn = vasgn[nv[index]]
}
- if(any(is.na(object at coefficients)))
+ if (any(is.na(object at coefficients)))
stop("cannot handle NAs in 'object at coefficients'")
dname2 = object at misc$predictors.names
- if(se.fit) {
+ if (se.fit) {
object = as(object, "vlm") # Coerce
fit.summary = summaryvlm(object, dispersion=dispersion)
- sigma = if(is.numeric(fit.summary at sigma)) fit.summary at sigma else
+ sigma = if (is.numeric(fit.summary at sigma)) fit.summary at sigma else
sqrt(deviance(object) / object at df.residual) # was @rss
pred = Build.terms.vlm(x=X_vlm, coefs=coefs,
cov=sigma^2 * fit.summary at cov.unscaled,
@@ -184,8 +184,8 @@ predict.vlm = function(object,
constant = attr(pred, "constant")
- if(type != "terms" && length(offset) && any(offset != 0)) {
- if(se.fit) {
+ if (type != "terms" && length(offset) && any(offset != 0)) {
+ if (se.fit) {
pred$fitted.values = pred$fitted.values + offset
} else {
pred = pred + offset
@@ -194,17 +194,17 @@ predict.vlm = function(object,
- if(type == "terms") {
+ if (type == "terms") {
Blist = subconstraints(object at misc$orig.assign, object at constraints)
ncolBlist = unlist(lapply(Blist, ncol))
- if(hasintercept)
+ if (hasintercept)
ncolBlist = ncolBlist[-1]
cs = cumsum(c(1, ncolBlist)) # Like a pointer
for(ii in 1:(length(cs)-1))
- if(cs[ii+1]-cs[ii] > 1)
+ if (cs[ii+1]-cs[ii] > 1)
for(kk in (cs[ii]+1):(cs[ii+1]-1))
- if(se.fit) {
+ if (se.fit) {
pred$fitted.values[,cs[ii]]= pred$fitted.values[,cs[ii]] +
pred$fitted.values[,kk]
pred$se.fit[,cs[ii]] = pred$se.fit[,cs[ii]] +
@@ -213,15 +213,15 @@ predict.vlm = function(object,
pred[,cs[ii]] = pred[,cs[ii]] + pred[,kk]
}
- if(se.fit) {
+ if (se.fit) {
pred$fitted.values = pred$fitted.values[,cs[-length(cs)],drop=FALSE]
pred$se.fit = pred$se.fit[, cs[-length(cs)], drop=FALSE]
} else {
pred = pred[, cs[-length(cs)], drop=FALSE]
}
- pp = if(se.fit) ncol(pred$fitted.values) else ncol(pred)
- if(se.fit) {
+ pp = if (se.fit) ncol(pred$fitted.values) else ncol(pred)
+ if (se.fit) {
dimnames(pred$fitted.values) = dimnames(pred$se.fit) = NULL
dim(pred$fitted.values) = dim(pred$se.fit) = c(M, nn, pp)
pred$fitted.values = aperm(pred$fitted.values, c(2,1,3))
@@ -234,11 +234,11 @@ predict.vlm = function(object,
dim(pred) = c(nn, M*pp)
}
- if(raw) {
+ if (raw) {
kindex = NULL
for(ii in 1:pp)
kindex = c(kindex, (ii-1)*M + (1:ncolBlist[ii]))
- if(se.fit) {
+ if (se.fit) {
pred$fitted.values = pred$fitted.values[,kindex,drop=FALSE]
pred$se.fit = pred$se.fit[,kindex,drop=FALSE]
} else {
@@ -246,9 +246,9 @@ predict.vlm = function(object,
}
}
- temp = if(raw) ncolBlist else rep(M, length(ncolBlist))
+ temp = if (raw) ncolBlist else rep(M, length(ncolBlist))
dd = vlabel(names(ncolBlist), temp, M)
- if(se.fit) {
+ if (se.fit) {
dimnames(pred$fitted.values) =
dimnames(pred$se.fit) = list(if(length(newdata))
dimnames(newdata)[[1]] else dx1, dd)
@@ -257,8 +257,8 @@ predict.vlm = function(object,
dimnames(newdata)[[1]] else dx1, dd)
}
- if(!length(newdata) && length(na.act)) {
- if(se.fit) {
+ 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)
} else {
@@ -266,22 +266,22 @@ predict.vlm = function(object,
}
}
- if(!raw)
+ if (!raw)
cs = cumsum(c(1, M + 0*ncolBlist))
fred = vector("list", length(ncolBlist))
for(ii in 1:length(fred))
fred[[ii]] = cs[ii]:(cs[ii+1]-1)
names(fred) = names(ncolBlist)
- if(se.fit) {
+ if (se.fit) {
attr(pred$fitted.values, "vterm.assign") = fred
attr(pred$se.fit, "vterm.assign") = fred
} else {
attr(pred, "vterm.assign") = fred
}
- } # End of if(type == "terms")
+ } # End of if (type == "terms")
- if(!is.null(xbar)) {
- if(se.fit) {
+ if (!is.null(xbar)) {
+ if (se.fit) {
attr(pred$fitted.values, "constant") = constant
} else {
attr(pred, "constant") = constant
@@ -304,7 +304,7 @@ subconstraints = function(assign, constraints) {
ans = vector("list", length(assign))
- if(!length(assign) || !length(constraints))
+ if (!length(assign) || !length(constraints))
stop("assign and/or constraints is empty")
for(ii in 1:length(assign))
ans[[ii]] = constraints[[assign[[ii]][1]]]
diff --git a/R/print.vglm.q b/R/print.vglm.q
index ec1f5c1..c777ac1 100644
--- a/R/print.vglm.q
+++ b/R/print.vglm.q
@@ -1,16 +1,16 @@
# These functions are
-# Copyright (C) 1998-2009 T.W. Yee, University of Auckland. All rights reserved.
+# Copyright (C) 1998-2010 T.W. Yee, University of Auckland. All rights reserved.
print.vglm <- function(x, ...) {
- if(!is.null(cl <- x at call)) {
+ if (!is.null(cl <- x at call)) {
cat("Call:\n")
dput(cl)
}
coef <- x at coefficients
- if(any(nas <- is.na(coef))) {
- if(is.null(names(coef)))
+ if (any(nas <- is.na(coef))) {
+ if (is.null(names(coef)))
names(coef) <- paste("b", 1:length(coef), sep = "")
cat("\nCoefficients: (", sum(nas),
" not defined because of singularities)\n", sep = "")
@@ -19,25 +19,25 @@ print.vglm <- function(x, ...) {
print.default(coef, ...)
rank <- x at rank
- if(!length(rank))
+ if (!length(rank))
rank <- sum(!nas)
- nobs <- if(length(x at df.total)) x at df.total else length(x at residuals)
+ nobs <- if (length(x at df.total)) x at df.total else length(x at residuals)
rdf <- x at df.residual
- if(!length(rdf))
+ if (!length(rdf))
rdf <- nobs - rank
cat("\nDegrees of Freedom:", nobs, "Total;", rdf, "Residual\n")
- if(length(deviance(x)))
+ if (length(deviance(x)))
cat("Residual Deviance:", format(deviance(x)), "\n")
llx = logLik.vlm(object = x)
- if(length(llx))
+ if (length(llx))
cat("Log-likelihood:", format(llx), "\n")
- if(length(x at criterion)) {
+ if (length(x at criterion)) {
ncrit <- names(x at criterion)
for(i in ncrit)
- if(i!="loglikelihood" && i!="deviance")
+ if (i!="loglikelihood" && i!="deviance")
cat(paste(i, ":", sep=""), format(x at criterion[[i]]), "\n")
}
@@ -47,7 +47,7 @@ print.vglm <- function(x, ...) {
print.vgam <- function(x, digits=2, ...) {
- if(!is.null(cl <- x at call)) {
+ if (!is.null(cl <- x at call)) {
cat("Call:\n")
dput(cl)
}
@@ -56,25 +56,25 @@ print.vgam <- function(x, digits=2, ...) {
nas <- is.na(coef)
rank <- x at rank
- if(is.null(rank))
+ if (is.null(rank))
rank <- sum(!nas)
- nobs <- if(length(x at df.total)) x at df.total else length(x at residuals)
+ nobs <- if (length(x at df.total)) x at df.total else length(x at residuals)
rdf <- x at df.residual
- if(is.null(rdf))
+ if (is.null(rdf))
rdf <- nobs - rank
cat("\nDegrees of Freedom:", nobs, "Total;",
format(round(rdf, dig=digits)), "Residual\n")
- if(length(deviance(x)))
+ if (length(deviance(x)))
cat("Residual Deviance:", format(deviance(x)), "\n")
llx = logLik.vlm(object = x)
- if(length(llx))
+ if (length(llx))
cat("Log-likelihood:", format(llx), "\n")
criterion <- attr(terms(x), "criterion") # 11/8/03; x at terms$terms,
- if(!is.null(criterion) && criterion!="coefficients")
+ if (!is.null(criterion) && criterion!="coefficients")
cat(paste(criterion, ":", sep=""), format(x[[criterion]]), "\n")
invisible(x)
diff --git a/R/print.vlm.q b/R/print.vlm.q
index 2d0ffe1..40b5b75 100644
--- a/R/print.vlm.q
+++ b/R/print.vlm.q
@@ -1,9 +1,9 @@
# These functions are
-# Copyright (C) 1998-2009 T.W. Yee, University of Auckland. All rights reserved.
+# Copyright (C) 1998-2010 T.W. Yee, University of Auckland. All rights reserved.
-if(!is.R()) {
+if (!is.R()) {
setMethod("show", "vlm",
function(object)
print.vlm(object))
@@ -14,7 +14,7 @@ setMethod("print", "vlm",
print.vlm(x, ...))
print.vlm <- function(x, ...) {
- if(!is.null(cl <- x at call)) {
+ if (!is.null(cl <- x at call)) {
cat("Call:\n")
dput(cl)
}
@@ -24,19 +24,19 @@ print.vlm <- function(x, ...) {
print(coef, ...)
rank <- x at rank
- if(is.null(rank))
+ if (is.null(rank))
rank <- sum(!is.na(coef))
n <- x at misc$n
M <- x at misc$M
- nobs <- if(length(x at df.total)) x at df.total else n*M
+ nobs <- if (length(x at df.total)) x at df.total else n*M
rdf <- x at df.residual
- if(is.null(rdf))
+ if (is.null(rdf))
rdf <- (n - rank) * M
cat("\nDegrees of Freedom:", nobs, "Total;", rdf, "Residual\n")
- if(length(deviance(x)) && is.finite(deviance(x)))
+ if (length(deviance(x)) && is.finite(deviance(x)))
cat("Deviance:", format(deviance(x)), "\n")
- if(length(x at rss) && is.finite(x at rss))
+ if (length(x at rss) && is.finite(x at rss))
cat("Residual Sum of Squares:", format(x at rss), "\n")
invisible(x)
diff --git a/R/qrrvglm.control.q b/R/qrrvglm.control.q
index b5c8746..4648fcb 100644
--- a/R/qrrvglm.control.q
+++ b/R/qrrvglm.control.q
@@ -1,9 +1,9 @@
# These functions are
-# Copyright (C) 1998-2009 T.W. Yee, University of Auckland. All rights reserved.
+# Copyright (C) 1998-2010 T.W. Yee, University of Auckland. All rights reserved.
qrrvglm.control = function(Rank=1,
- Bestof = if(length(Cinit)) 1 else 10,
+ Bestof = if (length(Cinit)) 1 else 10,
checkwz=TRUE,
Cinit = NULL,
Crow1positive=TRUE,
@@ -23,7 +23,7 @@ qrrvglm.control = function(Rank=1,
MUXfactor = rep(7, length=Rank),
Norrr = ~ 1,
optim.maxit = 20,
- Parscale = if(ITolerances) 0.001 else 1.0,
+ Parscale = if (ITolerances) 0.001 else 1.0,
SD.Cinit = 0.02,
SmallNo = 5.0e-13,
trace = TRUE,
@@ -34,53 +34,53 @@ qrrvglm.control = function(Rank=1,
- if(!is.Numeric(iShape, posit=TRUE)) stop("bad input for 'iShape'")
- if(!is.Numeric(iKvector, posit=TRUE)) stop("bad input for 'iKvector'")
- if(!is.Numeric(isdlv, posit=TRUE)) stop("bad input for 'isdlv'")
- if(any(isdlv < 0.2 | isdlv > 10))
+ if (!is.Numeric(iShape, posit=TRUE)) stop("bad input for 'iShape'")
+ if (!is.Numeric(iKvector, posit=TRUE)) stop("bad input for 'iKvector'")
+ if (!is.Numeric(isdlv, posit=TRUE)) stop("bad input for 'isdlv'")
+ if (any(isdlv < 0.2 | isdlv > 10))
stop("isdlv values must lie between 0.2 and 10")
- if(length(isdlv) > 1 && any(diff(isdlv) > 0))
+ if (length(isdlv) > 1 && any(diff(isdlv) > 0))
stop("successive isdlv values must not increase")
- if(!is.Numeric(epsilon, posit=TRUE, allow=1))
+ if (!is.Numeric(epsilon, posit=TRUE, allow=1))
stop("bad input for 'epsilon'")
- if(!is.Numeric(Etamat.colmax, posit=TRUE, allow=1) || Etamat.colmax < Rank)
+ if (!is.Numeric(Etamat.colmax, posit=TRUE, allow=1) || Etamat.colmax < Rank)
stop("bad input for 'Etamat.colmax'")
- if(!is.Numeric(Hstep, posit=TRUE, allow=1))
+ if (!is.Numeric(Hstep, posit=TRUE, allow=1))
stop("bad input for 'Hstep'")
- if(!is.Numeric(maxitl, posit=TRUE, allow=1, integer=TRUE))
+ if (!is.Numeric(maxitl, posit=TRUE, allow=1, integer=TRUE))
stop("bad input for 'maxitl'")
- if(!is.Numeric(method.init, posit=TRUE, allow=1, integer=TRUE))
+ if (!is.Numeric(method.init, posit=TRUE, allow=1, integer=TRUE))
stop("bad input for 'method.init'")
- if(!is.Numeric(Maxit.optim, integ=TRUE, posit=TRUE))
+ if (!is.Numeric(Maxit.optim, integ=TRUE, posit=TRUE))
stop("Bad input for 'Maxit.optim'")
- if(!is.Numeric(MUXfactor, posit=TRUE))
+ if (!is.Numeric(MUXfactor, posit=TRUE))
stop("bad input for 'MUXfactor'")
- if(any(MUXfactor < 1 | MUXfactor > 10))
+ if (any(MUXfactor < 1 | MUXfactor > 10))
stop("MUXfactor values must lie between 1 and 10")
- if(!is.Numeric(optim.maxit, allow=1, integ=TRUE, posit=TRUE))
+ if (!is.Numeric(optim.maxit, allow=1, integ=TRUE, posit=TRUE))
stop("Bad input for 'optim.maxit'")
- if(!is.Numeric(Rank, posit=TRUE, allow=1, integer=TRUE))
+ if (!is.Numeric(Rank, posit=TRUE, allow=1, integer=TRUE))
stop("bad input for 'Rank'")
- if(!is.Numeric(SD.Cinit, posit=TRUE, allow=1))
+ if (!is.Numeric(SD.Cinit, posit=TRUE, allow=1))
stop("bad input for 'SD.Cinit'")
- if(ITolerances && !EqualTolerances)
+ if (ITolerances && !EqualTolerances)
stop("EqualTolerances must be TRUE if ITolerances is TRUE")
- if(!is.Numeric(Bestof, posit=TRUE, allow=1, integer=TRUE))
+ if (!is.Numeric(Bestof, posit=TRUE, allow=1, integer=TRUE))
stop("bad input for 'Bestof'")
FastAlgorithm = as.logical(FastAlgorithm)[1]
- if(!FastAlgorithm)
+ if (!FastAlgorithm)
stop("FastAlgorithm=TRUE is now required")
- if((SmallNo < .Machine$double.eps) ||
+ if ((SmallNo < .Machine$double.eps) ||
(SmallNo > .0001)) stop("SmallNo is out of range")
- if(any(Parscale <= 0))
+ if (any(Parscale <= 0))
stop("Parscale must contain positive numbers only")
- if(!is.logical(checkwz) || length(checkwz) != 1)
+ if (!is.logical(checkwz) || length(checkwz) != 1)
stop("bad input for 'checkwz'")
- if(!is.Numeric(wzepsilon, allow=1, positive=TRUE))
+ if (!is.Numeric(wzepsilon, allow=1, positive=TRUE))
stop("bad input for 'wzepsilon'")
ans = list(
@@ -116,7 +116,7 @@ qrrvglm.control = function(Rank=1,
SD.Cinit = SD.Cinit,
SmallNo = SmallNo,
Structural.zero = NULL,
- Svd.arg = TRUE, Alpha=0.5, Uncor = TRUE,
+ Svd.arg = TRUE, Alpha=0.5, Uncorrelated.lv = TRUE,
trace = trace,
Use.Init.Poisson.QO=as.logical(Use.Init.Poisson.QO)[1],
wzepsilon = wzepsilon)
diff --git a/R/qtplot.q b/R/qtplot.q
index 894e126..dd58a3b 100644
--- a/R/qtplot.q
+++ b/R/qtplot.q
@@ -1,5 +1,5 @@
# These functions are
-# Copyright (C) 1998-2009 T.W. Yee, University of Auckland. All rights reserved.
+# Copyright (C) 1998-2010 T.W. Yee, University of Auckland. All rights reserved.
@@ -79,7 +79,7 @@ qtplot.default <- function(object, ...) {
"(object, ...)", sep="")
newcall = parse(text=newcall)[[1]]
- if(Attach) {
+ if (Attach) {
object at post$qtplot = eval(newcall)
invisible(object)
} else
@@ -96,16 +96,16 @@ qtplot.lmscreg <- function(object,
all(percentiles==object at misc$percentiles)
lp <- length(percentiles)
- if(same) {
- fitted.values <- if(!length(newdata)) object at fitted.values else {
+ if (same) {
+ fitted.values <- if (!length(newdata)) object at fitted.values else {
predict(object, newdata=newdata, type="response")
}
fitted.values <- as.matrix(fitted.values)
} else {
- if(!is.numeric(percentiles))
+ if (!is.numeric(percentiles))
stop("'percentiles' must be specified")
- eta <- if(length(newdata)) predict(object, newdata=newdata, type="link") else
+ eta <- if (length(newdata)) predict(object, newdata=newdata, type="link") else
object at predictors
eta <- eta2theta(eta, object at misc$link) # Now lambda, mu, sigma
@@ -117,7 +117,7 @@ qtplot.lmscreg <- function(object,
paste(as.character(percentiles), "%", sep=""))
}
- if(plot.it) {
+ if (plot.it) {
plotqtplot.lmscreg(fit=fitted.values, obj=object,
newdata=newdata,
lp=lp,
@@ -134,7 +134,8 @@ plotqtplot.lmscreg <- function(fitted.values, object,
percentiles=object at misc$percentiles,
lp=NULL,
add.arg=FALSE,
- y=if(length(newdata)) FALSE else TRUE, spline.fit=FALSE,
+ y = if (length(newdata)) FALSE else TRUE,
+ spline.fit=FALSE,
label=TRUE,
size.label=0.06,
xlab=NULL, ylab="",
@@ -148,32 +149,32 @@ plotqtplot.lmscreg <- function(fitted.values, object,
- if(!length(newdata)) {
+ if (!length(newdata)) {
X <- model.matrixvlm(object, type="lm")
- if(is.matrix(X) && length(object at y) && ncol(X)==2 &&
+ if (is.matrix(X) && length(object at y) && ncol(X)==2 &&
dimnames(X)[[2]][1]=="(Intercept)")
{
xx <- X[,2]
- if(is.null(xlab)) {
- xlab <- if(object at misc$nonparametric)
+ if (is.null(xlab)) {
+ xlab <- if (object at misc$nonparametric)
as.vector(slot(object, "s.xargument")) else
names(object at assign)[2]
}
- if(!add.arg) {
- if(!is.numeric(xlim))
- xlim <- if(label)
+ if (!add.arg) {
+ if (!is.numeric(xlim))
+ xlim <- if (label)
c(min(xx), max(xx)+size.label*diff(range(xx))) else
c(min(xx), max(xx))
fred <- cbind(object at y, fitted.values)
- if(!is.numeric(ylim))
+ if (!is.numeric(ylim))
ylim <- c(min(fred), max(fred))
matplot(x=xx, y=fred,
xlab=xlab, ylab=ylab, type="n",
xlim=xlim, ylim=ylim, ...)
}
- if(y && length(object at y))
+ if (y && length(object at y))
matpoints(x=xx, y=object at y, pch=pch, cex=pcex,
col=pcol.arg)
} else {
@@ -185,28 +186,28 @@ plotqtplot.lmscreg <- function(fitted.values, object,
firstterm = attr(terms(object), "term.labels")[1]
- if(object at misc$nonparametric &&
+ if (object at misc$nonparametric &&
length(object at s.xargument[firstterm]))
firstterm <- object at s.xargument[firstterm]
xx <- newdata[[firstterm]]
- if(!is.numeric(xx))
+ if (!is.numeric(xx))
stop("couldn't extract the 'primary' variable from newdata")
- if(!add.arg) {
- if(is.null(xlab))
+ if (!add.arg) {
+ if (is.null(xlab))
xlab <- firstterm
- if(!is.numeric(xlim))
- xlim <- if(label)
+ if (!is.numeric(xlim))
+ xlim <- if (label)
c(min(xx), max(xx)+size.label*diff(range(xx))) else
c(min(xx), max(xx))
- if(!is.numeric(ylim))
+ if (!is.numeric(ylim))
ylim <- c(min(fitted.values), max(fitted.values))
matplot(x=xx, y=fitted.values,
xlab=xlab, ylab=ylab, type="n",
xlim=xlim, ylim=ylim, col=pcol.arg)
}
- if(y && length(object at y))
+ if (y && length(object at y))
matpoints(x=xx, y=object at y, pch=pch, cex=pcex,
col=pcol.arg)
@@ -220,14 +221,14 @@ plotqtplot.lmscreg <- function(fitted.values, object,
temp <- cbind(xx, fitted.values[,i])
temp <- temp[sort.list(temp[,1]),]
index <- !duplicated(temp[,1])
- if(spline.fit) {
+ if (spline.fit) {
lines(spline(temp[index,1], temp[index,2]),
lty=llty.arg[i], col=lcol.arg[i], err=-1, lwd=llwd.arg[i])
} else {
lines(temp[index,1], temp[index,2],
lty=llty.arg[i], col=lcol.arg[i], err=-1, lwd=llwd.arg[i])
}
- if(label)
+ if (label)
text(par()$usr[2], temp[nrow(temp),2],
paste( percentiles[i], "%", sep=""),
adj=tadj, col=tcol.arg[i], err=-1)
@@ -237,8 +238,8 @@ plotqtplot.lmscreg <- function(fitted.values, object,
}
-if(TRUE) {
- if(!isGeneric("qtplot"))
+if (TRUE) {
+ if (!isGeneric("qtplot"))
setGeneric("qtplot", function(object, ...) standardGeneric("qtplot"))
@@ -274,9 +275,9 @@ qtplot.gumbel <-
llty.arg=par()$lty, lcol.arg=par()$col, llwd.arg=par()$lwd,
tcol.arg=par()$col, tadj=1, ...)
{
- if(!is.logical(mpv) || length(mpv) != 1)
+ if (!is.logical(mpv) || length(mpv) != 1)
stop("bad input for 'mpv'")
- if(!length(percentiles) ||
+ if (!length(percentiles) ||
(!is.Numeric(percentiles, posit=TRUE) || max(percentiles) >= 100))
stop("bad input for 'percentiles'")
@@ -285,10 +286,10 @@ qtplot.gumbel <-
eta <- predict(object)
- if(is.Numeric(R))
+ if (is.Numeric(R))
R <- rep(R, length=nrow(eta))
- if(!is.Numeric(percentiles))
+ if (!is.Numeric(percentiles))
stop("the 'percentiles' argument needs to be assigned a value")
@@ -301,7 +302,7 @@ qtplot.gumbel <-
answer = list(fitted.values = fitted.values,
percentiles = percentiles)
- if(!plot.it)
+ if (!plot.it)
return(answer)
@@ -313,20 +314,20 @@ qtplot.gumbel <-
llty.arg = rep(llty.arg, length=lp+mpv)
X <- model.matrixvlm(object, type="lm")
- if(is.matrix(X) && length(object at y) && ncol(X)==2 &&
+ if (is.matrix(X) && length(object at y) && ncol(X)==2 &&
dimnames(X)[[2]][1]=="(Intercept)")
{
xx <- X[,2]
- if(!length(xlab))
- xlab <- if(object at misc$nonparametric &&
+ if (!length(xlab))
+ xlab <- if (object at misc$nonparametric &&
length(object at s.xargument))
object at s.xargument else names(object at assign)[2]
- if(!add.arg)
+ if (!add.arg)
matplot(x=xx, y=cbind(object at y, fitted.values), main=main,
xlab=xlab, ylab=ylab, type="n", ...)
- if(y.arg) {
+ if (y.arg) {
matpoints(x=xx, y=object at y, pch=pch, col=pcol.arg)
}
} else {
@@ -339,14 +340,14 @@ qtplot.gumbel <-
temp <- cbind(xx, fitted.values[,i])
temp <- temp[sort.list(temp[,1]),]
index <- !duplicated(temp[,1])
- if(spline.fit) {
+ if (spline.fit) {
lines(spline(temp[index,1], temp[index,2]),
lty=llty.arg[i], col=lcol.arg[i], lwd=llwd.arg[i])
} else {
lines(temp[index,1], temp[index,2],
lty=llty.arg[i], col=lcol.arg[i], lwd=llwd.arg[i])
}
- if(label) {
+ if (label) {
mylabel = (dimnames(answer$fitted)[[2]])[i]
text(par()$usr[2], temp[nrow(temp),2],
mylabel, adj=tadj, col=tcol.arg[i], err=-1)
@@ -365,7 +366,7 @@ deplot.lms.bcn <- function(object,
y.arg,
eta0)
{
- if(!any(object at family@vfamily == "lms.bcn"))
+ if (!any(object at family@vfamily == "lms.bcn"))
warning("I think you've called the wrong function")
Zvec <- ((y.arg/eta0[,2])^(eta0[,1]) -1) / (eta0[,1] * eta0[,3])
@@ -382,7 +383,7 @@ deplot.lms.bcg <- function(object,
y.arg,
eta0)
{
- if(!any(object at family@vfamily == "lms.bcg"))
+ if (!any(object at family@vfamily == "lms.bcg"))
warning("I think you've called the wrong function")
Zvec <- (y.arg/eta0[,2])^(eta0[,1]) # different from lms.bcn
@@ -403,7 +404,7 @@ deplot.lms.yjn <- function(object,
eta0)
{
- if(!length(intersect(object at family@vfamily, c("lms.yjn","lms.yjn2"))))
+ if (!length(intersect(object at family@vfamily, c("lms.yjn","lms.yjn2"))))
warning("I think you've called the wrong function")
lambda <- eta0[,1]
@@ -432,7 +433,7 @@ deplot.default <- function(object, ...) {
"(object, ...)", sep="")
newcall = parse(text=newcall)[[1]]
- if(Attach) {
+ if (Attach) {
object at post$deplot = eval(newcall)
invisible(object)
} else
@@ -447,19 +448,19 @@ deplot.default <- function(object, ...) {
y.arg, plot.it= TRUE, ...) {
- if(!length(newdata)) {
+ if (!length(newdata)) {
newdata <- data.frame(x0=x0)
var1name <- attr(terms(object), "term.labels")[1]
names(newdata) <- var1name
- ii <- if(object at misc$nonparametric)
+ ii <- if (object at misc$nonparametric)
slot(object, "s.xargument") else NULL
- if(length(ii) && any(logic.vec <-
+ if (length(ii) && any(logic.vec <-
names(slot(object, "s.xargument"))==var1name))
names(newdata) <- ii[logic.vec] # should be the first one
}
- eta0 = if(length(newdata)) predict(object, newdata) else predict(object)
+ eta0 = if (length(newdata)) predict(object, newdata) else predict(object)
eta0 <- eta2theta(eta0, object at misc$link) # lambda, mu, sigma
newcall = paste("deplot.", object at family@vfamily[1],
@@ -467,7 +468,7 @@ deplot.default <- function(object, ...) {
newcall = parse(text=newcall)[[1]]
answer = eval(newcall)
- if(plot.it)
+ if (plot.it)
plotdeplot.lmscreg(answer, y.arg=y.arg, ...)
invisible(answer)
@@ -487,10 +488,10 @@ plotdeplot.lmscreg <- function(answer,
yvec <- answer$density
xx <- y.arg
- if(!add.arg) {
- if(!is.numeric(xlim))
+ if (!add.arg) {
+ if (!is.numeric(xlim))
xlim <- c(min(xx), max(xx))
- if(!is.numeric(ylim))
+ if (!is.numeric(ylim))
ylim <- c(min(yvec), max(yvec))
matplot(x=xx, y=yvec,
xlab=xlab, ylab=ylab, type="n",
@@ -509,9 +510,9 @@ plotdeplot.lmscreg <- function(answer,
-if(TRUE) {
+if (TRUE) {
- if(!isGeneric("deplot"))
+ if (!isGeneric("deplot"))
setGeneric("deplot", function(object, ...) standardGeneric("deplot"))
setMethod("deplot", signature(object="vglm"),
@@ -525,9 +526,9 @@ if(TRUE) {
-if(TRUE) {
+if (TRUE) {
- if(!isGeneric("cdf"))
+ if (!isGeneric("cdf"))
setGeneric("cdf", function(object, ...) standardGeneric("cdf"))
setMethod("cdf", signature(object="vglm"),
@@ -546,7 +547,7 @@ if(TRUE) {
"(object, newdata, ...)", sep="")
newcall = parse(text=newcall)[[1]]
- if(Attach) {
+ if (Attach) {
object at post$cdf = eval(newcall)
object
} else
@@ -560,10 +561,10 @@ if(TRUE) {
- if(!length(newdata))
+ if (!length(newdata))
return(object at post$cdf)
- eta0 = if(length(newdata)) predict(object, newdata) else predict(object)
+ eta0 = if (length(newdata)) predict(object, newdata) else predict(object)
eta0 <- eta2theta(eta0, link=object at misc$link) # lambda, mu, sigma
y = vgety(object, newdata) # Includes yoffset
@@ -610,13 +611,13 @@ cdf.lms.yjn <- function(y, eta0)
vgety = function(object, newdata=NULL) {
- y = if(length(newdata)) {
+ y = if (length(newdata)) {
yname = dimnames(attr(terms(object at terms),"factors"))[[1]][1]
newdata[[yname]]
} else {
object at y
}
- if(length(object at misc$yoffset))
+ if (length(object at misc$yoffset))
y = y + object at misc$yoffset
y
}
@@ -633,7 +634,7 @@ vgety = function(object, newdata=NULL) {
"(object, ...)", sep="")
newcall = parse(text=newcall)[[1]]
- if(Attach) {
+ if (Attach) {
object at post$rlplot = eval(newcall)
invisible(object)
} else
@@ -669,16 +670,16 @@ rlplot.gev <-
epsilon = 1.0e-05,
...)
{
- if(!is.Numeric(epsilon, allow=1) || abs(epsilon) > 0.10)
+ if (!is.Numeric(epsilon, allow=1) || abs(epsilon) > 0.10)
stop("bad input for 'epsilon'")
- if(!is.Numeric(probability, posit=TRUE) || max(probability) >= 1 ||
+ if (!is.Numeric(probability, posit=TRUE) || max(probability) >= 1 ||
length(probability) < 5)
stop("bad input for 'probability'")
- if(!is.logical(Log) || length(Log) != 1)
+ if (!is.logical(Log) || length(Log) != 1)
stop("bad input for argument 'Log'")
- if(!is.logical(CI) || length(CI) != 1)
+ if (!is.logical(CI) || length(CI) != 1)
stop("bad input for argument 'CI'")
- if(!object at misc$intercept.only)
+ if (!object at misc$intercept.only)
stop("object must be an intercept-only fit, i.e., y ~ 1 is the response")
extra2 = object at extra
@@ -687,26 +688,26 @@ rlplot.gev <-
yp = -log(probability)
ydata = sort(object at y[,1])
n = object at misc$n
- if(Log) {
- if(!add.arg)
+ if (Log) {
+ if (!add.arg)
plot(log(1/yp), zp, log="", type="n",
- ylim=if(length(ylim)) ylim else
+ ylim = if (length(ylim)) ylim else
c(min(c(ydata, zp)), max(c(ydata, zp))),
xlab=xlab, ylab=ylab, main=main, ...)
points(log(-1/log((1:n)/(n+1))), ydata, col=pcol.arg, pch=pch, cex=pcex)
lines(log(1/yp), zp,
lwd=llwd.arg, col=lcol.arg, lty=llty.arg)
} else {
- if(!add.arg)
+ if (!add.arg)
plot(1/yp, zp, log="x", type="n",
- ylim=if(length(ylim)) ylim else
+ ylim = if (length(ylim)) ylim else
c(min(c(ydata, zp)), max(c(ydata, zp))),
xlab=xlab, ylab=ylab, main=main, ...)
points(-1/log((1:n)/(n+1)), ydata, col=pcol.arg, pch=pch, cex=pcex)
lines(1/yp, zp, lwd=llwd.arg, col=lcol.arg, lty=llty.arg)
}
- if(CI) {
+ if (CI) {
zpp = cbind(zp, zp, zp) # lp x 3
eta = predict(object)
Links = object at misc$link
@@ -733,7 +734,7 @@ rlplot.gev <-
v = numeric(nrow(zpp))
for(ii in 1:nrow(zpp))
v[ii] = t(as.matrix(zpp[ii,])) %*% VCOV %*% as.matrix(zpp[ii,])
- if(Log) {
+ if (Log) {
lines(log(1/yp), zp - 1.96 * sqrt(v),
lwd=slwd.arg, col=scol.arg, lty=slty.arg)
lines(log(1/yp), zp + 1.96 * sqrt(v),
@@ -747,14 +748,14 @@ rlplot.gev <-
}
answer = list(yp = yp,
zp = zp)
- if(CI) {
+ if (CI) {
answer$lower = zp - 1.96 * sqrt(v)
answer$upper = zp + 1.96 * sqrt(v)
}
invisible(answer)
}
-if(!isGeneric("rlplot"))
+if (!isGeneric("rlplot"))
setGeneric("rlplot", function(object, ...) standardGeneric("rlplot"))
setMethod("rlplot", "vglm", function(object, ...)
diff --git a/R/residuals.vlm.q b/R/residuals.vlm.q
index e525318..658a2bf 100644
--- a/R/residuals.vlm.q
+++ b/R/residuals.vlm.q
@@ -1,5 +1,5 @@
# These functions are
-# Copyright (C) 1998-2009 T.W. Yee, University of Auckland. All rights reserved.
+# Copyright (C) 1998-2010 T.W. Yee, University of Auckland. All rights reserved.
@@ -8,7 +8,7 @@
residualsvlm <- function(object,
type = c("response", "deviance", "pearson", "working"))
{
- if(mode(type) != "character" && mode(type) != "name")
+ if (mode(type) != "character" && mode(type) != "name")
type <- as.character(substitute(type))
type <- match.arg(type, c("response", "deviance", "pearson", "working"))[1]
@@ -16,22 +16,22 @@ residualsvlm <- function(object,
object at na.action = list()
pooled.weight <- object at misc$pooled.weight
- if(is.null(pooled.weight))
+ if (is.null(pooled.weight))
pooled.weight <- FALSE
answer =
switch(type,
- working = if(pooled.weight) NULL else object at residuals,
+ working = if (pooled.weight) NULL else object at residuals,
pearson = {
- if(pooled.weight) return(NULL)
+ if (pooled.weight) return(NULL)
n <- object at misc$n
M <- object at misc$M
wz <- weights(object, type="w") # $weights
- if(!length(wz))
- wz <- if(M==1) rep(1, n) else matrix(1, n, M)
+ if (!length(wz))
+ wz <- if (M==1) rep(1, n) else matrix(1, n, M)
- if(M==1) {
- if(any(wz < 0))
+ if (M==1) {
+ if (any(wz < 0))
warning(paste("some weights are negative.",
"Their residual will be assigned NA"))
ans <- sqrt(c(wz)) * c(object at residuals)
@@ -48,7 +48,7 @@ residualsvlm <- function(object,
},
deviance = {
M <- object at misc$M
- if(M > 1)
+ if (M > 1)
return(NULL)
ans <- residualsvlm(object, type = "pearson")
ans
@@ -56,7 +56,7 @@ residualsvlm <- function(object,
response = object at residuals
)
- if(length(answer) && length(na.act)) {
+ if (length(answer) && length(na.act)) {
napredict(na.act[[1]], answer)
} else {
answer
@@ -70,7 +70,7 @@ residualsvglm <- function(object,
matrix.arg=TRUE)
{
- if(mode(type) != "character" && mode(type) != "name")
+ if (mode(type) != "character" && mode(type) != "name")
type <- as.character(substitute(type))
type <- match.arg(type,
c("working", "pearson", "response", "deviance", "ldot"))[1]
@@ -79,21 +79,21 @@ residualsvglm <- function(object,
object at na.action = list()
pooled.weight <- object at misc$pooled.weight
- if(is.null(pooled.weight))
+ if (is.null(pooled.weight))
pooled.weight <- FALSE
answer =
switch(type,
- working = if(pooled.weight) NULL else object at residuals,
+ working = if (pooled.weight) NULL else object at residuals,
pearson = {
- if(pooled.weight) return(NULL)
+ if (pooled.weight) return(NULL)
n <- object at misc$n
M <- object at misc$M
wz <- weights(object, type="w") # $weights
- if(M==1) {
- if(any(wz < 0))
+ if (M==1) {
+ if (any(wz < 0))
warning(paste("some weights are negative.",
"Their residual will be assigned NA"))
ans <- sqrt(c(wz)) * c(object at residuals)
@@ -116,19 +116,19 @@ residualsvglm <- function(object,
w <- object at prior.weights
- if(!length(w))
+ if (!length(w))
w <- rep(1, n)
eta <- object at predictors
dev.fn <- object at family@deviance # May not 'exist' for that model
- if(( is.R() && length(body(dev.fn)) > 0) ||
+ if (( is.R() && length(body(dev.fn)) > 0) ||
(!is.R() && length(args(dev.fn)) > 1)) {
extra <- object at extra
ans <- dev.fn(mu=mu,y=y,w=w,residuals=TRUE,eta=eta,extra)
- if(length(ans)) {
+ if (length(ans)) {
lob <- labels(object at residuals)
- if(is.list(lob)) {
- if(is.matrix(ans)) dimnames(ans) <- lob else
+ if (is.list(lob)) {
+ if (is.matrix(ans)) dimnames(ans) <- lob else
names(ans) <- lob[[1]]
} else
names(ans) <- lob
@@ -141,13 +141,13 @@ residualsvglm <- function(object,
y <- as.matrix(object at y)
mu <- object at fitted
w <- object at prior.weights
- if(is.null(w))
+ if (is.null(w))
w <- rep(1, n)
eta <- object at predictors
- if(!is.null(ll.fn <- object at family@loglikelihood)) {
+ if (!is.null(ll.fn <- object at family@loglikelihood)) {
extra <- object at extra
ans <- ll.fn(mu=mu,y=y,w=w,residuals=TRUE,eta=eta,extra)
- if(!is.null(ans)) {
+ if (!is.null(ans)) {
ans <- c(ans) # ldot residuals can only be a vector
names(ans) <- labels(object at residuals)
}
@@ -160,14 +160,14 @@ residualsvglm <- function(object,
mu <- fitted(object)
true.mu <- object at misc$true.mu
- if(is.null(true.mu))
+ if (is.null(true.mu))
true.mu <- TRUE
- ans <- if(true.mu) y - mu else NULL
+ ans <- if (true.mu) y - mu else NULL
- if(!matrix.arg && length(ans)) {
- if(ncol(ans) == 1) {
+ if (!matrix.arg && length(ans)) {
+ if (ncol(ans) == 1) {
names.ans = dimnames(ans)[[1]]
ans = c(ans)
names(ans) = names.ans
@@ -179,7 +179,7 @@ residualsvglm <- function(object,
} else ans
})
- if(length(answer) && length(na.act)) {
+ if (length(answer) && length(na.act)) {
napredict(na.act[[1]], answer)
} else {
answer
@@ -196,7 +196,7 @@ residualsqrrvglm <- function(object,
{
- if(mode(type) != "character" && mode(type) != "name")
+ if (mode(type) != "character" && mode(type) != "name")
type <- as.character(substitute(type))
type <- match.arg(type,
c("response"))[1]
@@ -205,12 +205,12 @@ residualsqrrvglm <- function(object,
object at na.action = list()
pooled.weight <- object at misc$pooled.weight
- if(is.null(pooled.weight))
+ if (is.null(pooled.weight))
pooled.weight <- FALSE
answer =
switch(type,
- working = if(pooled.weight) NULL else object at residuals,
+ working = if (pooled.weight) NULL else object at residuals,
pearson = {
stop("have not programmed pearson resids yet")
},
@@ -225,14 +225,14 @@ residualsqrrvglm <- function(object,
mu <- fitted(object)
true.mu <- object at misc$true.mu
- if(is.null(true.mu))
+ if (is.null(true.mu))
true.mu <- TRUE
- ans <- if(true.mu) y - mu else NULL
+ ans <- if (true.mu) y - mu else NULL
- if(!matrix.arg && length(ans)) {
- if(ncol(ans) == 1) {
+ if (!matrix.arg && length(ans)) {
+ if (ncol(ans) == 1) {
names.ans = dimnames(ans)[[1]]
ans = c(ans)
names(ans) = names.ans
@@ -244,7 +244,7 @@ residualsqrrvglm <- function(object,
} else ans
})
- if(length(answer) && length(na.act)) {
+ if (length(answer) && length(na.act)) {
napredict(na.act[[1]], answer)
} else {
answer
diff --git a/R/rrvglm.R b/R/rrvglm.R
index 4d8c951..45bab6a 100644
--- a/R/rrvglm.R
+++ b/R/rrvglm.R
@@ -1,5 +1,7 @@
# These functions are
-# Copyright (C) 1998-2009 T.W. Yee, University of Auckland. All rights reserved.
+# Copyright (C) 1998-2010 T.W. Yee, University of Auckland. All rights reserved.
+
+
@@ -23,11 +25,11 @@ rrvglm <- function(formula,
ocall <- match.call()
- if(smart)
+ if (smart)
setup.smart("write")
mt <- terms(formula, data = data)
- if(missing(data))
+ if (missing(data))
data <- environment(formula)
mf <- match.call(expand=FALSE)
@@ -38,7 +40,7 @@ rrvglm <- function(formula,
mf$drop.unused.levels <- TRUE
mf[[1]] <- as.name("model.frame")
mf <- eval(mf, parent.frame())
- if(method == "model.frame")
+ if (method == "model.frame")
return(mf)
na.act <- attr(mf, "na.action")
@@ -57,29 +59,29 @@ rrvglm <- function(formula,
offset <- model.offset(mf)
- if(is.null(offset))
+ if (is.null(offset))
offset <- 0 # yyy ???
w <- model.weights(mf)
- if(!length(w))
+ if (!length(w))
w <- rep(1, nrow(mf))
- else if(ncol(as.matrix(w))==1 && any(w < 0))
+ else if (ncol(as.matrix(w))==1 && any(w < 0))
stop("negative weights not allowed")
- if(is.character(family))
+ if (is.character(family))
family <- get(family)
- if(is.function(family))
+ if (is.function(family))
family <- family()
- if(!inherits(family, "vglmff")) {
+ if (!inherits(family, "vglmff")) {
stop("'family=", family, "' is not a VGAM family function")
}
eval(vcontrol.expression)
- if(!is.null(family at first))
+ if (!is.null(family at first))
eval(family at first)
# 10/12/04: testing for an empty (function) slot not elegant:
- if(control$Quadratic && control$FastAlgorithm &&
+ if (control$Quadratic && control$FastAlgorithm &&
length(as.list(family at deviance)) <= 1)
stop("The fast algorithm requires the family ",
"function to have a deviance slot")
@@ -97,10 +99,10 @@ rrvglm <- function(formula,
qr.arg = qr.arg,
Terms=mt, function.name=function.name, ...)
- if(control$Bestof > 1) {
+ if (control$Bestof > 1) {
deviance.Bestof = rep(fit$crit.list$deviance, len= control$Bestof)
for(tries in 2:control$Bestof) {
- if(control$trace && (control$Bestof>1))
+ if (control$trace && (control$Bestof>1))
cat(paste("\n========================= Fitting model", tries,
"=========================\n\n"))
it <- rrvglm.fitter(x=x, y=y, w=w, offset=offset,
@@ -113,7 +115,7 @@ rrvglm <- function(formula,
qr.arg = qr.arg,
Terms=mt, function.name=function.name, ...)
deviance.Bestof[tries] = it$crit.list$deviance
- if(min(deviance.Bestof[1:(tries-1)]) > deviance.Bestof[tries])
+ if (min(deviance.Bestof[1:(tries-1)]) > deviance.Bestof[tries])
fit = it
}
fit$misc$deviance.Bestof = deviance.Bestof
@@ -121,7 +123,7 @@ rrvglm <- function(formula,
fit$misc$dataname <- dataname
- if(smart) {
+ if (smart) {
fit$smart.prediction <- get.smart.prediction()
wrapup.smart()
}
@@ -139,7 +141,7 @@ rrvglm <- function(formula,
"effects" = fit$effects,
"family" = fit$family,
"misc" = fit$misc,
- "model" = if(model) mf else data.frame(),
+ "model" = if (model) mf else data.frame(),
"R" = fit$R,
"rank" = fit$rank,
"residuals" = as.matrix(fit$residuals),
@@ -147,33 +149,33 @@ rrvglm <- function(formula,
"smart.prediction" = as.list(fit$smart.prediction),
"terms" = list(terms=mt))
- if(!smart) answer at smart.prediction <- list(smart.arg=FALSE)
+ if (!smart) answer at smart.prediction <- list(smart.arg=FALSE)
- if(qr.arg) {
+ if (qr.arg) {
class(fit$qr) = "list"
slot(answer, "qr") = fit$qr
}
- if(length(attr(x, "contrasts")))
+ if (length(attr(x, "contrasts")))
slot(answer, "contrasts") = attr(x, "contrasts")
- if(length(fit$fitted.values))
+ if (length(fit$fitted.values))
slot(answer, "fitted.values") = as.matrix(fit$fitted.values)
- slot(answer, "na.action") = if(length(na.act)) list(na.act) else list()
- if(length(offset))
+ slot(answer, "na.action") = if (length(na.act)) list(na.act) else list()
+ if (length(offset))
slot(answer, "offset") = as.matrix(offset)
- if(length(fit$weights))
+ if (length(fit$weights))
slot(answer, "weights") = as.matrix(fit$weights)
- if(x.arg)
+ if (x.arg)
slot(answer, "x") = fit$x # The 'small' design matrix
- if(length(xlev))
+ if (length(xlev))
slot(answer, "xlevels") = xlev
- if(y.arg)
+ if (y.arg)
slot(answer, "y") = as.matrix(fit$y)
answer at misc$formula = formula
slot(answer, "control") = fit$control
- slot(answer, "extra") = if(length(fit$extra)) {
- if(is.list(fit$extra)) fit$extra else {
+ 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)
}
@@ -184,7 +186,7 @@ rrvglm <- function(formula,
dimnames(fit$predictors) = list(dimnames(fit$predictors)[[1]],
fit$misc$predictors.names)
slot(answer, "predictors") = fit$predictors
- if(length(fit$prior.weights))
+ if (length(fit$prior.weights))
slot(answer, "prior.weights") = fit$prior.weights
diff --git a/R/rrvglm.control.q b/R/rrvglm.control.q
index 7663cba..5de4d87 100644
--- a/R/rrvglm.control.q
+++ b/R/rrvglm.control.q
@@ -1,5 +1,5 @@
# These functions are
-# Copyright (C) 1998-2009 T.W. Yee, University of Auckland. All rights reserved.
+# Copyright (C) 1998-2010 T.W. Yee, University of Auckland. All rights reserved.
@@ -7,10 +7,10 @@
rrvglm.control = function(Rank=1,
Algorithm=c("alternating", "derivative"),
Corner=TRUE,
- Uncor=FALSE,
+ Uncorrelated.lv=FALSE,
Wmat=NULL,
Svd.arg=FALSE,
- Index.corner=if(length(Structural.zero))
+ Index.corner = if (length(Structural.zero))
head((1:1000)[-Structural.zero], Rank) else 1:Rank,
Alpha=0.5,
Bestof = 1,
@@ -29,58 +29,58 @@ rrvglm.control = function(Rank=1,
- if(mode(Algorithm) != "character" && mode(Algorithm) != "name")
+ if (mode(Algorithm) != "character" && mode(Algorithm) != "name")
Algorithm <- as.character(substitute(Algorithm))
Algorithm <- match.arg(Algorithm, c("alternating", "derivative"))[1]
- if(Svd.arg) Corner = FALSE
+ if (Svd.arg) Corner = FALSE
- if(!is.Numeric(Rank, posit=TRUE, allow=1, integer=TRUE))
+ if (!is.Numeric(Rank, posit=TRUE, allow=1, integer=TRUE))
stop("bad input for 'Rank'")
- if(!is.Numeric(Alpha, posit=TRUE, allow=1) || Alpha > 1)
+ if (!is.Numeric(Alpha, posit=TRUE, allow=1) || Alpha > 1)
stop("bad input for 'Alpha'")
- if(!is.Numeric(Bestof, posit=TRUE, allow=1, integer=TRUE))
+ if (!is.Numeric(Bestof, posit=TRUE, allow=1, integer=TRUE))
stop("bad input for 'Bestof'")
- if(!is.Numeric(SD.Cinit, posit=TRUE, allow=1))
+ if (!is.Numeric(SD.Cinit, posit=TRUE, allow=1))
stop("bad input for 'SD.Cinit'")
- if(!is.Numeric(Etamat.colmax, posit=TRUE, allow=1) || Etamat.colmax < Rank)
+ if (!is.Numeric(Etamat.colmax, posit=TRUE, allow=1) || Etamat.colmax < Rank)
stop("bad input for 'Etamat.colmax'")
- if(length(Structural.zero) && (any(round(Structural.zero) != Structural.zero)
+ if (length(Structural.zero) && (any(round(Structural.zero) != Structural.zero)
|| any(Structural.zero<1)))
stop("bad input for the argument 'Structural.zero'")
Quadratic = FALSE
- if(!Quadratic && Algorithm == "derivative" && !Corner) {
+ if (!Quadratic && Algorithm == "derivative" && !Corner) {
dd = "derivative algorithm only supports corner constraints"
- if(length(Wmat) || Uncor || Svd.arg)
+ if (length(Wmat) || Uncorrelated.lv || Svd.arg)
stop(dd)
warning(dd)
Corner = TRUE
}
- if(Quadratic && Algorithm != "derivative")
+ if (Quadratic && Algorithm != "derivative")
stop("Quadratic model can only be fitted using the derivative algorithm")
- if(Corner && (Svd.arg || Uncor || length(Wmat)))
- stop("cannot have Corner=TRUE and either Svd=TRUE or Uncor=TRUE or Wmat")
+ if (Corner && (Svd.arg || Uncorrelated.lv || length(Wmat)))
+ stop("cannot have Corner=TRUE and either Svd=TRUE or Uncorrelated.lv=TRUE or Wmat")
- if(Corner && length(intersect(Structural.zero, Index.corner)))
+ if (Corner && length(intersect(Structural.zero, Index.corner)))
stop("cannot have Structural.zero and Index.corner having common values")
- if(length(Index.corner) != Rank)
+ if (length(Index.corner) != Rank)
stop("length(Index.corner) != Rank")
- if(!is.logical(checkwz) || length(checkwz) != 1)
+ if (!is.logical(checkwz) || length(checkwz) != 1)
stop("bad input for 'checkwz'")
- if(!is.Numeric(wzepsilon, allow=1, positive=TRUE))
+ if (!is.Numeric(wzepsilon, allow=1, positive=TRUE))
stop("bad input for 'wzepsilon'")
ans =
c(vglm.control(trace = trace, ...),
switch(Algorithm,
"alternating" = valt.control(...),
- "derivative" = if(is.R()) rrvglm.optim.control(...) else
+ "derivative" = if (is.R()) rrvglm.optim.control(...) else
nlminbcontrol(...)),
list(Rank=Rank,
Algorithm=Algorithm,
@@ -89,7 +89,7 @@ rrvglm.control = function(Rank=1,
Cinit=Cinit,
Index.corner=Index.corner,
Norrr=Norrr,
- Corner=Corner, Uncor=Uncor, Wmat=Wmat,
+ Corner=Corner, Uncorrelated.lv=Uncorrelated.lv, Wmat=Wmat,
OptimizeWrtC = TRUE, # OptimizeWrtC,
Quadratic = FALSE, # A constant now, here.
SD.Cinit = SD.Cinit,
@@ -99,11 +99,11 @@ rrvglm.control = function(Rank=1,
Use.Init.Poisson.QO=Use.Init.Poisson.QO),
checkwz=checkwz,
wzepsilon = wzepsilon,
- if(Quadratic) qrrvglm.control(Rank=Rank, ...) else NULL)
+ if (Quadratic) qrrvglm.control(Rank=Rank, ...) else NULL)
- if(Quadratic && ans$ITolerances) {
+ if (Quadratic && ans$ITolerances) {
ans$Svd.arg = FALSE
- ans$Uncor = FALSE
+ ans$Uncorrelated.lv = FALSE
ans$Corner = FALSE
}
@@ -126,11 +126,13 @@ setMethod("summary", "rrvglm",
summary.rrvglm(object, ...))
+
+
printsummary.rrvglm <- function(x, digits=NULL, quote= TRUE, prefix="")
{
- printsummary.vglm(x, digits = NULL, quote = TRUE, prefix = "")
+ printsummary.vglm(x, digits = digits, quote = quote, prefix = prefix)
invisible(x)
diff --git a/R/rrvglm.fit.q b/R/rrvglm.fit.q
index ba82a72..a338bd6 100644
--- a/R/rrvglm.fit.q
+++ b/R/rrvglm.fit.q
@@ -1,5 +1,5 @@
# These functions are
-# Copyright (C) 1998-2009 T.W. Yee, University of Auckland. All rights reserved.
+# Copyright (C) 1998-2010 T.W. Yee, University of Auckland. All rights reserved.
@@ -31,19 +31,19 @@ rrvglm.fit <- function(x, y, w=rep(1, length(x[, 1])),
n <- dim(x)[1]
new.s.call <- expression({
- if(c.list$one.more)
+ if (c.list$one.more)
{
fv <- c.list$fit
new.coeffs <- c.list$coeff
- if(length(family at middle))
+ if (length(family at middle))
eval(family at middle)
eta <- fv + offset
mu <- family at inverse(eta, extra)
- if(length(family at middle2))
+ if (length(family at middle2))
eval(family at middle2)
old.crit <- new.crit
@@ -54,7 +54,7 @@ rrvglm.fit <- function(x, y, w=rep(1, length(x[, 1])),
- if(trace && orig.stepsize==1) {
+ if (trace && orig.stepsize==1) {
cat(if(control$Quadratic) "QRR-VGLM" else "RR-VGLM",
" linear loop ", iter, ": ", criterion, "= ")
uuuu = switch(criterion, coefficients=
@@ -73,36 +73,36 @@ rrvglm.fit <- function(x, y, w=rep(1, length(x[, 1])),
(criterion!="coefficients" &&
(if(minimize.criterion) new.crit > old.crit else
new.crit < old.crit)))
- if(!is.logical(take.half.step))
+ if (!is.logical(take.half.step))
take.half.step = TRUE
- if(take.half.step) {
+ if (take.half.step) {
stepsize <- 2 * min(orig.stepsize, 2*stepsize)
new.coeffs.save <- new.coeffs
- if(trace)
+ if (trace)
cat("Taking a modified step")
repeat {
- if(trace) {
+ if (trace) {
cat(".")
flush.console()
}
stepsize <- stepsize / 2
- if(too.small <- stepsize < 0.001)
+ if (too.small <- stepsize < 0.001)
break
new.coeffs <- (1-stepsize)*old.coeffs +
stepsize*new.coeffs.save
- if(length(family at middle))
+ if (length(family at middle))
eval(family at middle)
fv <- X_vlm_save %*% new.coeffs
- if(M > 1)
+ if (M > 1)
fv <- matrix(fv, n, M, byrow=TRUE)
eta <- fv + offset
mu <- family at inverse(eta, extra)
- if(length(family at middle2))
+ if (length(family at middle2))
eval(family at middle2)
@@ -111,20 +111,20 @@ rrvglm.fit <- function(x, y, w=rep(1, length(x[, 1])),
coefficients=new.coeffs,
tfun(mu=mu,y=y,w=w,res=FALSE,eta=eta,extra))
- if((criterion=="coefficients") ||
+ if ((criterion=="coefficients") ||
( minimize.criterion && new.crit < old.crit) ||
(!minimize.criterion && new.crit > old.crit))
break
}
- if(trace)
+ if (trace)
cat("\n")
- if(too.small) {
+ if (too.small) {
warning("iterations terminated because ",
"half-step sizes are very small")
one.more <- FALSE
} else {
- if(trace) {
+ if (trace) {
cat(if(control$Quadratic) "QRR-VGLM" else "RR-VGLM",
" linear loop ", iter, ": ", criterion, "= ")
uuuu = switch(criterion, coefficients=
@@ -145,11 +145,11 @@ rrvglm.fit <- function(x, y, w=rep(1, length(x[, 1])),
}
flush.console()
- if(one.more) {
+ if (one.more) {
iter <- iter + 1
deriv.mu <- eval(family at deriv)
wz <- eval(family at weight)
- if(control$checkwz)
+ if (control$checkwz)
wz = checkwz(wz, M=M, trace=trace, wzeps=control$wzepsilon)
@@ -165,7 +165,7 @@ rrvglm.fit <- function(x, y, w=rep(1, length(x[, 1])),
c.list$z <- z # contains \bI_{Rank} \bnu
c.list$U <- U
- if(copy_X_vlm) c.list$X_vlm <- X_vlm_save
+ if (copy_X_vlm) c.list$X_vlm <- X_vlm_save
}
c.list$one.more <- one.more
@@ -194,29 +194,29 @@ rrvglm.fit <- function(x, y, w=rep(1, length(x[, 1])),
Rank <- control$Rank
rrcontrol <- control #
- if(length(slot(family, "initialize")))
+ if (length(slot(family, "initialize")))
eval(slot(family, "initialize")) # Initialize mu & M (and optionally w)
eval(rrr.init.expression)
- if(length(etastart)) {
+ if (length(etastart)) {
eta <- etastart
- mu <- if(length(mustart)) mustart else
+ mu <- if (length(mustart)) mustart else
slot(family, "inverse")(eta, extra)
} else {
- if(length(mustart))
+ if (length(mustart))
mu <- mustart
eta <- slot(family, "link")(mu, extra)
}
- M <- if(is.matrix(eta)) ncol(eta) else 1
+ M <- if (is.matrix(eta)) ncol(eta) else 1
- if(is.character(rrcontrol$Dzero)) {
+ if (is.character(rrcontrol$Dzero)) {
index = match(rrcontrol$Dzero, dimnames(as.matrix(y))[[2]])
- if(any(is.na(index)))
+ if (any(is.na(index)))
stop("Dzero argument didn't fully match y-names")
- if(length(index) == M)
+ if (length(index) == M)
stop("all linear predictors are linear in the ",
"latent variable(s); so set 'Quadratic=FALSE'")
rrcontrol$Dzero = control$Dzero = index
@@ -226,7 +226,7 @@ rrvglm.fit <- function(x, y, w=rep(1, length(x[, 1])),
- if(length(family at constraints))
+ if (length(family at constraints))
eval(family at constraints)
@@ -235,21 +235,21 @@ rrvglm.fit <- function(x, y, w=rep(1, length(x[, 1])),
findex = trivial.constraints(just.testing, special.matrix)
tc1 = trivial.constraints(constraints)
- if(!control$Quadratic && sum(!tc1)) {
+ if (!control$Quadratic && sum(!tc1)) {
for(ii in names(tc1))
- if(!tc1[ii] && !any(ii == names(findex)[findex==1]))
+ if (!tc1[ii] && !any(ii == names(findex)[findex==1]))
warning("'", ii, "' is a non-trivial constraint that ",
"will be overwritten by reduced-rank regression")
}
- if(all(findex == 1))
+ if (all(findex == 1))
stop("use vglm(), not rrvglm()!")
colx1.index = names.colx1.index = NULL
dx2 = dimnames(x)[[2]]
- if(sum(findex)) {
+ if (sum(findex)) {
asx = attr(x, "assign")
for(ii in names(findex))
- if(findex[ii]) {
+ if (findex[ii]) {
names.colx1.index = c(names.colx1.index, dx2[asx[[ii]]])
colx1.index = c(colx1.index, asx[[ii]])
}
@@ -266,10 +266,10 @@ rrvglm.fit <- function(x, y, w=rep(1, length(x[, 1])),
- Amat <- if(length(rrcontrol$Ainit)) rrcontrol$Ainit else
+ Amat <- if (length(rrcontrol$Ainit)) rrcontrol$Ainit else
matrix(rnorm(M * Rank, sd=rrcontrol$SD.Cinit), M, Rank)
- Cmat <- if(length(rrcontrol$Cinit)) rrcontrol$Cinit else {
- if(!rrcontrol$Use.Init.Poisson.QO) {
+ Cmat <- if (length(rrcontrol$Cinit)) rrcontrol$Cinit else {
+ if (!rrcontrol$Use.Init.Poisson.QO) {
matrix(rnorm(p2 * Rank, sd=rrcontrol$SD.Cinit), p2, Rank)
} else
.Init.Poisson.QO(ymat=as.matrix(y),
@@ -281,13 +281,13 @@ rrvglm.fit <- function(x, y, w=rep(1, length(x[, 1])),
isdlv=rrcontrol$isdlv)
}
- if(modelno==3)
+ if (modelno==3)
Amat[c(FALSE,TRUE),] <- 0 # Intercept only for log(k)
- if(control$Corner)
+ if (control$Corner)
Amat[control$Index.corner,] = diag(Rank)
- if(length(control$Structural.zero))
+ if (length(control$Structural.zero))
Amat[control$Structural.zero,] = 0
rrcontrol$Ainit = control$Ainit = Amat # Good for valt()
@@ -305,18 +305,18 @@ rrvglm.fit <- function(x, y, w=rep(1, length(x[, 1])),
dimB <- sum(ncolBlist)
- X_vlm_save <- if(control$Quadratic) {
+ X_vlm_save <- if (control$Quadratic) {
tmp500 = lm2qrrvlm.model.matrix(x=x, Blist=Blist,
C=Cmat, control=control)
xsmall.qrr = tmp500$new.lv.model.matrix
B.list = tmp500$constraints # Doesn't change or contain \bI_{Rank} \bnu
- if(modelno==3 && FALSE) {
+ if (modelno==3 && FALSE) {
B.list[[1]] = (B.list[[1]])[,c(TRUE,FALSE),drop=FALSE] # Amat
B.list[[2]] = (B.list[[2]])[,c(TRUE,FALSE),drop=FALSE] # D
}
lv.mat = tmp500$lv.mat
- if(length(tmp500$offset)) {
+ if (length(tmp500$offset)) {
offset = tmp500$offset
}
lm2vlm.model.matrix(xsmall.qrr, B.list, xij=control$xij)
@@ -328,16 +328,16 @@ rrvglm.fit <- function(x, y, w=rep(1, length(x[, 1])),
- if(length(coefstart)) {
- eta <- if(ncol(X_vlm_save)>1) X_vlm_save %*% coefstart +
+ 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)
+ eta <- if (M > 1) matrix(eta, ncol=M, byrow=TRUE) else c(eta)
mu <- family at inverse(eta, extra)
}
- if(criterion != "coefficients") {
+ if (criterion != "coefficients") {
tfun <- slot(family, criterion) # family[[criterion]]
}
@@ -345,13 +345,13 @@ rrvglm.fit <- function(x, y, w=rep(1, length(x[, 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
+ old.crit <- if (minimize.criterion) 10*new.crit+10 else -10*new.crit-10
deriv.mu <- eval(family at deriv)
wz <- eval(family at weight)
- if(control$checkwz)
+ if (control$checkwz)
wz = checkwz(wz, M=M, trace=trace, wzeps=control$wzepsilon)
U <- vchol(wz, M=M, n=n, silent=!trace)
@@ -361,7 +361,7 @@ rrvglm.fit <- function(x, y, w=rep(1, length(x[, 1])),
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))
+ X_vlm = if (copy_X_vlm) as.double(X_vlm_save) else double(3))
@@ -369,53 +369,53 @@ rrvglm.fit <- function(x, y, w=rep(1, length(x[, 1])),
nrow_X_vlm <- dX_vlm[[1]]
ncol_X_vlm <- dX_vlm[[2]]
- if(nrow_X_vlm < ncol_X_vlm)
+ 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, zedd,
- Blist=if(control$Quadratic) B.list else Blist,
+ Blist = if (control$Quadratic) B.list else Blist,
ncolx=ncol(x), U=U,
Eta.range = control$Eta.range,
- matrix.out=if(control$Quadratic) FALSE else TRUE, is.vlmX=TRUE,
- qr=qr.arg, xij=control$xij))
+ matrix.out = if (control$Quadratic) FALSE else TRUE,
+ is.vlmX = TRUE, qr = qr.arg, xij = control$xij))
while(c.list$one.more) {
- if(control$Quadratic) {
+ if (control$Quadratic) {
zedd = as.matrix(z)
- if(control$Corner)
+ if (control$Corner)
zedd[,Index.corner] = zedd[,Index.corner] - lv.mat
} else {
zedd = z
}
- if(!nice31)
+ if (!nice31)
tfit <- eval(bf.call) # tfit$fitted.values is n x M
- if(!control$Quadratic) {
+ if (!control$Quadratic) {
Cmat = tfit$mat.coef[colx2.index,,drop=FALSE] %*%
Amat %*% solve(t(Amat) %*% Amat)
rrcontrol$Ainit = control$Ainit = Amat # Good for valt()
rrcontrol$Cinit = control$Cinit = Cmat # Good for valt()
}
- if(!nice31) c.list$coeff <- tfit$coefficients
+ if (!nice31) c.list$coeff <- tfit$coefficients
- if(control$Quadratic) {
- if(control$Corner)
+ if (control$Quadratic) {
+ if (control$Corner)
tfit$fitted.values[,Index.corner] =
tfit$fitted.values[,Index.corner] + lv.mat
}
- if(!nice31)
+ if (!nice31)
tfit$predictors = tfit$fitted.values # Doesn't contain the offset
- if(!nice31) c.list$fit = tfit$fitted.values
+ if (!nice31) c.list$fit = tfit$fitted.values
c.list <- eval(new.s.call)
NULL
}
}
- if(maxit>1 && iter>=maxit)
+ if (maxit>1 && iter>=maxit)
warning("convergence not obtained in ", maxit, " iterations")
@@ -423,14 +423,14 @@ rrvglm.fit <- function(x, y, w=rep(1, length(x[, 1])),
xnrow_X_vlm <- dnrow_X_vlm[[2]]
ynrow_X_vlm <- dnrow_X_vlm[[1]]
- if(length(family at fini))
+ if (length(family at fini))
eval(family at fini)
- if(M>1 && !nice31)
+ if (M>1 && !nice31)
tfit$predictors <- matrix(tfit$predictors, n, M)
asgn <- attr(X_vlm_save, "assign")
- if(nice31) {
+ if (nice31) {
coefs <- rep(0, len=length(xnrow_X_vlm))
rank <- ncol_X_vlm
} else {
@@ -441,10 +441,10 @@ rrvglm.fit <- function(x, y, w=rep(1, length(x[, 1])),
cnames <- xnrow_X_vlm
- if(check.rank && rank < ncol_X_vlm)
+ if (check.rank && rank < ncol_X_vlm)
stop("rrvglm only handles full-rank models (currently)")
- if(nice31) {
+ if (nice31) {
R <- matrix(as.numeric(NA), 5, 5)
} else {
R <- tfit$qr$qr[1:ncol_X_vlm, 1:ncol_X_vlm, drop=FALSE]
@@ -453,7 +453,7 @@ rrvglm.fit <- function(x, y, w=rep(1, length(x[, 1])),
dimnames=list(cnames, cnames), rank=rank)
}
- if(nice31) {
+ if (nice31) {
effects <- rep(0, len=77)
} else {
effects <- tfit$effects
@@ -467,9 +467,9 @@ rrvglm.fit <- function(x, y, w=rep(1, length(x[, 1])),
yn <- dn[[1]]
xn <- dn[[2]]
- if(nice31) {
+ if (nice31) {
residuals <- z - fv
- if(M==1) {
+ if (M==1) {
residuals <- as.vector(residuals)
names(residuals) <- yn
} else {
@@ -477,7 +477,7 @@ rrvglm.fit <- function(x, y, w=rep(1, length(x[, 1])),
}
} else {
residuals <- z - tfit$predictors
- if(M==1) {
+ if (M==1) {
tfit$predictors <- as.vector(tfit$predictors)
residuals <- as.vector(residuals)
names(residuals) <- names(tfit$predictors) <- yn
@@ -486,11 +486,11 @@ rrvglm.fit <- function(x, y, w=rep(1, length(x[, 1])),
}
}
- if(is.matrix(mu)) {
- if(length(dimnames(y)[[2]])) {
+ if (is.matrix(mu)) {
+ if (length(dimnames(y)[[2]])) {
y.names <- dimnames(y)[[2]]
}
- if(length(dimnames(mu)[[2]])) {
+ if (length(dimnames(mu)[[2]])) {
y.names <- dimnames(mu)[[2]]
}
dimnames(mu) <- list(yn, y.names)
@@ -503,7 +503,7 @@ rrvglm.fit <- function(x, y, w=rep(1, length(x[, 1])),
df.residual <- nrow_X_vlm - rank - (if(control$Quadratic) Rank*p2 else 0)
fit <- list(assign=asgn,
coefficients=coefs,
- constraints=if(control$Quadratic) B.list else Blist,
+ constraints = if (control$Quadratic) B.list else Blist,
df.residual=df.residual,
df.total=n*M,
effects=effects,
@@ -514,15 +514,15 @@ rrvglm.fit <- function(x, y, w=rep(1, length(x[, 1])),
R=R,
terms=Terms) # terms: This used to be done in vglm()
- if(qr.arg && !nice31) {
+ if (qr.arg && !nice31) {
fit$qr <- tfit$qr
dimnames(fit$qr$qr) <- dnrow_X_vlm
}
- if(M==1) {
+ if (M==1) {
wz <- as.vector(wz) # Convert wz into a vector
} # else
- fit$weights <- if(save.weight) wz else NULL
+ fit$weights <- if (save.weight) wz else NULL
misc <- list(
@@ -541,16 +541,16 @@ rrvglm.fit <- function(x, y, w=rep(1, length(x[, 1])),
ncol_X_vlm = ncol_X_vlm,
ynames = dimnames(y)[[2]])
- if(one.more)
+ if (one.more)
misc$rrr.expression = rrr.expression #
crit.list <- list()
- if(criterion != "coefficients")
+ if (criterion != "coefficients")
crit.list[[criterion]] <- fit[[criterion]] <- new.crit
for(ii in names(.min.criterion.VGAM)) {
- if(ii != criterion &&
+ 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)
@@ -559,14 +559,15 @@ rrvglm.fit <- function(x, y, w=rep(1, length(x[, 1])),
- if(w[1] != 1 || any(w != w[1]))
+ if (w[1] != 1 || any(w != w[1]))
fit$prior.weights <- w
- if(length(family at last))
+ if (length(family at last))
eval(family at last)
- structure(c(fit, list(predictors=if(nice31) matrix(eta,n,M) else tfit$predictors,
+ structure(c(fit, list(predictors = if (nice31) matrix(eta,n,M) else
+ tfit$predictors,
contrasts=attr(x, "contrasts"),
control=control,
crit.list=crit.list,
@@ -575,7 +576,7 @@ rrvglm.fit <- function(x, y, w=rep(1, length(x[, 1])),
iter=iter,
misc=misc,
post = post,
- rss=if(nice31) 000 else tfit$rss,
+ rss = if (nice31) 000 else tfit$rss,
x=x,
y=y)),
vclass=family at vfamily)
diff --git a/R/s.q b/R/s.q
index 6f903bc..d01370a 100644
--- a/R/s.q
+++ b/R/s.q
@@ -1,5 +1,5 @@
# These functions are
-# Copyright (C) 1998-2009 T.W. Yee, University of Auckland. All rights reserved.
+# Copyright (C) 1998-2010 T.W. Yee, University of Auckland. All rights reserved.
@@ -9,15 +9,15 @@ s <- function(x, df=4, spar=0, ...)
xs <- substitute(x)
ans <- as.character(xs)
- if(length(ans) > 1)
+ if (length(ans) > 1)
stop("x argument must be of length one")
call <- deparse(sys.call())
- if(ncol(as.matrix(x)) > 1)
+ if (ncol(as.matrix(x)) > 1)
stop("x must be a vector")
- if(!is.null(levels(x))) {
- x <- if(inherits(x, "ordered")) codes(x) else
+ if (!is.null(levels(x))) {
+ x <- if (inherits(x, "ordered")) codes(x) else
stop("unordered factors cannot be used as smoothing variables")
}
attr(x, "spar") <- spar
@@ -28,7 +28,7 @@ s <- function(x, df=4, spar=0, ...)
a <- is.na(x)
- if(any(a))
+ if (any(a))
attr(x, "NAs") <- seq(along = x)[a]
x
diff --git a/R/s.vam.q b/R/s.vam.q
index 6a4a7e2..1b45925 100644
--- a/R/s.vam.q
+++ b/R/s.vam.q
@@ -1,5 +1,5 @@
# These functions are
-# Copyright (C) 1998-2009 T.W. Yee, University of Auckland. All rights reserved.
+# Copyright (C) 1998-2010 T.W. Yee, University of Auckland. All rights reserved.
@@ -18,7 +18,7 @@ s.vam <- function(x, z, wz, s, which, smooth.frame, bf.maxit=10,
pbig <- dX_vlm[2]
- if(!length(smooth.frame$first)) {
+ if (!length(smooth.frame$first)) {
data <- smooth.frame[, nwhich, drop=FALSE]
smooth.frame <- vgam.match(data, all.knots=all.knots, nk=nk)
smooth.frame$first <- FALSE # No longer first for next time
@@ -36,24 +36,24 @@ s.vam <- function(x, z, wz, s, which, smooth.frame, bf.maxit=10,
i <- nwhich[k]
temp <- spar[[i]]
- if(!is.numeric(temp) || any(temp<0))
+ if (!is.numeric(temp) || any(temp<0))
stop("spar cannot be negative or non-numeric")
- if(length(temp) > ncolBlist[i])
+ if (length(temp) > ncolBlist[i])
warning("only the first ", ncolBlist[i], " values of 'spar' ",
" are used for variable '", s.xargument, "'")
spar[[i]] <- rep(temp, length=ncolBlist[i]) # recycle
temp <- df[[i]]
- if(!is.numeric(temp) || any(temp<1))
+ if (!is.numeric(temp) || any(temp<1))
stop("df is non-numeric or less than 1")
- if(length(temp) > ncolBlist[i])
+ if (length(temp) > ncolBlist[i])
warning("only the first", ncolBlist[i], "values of 'df' ",
"are used for variable '", s.xargument, "'")
df[[i]] <- rep(temp, length=ncolBlist[i]) # recycle
- if(max(temp) > smooth.frame$nef[k]-1)
+ if (max(temp) > smooth.frame$nef[k]-1)
stop("'df' value too high for variable '", s.xargument, "'")
- if(any(spar[[i]]!=0) && any(df[[i]]!=4))
+ if (any(spar[[i]]!=0) && any(df[[i]]!=4))
stop("cannot specify both 'spar' and 'df'")
}
@@ -62,7 +62,7 @@ s.vam <- function(x, z, wz, s, which, smooth.frame, bf.maxit=10,
smooth.frame$spar <- spar # original
smooth.frame$df <- df # original
- if(sum(smooth.frame$df[smooth.frame$spar==0]) + pbig >
+ if (sum(smooth.frame$df[smooth.frame$spar==0]) + pbig >
smooth.frame$n * sum(ncolBlist[nwhich]))
stop("too many parameters/dof for data on hand")
@@ -87,7 +87,7 @@ s.vam <- function(x, z, wz, s, which, smooth.frame, bf.maxit=10,
smooth.frame$nknots*ncolBlist[nwhich])))
smooth.frame$kindex = as.integer(cumsum(c(1, 4+smooth.frame$nknots)))
}
- if(sf.only)
+ if (sf.only)
return(smooth.frame)
ldk <- 4 * max(ncolBlist[nwhich]) # was M; # Prior to 11/7/02
@@ -97,15 +97,15 @@ s.vam <- function(x, z, wz, s, which, smooth.frame, bf.maxit=10,
which <- unlist(which)
p <- smooth.frame$p
n <- smooth.frame$n
- dimw <- if(is.matrix(wz)) ncol(wz) else 1
+ dimw <- if (is.matrix(wz)) ncol(wz) else 1
- dimu <- if(is.matrix(U)) nrow(U) else 1
+ dimu <- if (is.matrix(U)) nrow(U) else 1
index <- iam(NA, NA, M, both=TRUE)
nBlist <- names(Blist)
for(i in length(nBlist):1) {
- if(!any(nBlist[i] == nwhich))
+ if (!any(nBlist[i] == nwhich))
Blist[[i]] <- NULL
}
trivc <- trivial.constraints(Blist)
@@ -132,7 +132,7 @@ s.vam <- function(x, z, wz, s, which, smooth.frame, bf.maxit=10,
as.integer(smooth.frame$o),as.integer(smooth.frame$nef),as.integer(which),
etal = double(M*n), smooth = as.double(s), eta = double(M*n),
s0 = double((2*M)*(2*M)*2),
- beta = double(pbig), var = if(se.fit) as.double(s) else double(1),
+ beta = double(pbig), var = if (se.fit) as.double(s) else double(1),
as.double(bf.epsilon),
qr = as.double(X_vlm_save), qraux = double(pbig),
qpivot = as.integer(1:pbig),
@@ -166,7 +166,7 @@ s.vam <- function(x, z, wz, s, which, smooth.frame, bf.maxit=10,
dimnames(fit$y) = dimnames(z)
dim(fit$smooth) = dim(s)
dimnames(fit$smooth) = dimnames(s) # Needed for vgam.nlchisq
- if(se.fit) {
+ if (se.fit) {
dim(fit$var) = dim(s)
dimnames(fit$var) = dimnames(s)
}
@@ -176,10 +176,10 @@ s.vam <- function(x, z, wz, s, which, smooth.frame, bf.maxit=10,
- if(fit$npetc[14] != 0)
+ if (fit$npetc[14] != 0)
stop("something went wrong in the Fortran subroutine vbfa()")
- fit$eta <- if(M>1) matrix(fit$eta,n,M,byrow=TRUE) else c(fit$eta)
+ fit$eta <- if (M>1) matrix(fit$eta,n,M,byrow=TRUE) else c(fit$eta)
nit <- fit$npetc[5]
qrank <- fit$npetc[7]
@@ -191,7 +191,7 @@ s.vam <- function(x, z, wz, s, which, smooth.frame, bf.maxit=10,
smooth.frame$try.spar[change] <- 0 # For next time
smooth.frame$prev.dof <- fit$df
- if((nit == bf.maxit) & bf.maxit > 1)
+ if ((nit == bf.maxit) & bf.maxit > 1)
warning("'s.vam' convergence not obtained in ", bf.maxit, " iterations")
R <- fit$qr[1:pbig, 1:pbig]
@@ -232,7 +232,7 @@ s.vam <- function(x, z, wz, s, which, smooth.frame, bf.maxit=10,
names(rl$spar) <- smooth.frame$ndfspar
names(rl$nl.df) <- smooth.frame$ndfspar
- if(se.fit)
+ if (se.fit)
rl <- c(rl, list(var=fit$var))
c(list(smooth.frame=smooth.frame), rl)
}
diff --git a/R/smart.R b/R/smart.R
index bffee5e..6bf7ef4 100644
--- a/R/smart.R
+++ b/R/smart.R
@@ -1,5 +1,5 @@
# These functions are
-# Copyright (C) 1998-2009 T.W. Yee, University of Auckland. All rights reserved.
+# Copyright (C) 1998-2010 T.W. Yee, University of Auckland. All rights reserved.
@@ -18,16 +18,16 @@ smartpredenv = new.env()
smart.mode.is <- function(mode.arg=NULL) {
- if(!length(mode.arg)) {
- if(exists(".smart.prediction", env=smartpredenv)) {
+ if (!length(mode.arg)) {
+ if (exists(".smart.prediction", env=smartpredenv)) {
get(".smart.prediction.mode", env=smartpredenv)
} else {
"neutral"
}
} else {
- if(mode.arg != "neutral" && mode.arg != "read" && mode.arg != "write")
+ if (mode.arg != "neutral" && mode.arg != "read" && mode.arg != "write")
stop("argument \"mode.arg\" must be one of \"neutral\", \"read\" or \"write\"")
- if(exists(".smart.prediction", env=smartpredenv)) {
+ if (exists(".smart.prediction", env=smartpredenv)) {
get(".smart.prediction.mode", env=smartpredenv)==mode.arg
} else {
mode.arg=="neutral"
@@ -37,13 +37,13 @@ stop("argument \"mode.arg\" must be one of \"neutral\", \"read\" or \"write\"")
setup.smart <- function(mode.arg, smart.prediction=NULL, max.smart=30) {
- actual <- if(mode.arg=="write") vector("list", max.smart) else
- if(mode.arg=="read") smart.prediction else
+ actual <- if (mode.arg=="write") vector("list", max.smart) else
+ if (mode.arg=="read") smart.prediction else
stop("value of mode.arg unrecognized")
wrapup.smart() # make sure
- if(length(actual)) {
+ if (length(actual)) {
# Double check that smart.prediction is not trivial (in "read" mode)
# If it is trivial then ignore it. This saves testing whether
# length(object$smart.prediction) > 0 in the predict methods function
@@ -58,13 +58,13 @@ setup.smart <- function(mode.arg, smart.prediction=NULL, max.smart=30) {
}
wrapup.smart <- function() {
- if(exists(".smart.prediction", envir = smartpredenv))
+ if (exists(".smart.prediction", envir = smartpredenv))
rm(".smart.prediction", envir = smartpredenv)
- if(exists(".smart.prediction.counter", envir = smartpredenv))
+ if (exists(".smart.prediction.counter", envir = smartpredenv))
rm(".smart.prediction.counter", envir = smartpredenv)
- if(exists(".smart.prediction.mode", envir = smartpredenv))
+ if (exists(".smart.prediction.mode", envir = smartpredenv))
rm(".smart.prediction.mode", envir = smartpredenv)
- if(exists(".max.smart", envir = smartpredenv))
+ if (exists(".max.smart", envir = smartpredenv))
rm(".max.smart", envir = smartpredenv)
}
@@ -75,10 +75,10 @@ get.smart.prediction <- function() {
envir = smartpredenv)
max.smart <- get(".max.smart", envir = smartpredenv)
- if(smart.prediction.counter > 0) {
+ if (smart.prediction.counter > 0) {
# Save this on the object for smart prediction later
smart.prediction <- get(".smart.prediction", envir = smartpredenv)
- if(max.smart >= (smart.prediction.counter+1))
+ if (max.smart >= (smart.prediction.counter+1))
for(i in max.smart:(smart.prediction.counter+1))
smart.prediction[[i]] <- NULL
smart.prediction
@@ -100,7 +100,7 @@ put.smart <- function(smart) {
smart.prediction <- get(".smart.prediction", envir = smartpredenv)
smart.prediction.counter <- smart.prediction.counter + 1
- if(smart.prediction.counter > max.smart) {
+ if (smart.prediction.counter > max.smart) {
# if list is too small, make it larger
max.smart <- max.smart + (inc.smart <- 10) # can change inc.smart
smart.prediction <- c(smart.prediction, vector("list", inc.smart))
@@ -147,16 +147,16 @@ smart.expression <- expression({
is.smart <- function(object) {
- if(is.function(object)) {
- if(is.logical(a <- attr(object, "smart"))) a else FALSE
+ if (is.function(object)) {
+ if (is.logical(a <- attr(object, "smart"))) a else FALSE
} else {
- if(length(slotNames(object))) {
- if(length(object at smart.prediction) == 1 &&
+ if (length(slotNames(object))) {
+ if (length(object at smart.prediction) == 1 &&
is.logical(object at smart.prediction$smart.arg))
object at smart.prediction$smart.arg else
any(slotNames(object) == "smart.prediction")
} else {
- if(length(object$smart.prediction) == 1 &&
+ if (length(object$smart.prediction) == 1 &&
is.logical(object$smart.prediction$smart.arg))
object$smart.prediction$smart.arg else
any(names(object) == "smart.prediction")
@@ -176,7 +176,7 @@ function (x, df = NULL, knots = NULL, degree = 3, intercept = FALSE,
Boundary.knots = range(x))
{
x <- x # Evaluate x
- if(smart.mode.is("read")) {
+ if (smart.mode.is("read")) {
return(eval(smart.expression))
}
@@ -246,7 +246,7 @@ function (x, df = NULL, knots = NULL, degree = 3, intercept = FALSE,
attributes(basis) <- c(attributes(basis), a)
class(basis) <- c("bs", "basis")
- if(smart.mode.is("write"))
+ if (smart.mode.is("write"))
put.smart(list(df=df,
knots=knots,
degree=degree,
@@ -262,7 +262,7 @@ ns <-
function (x, df = NULL, knots = NULL, intercept = FALSE, Boundary.knots = range(x))
{
x <- x # Evaluate x
- if(smart.mode.is("read")) {
+ if (smart.mode.is("read")) {
return(eval(smart.expression))
}
@@ -329,7 +329,7 @@ function (x, df = NULL, knots = NULL, intercept = FALSE, Boundary.knots = range(
attributes(basis) <- c(attributes(basis), a)
class(basis) <- c("ns", "basis")
- if(smart.mode.is("write"))
+ if (smart.mode.is("write"))
put.smart(list(df=df,
knots=knots,
intercept=intercept,
@@ -347,7 +347,7 @@ poly <-
function (x, ..., degree = 1, coefs = NULL, raw = FALSE)
{
x <- x # Evaluate x
- if(!raw && smart.mode.is("read")) {
+ if (!raw && smart.mode.is("read")) {
smart <- get.smart()
degree <- smart$degree
coefs <- smart$coefs
@@ -368,7 +368,7 @@ function (x, ..., degree = 1, coefs = NULL, raw = FALSE)
stop("'degree' must be at least 1")
# At prediction time x may be less than the degree
- if(smart.mode.is("write") || smart.mode.is("neutral"))
+ if (smart.mode.is("write") || smart.mode.is("neutral"))
if (degree >= length(x))
stop("degree must be less than number of points")
@@ -420,7 +420,7 @@ function (x, ..., degree = 1, coefs = NULL, raw = FALSE)
class(Z) <- c("poly", "matrix")
}
- if(smart.mode.is("write"))
+ if (smart.mode.is("write"))
put.smart(list(degree=degree, coefs=attr(Z, "coefs"),
raw=FALSE, # raw is changed above
match.call=match.call()))
@@ -435,7 +435,7 @@ function (x, center = TRUE, scale = TRUE)
{
x <- as.matrix(x)
- if(smart.mode.is("read")) {
+ if (smart.mode.is("read")) {
return(eval(smart.expression))
}
@@ -465,7 +465,7 @@ function (x, center = TRUE, scale = TRUE)
if (is.numeric(scale))
attr(x, "scaled:scale") <- scale
- if(smart.mode.is("write")) {
+ if (smart.mode.is("write")) {
put.smart(list(center=center, scale=scale,
match.call=match.call()))
}
@@ -485,11 +485,11 @@ attr(scale, "smart") <- TRUE
x <- x # Evaluate x
- if(smart.mode.is("read")) {
+ if (smart.mode.is("read")) {
smart <- get.smart()
minx <- smart$minx # Overwrite its value
} else
- if(smart.mode.is("write"))
+ if (smart.mode.is("write"))
put.smart(list(minx=minx))
(x-minx)^2
@@ -503,10 +503,10 @@ attr(my1, "smart") <- TRUE
x <- x # Evaluate x
- if(smart.mode.is("read")) {
+ if (smart.mode.is("read")) {
return(eval(smart.expression))
} else
- if(smart.mode.is("write"))
+ if (smart.mode.is("write"))
put.smart(list(minx=minx, match.call=match.call()))
(x-minx)^2
@@ -521,20 +521,20 @@ attr(my2, "smart") <- TRUE
x <- x # Evaluate x
- if(!is.vector(x))
+ if (!is.vector(x))
stop("x must be a vector")
- if(smart.mode.is("read")) {
+ if (smart.mode.is("read")) {
smart <- get.smart()
return((x-smart$center)/smart$scale)
}
- if(is.logical(center))
- center <- if(center) mean(x) else 0
- if(is.logical(scale))
- scale <- if(scale) sqrt(var(x)) else 1
+ if (is.logical(center))
+ center <- if (center) mean(x) else 0
+ if (is.logical(scale))
+ scale <- if (scale) sqrt(var(x)) else 1
- if(smart.mode.is("write"))
+ if (smart.mode.is("write"))
put.smart(list(center=center,
scale=scale))
# Normal use
@@ -546,19 +546,19 @@ attr(stdze1, "smart") <- TRUE
x <- x # Evaluate x
- if(!is.vector(x))
+ if (!is.vector(x))
stop("x must be a vector")
- if(smart.mode.is("read")) {
+ if (smart.mode.is("read")) {
return(eval(smart.expression))
}
- if(is.logical(center))
- center <- if(center) mean(x) else 0
- if(is.logical(scale))
- scale <- if(scale) sqrt(var(x)) else 1
+ if (is.logical(center))
+ center <- if (center) mean(x) else 0
+ if (is.logical(scale))
+ scale <- if (scale) sqrt(var(x)) else 1
- if(smart.mode.is("write"))
+ if (smart.mode.is("write"))
put.smart(list(center=center,
scale=scale,
match.call=match.call()))
diff --git a/R/step.vglm.q b/R/step.vglm.q
index 484c2da..517740e 100644
--- a/R/step.vglm.q
+++ b/R/step.vglm.q
@@ -1,5 +1,5 @@
# These functions are
-# Copyright (C) 1998-2009 T.W. Yee, University of Auckland. All rights reserved.
+# Copyright (C) 1998-2010 T.W. Yee, University of Auckland. All rights reserved.
step.vglm <- function(fit, ...)
diff --git a/R/summary.vgam.q b/R/summary.vgam.q
index 0a637db..bf62ee8 100644
--- a/R/summary.vgam.q
+++ b/R/summary.vgam.q
@@ -1,5 +1,5 @@
# These functions are
-# Copyright (C) 1998-2009 T.W. Yee, University of Auckland. All rights reserved.
+# Copyright (C) 1998-2010 T.W. Yee, University of Auckland. All rights reserved.
@@ -8,7 +8,7 @@
summaryvgam <- function(object, dispersion=NULL, digits=options()$digits-2)
{
- if(length(dispersion) && dispersion == 0 &&
+ if (length(dispersion) && dispersion == 0 &&
length(object at family@summary.dispersion) &&
!object at family@summary.dispersion) {
stop("cannot use the general VGLM formula (based on a residual ",
@@ -22,7 +22,7 @@ summaryvgam <- function(object, dispersion=NULL, digits=options()$digits-2)
M <- object at misc$M
nrow_X_vlm <- object at misc$nrow_X_vlm
- rank <- if(is.null(object at qr$rank)) length(object at coefficients) else
+ rank <- if (is.null(object at qr$rank)) length(object at coefficients) else
object at qr$rank
@@ -33,16 +33,16 @@ summaryvgam <- function(object, dispersion=NULL, digits=options()$digits-2)
useF <- object at misc$useF
- if(is.null(useF))
+ if (is.null(useF))
useF <- FALSE
df <- unlist(lapply(object at misc$new.assign, length))
nldf <- object at nl.df
- if(length(df)) {
+ if (length(df)) {
aod <- as.matrix(round(df, 1))
dimnames(aod) <- list(names(df), "Df")
- if(!is.null(object at nl.chisq)) {
+ if (!is.null(object at nl.chisq)) {
aod <- cbind(aod, NA, NA, NA)
nl.chisq <- object at nl.chisq / object at dispersion
@@ -51,28 +51,28 @@ summaryvgam <- function(object, dispersion=NULL, digits=options()$digits-2)
snames <- names(nldf)
aod[snames, 2] <- round(nldf, 1)
- aod[snames, 3] <- if(useF) nl.chisq/nldf else nl.chisq
- aod[snames, 4] <- if(useF) 1-pf(nl.chisq/nldf, nldf, rdf) else
- 1-pchisq(nl.chisq, nldf)
+ aod[snames, 3] <- if (useF) nl.chisq/nldf else nl.chisq
+ aod[snames, 4] <- if (useF) pf(nl.chisq/nldf, nldf, rdf, lower.tail=FALSE) else
+ pchisq(nl.chisq, nldf, lower.tail=FALSE)
- if(any(special)) {
+ if (any(special)) {
aod[snames[special], 2:4] = NA
}
rnames <- c("Df", "Npar Df", "Npar Chisq", "P(Chi)")
- if(useF)
+ if (useF)
rnames[3:4] <- c("Npar F", "Pr(F)")
dimnames(aod) <- list(names(df), rnames)
- heading <- if(useF)
+ heading <- if (useF)
"\nDF for Terms and Approximate F-values for Nonparametric Effects\n"
else
"\nDF for Terms and Approximate Chi-squares for Nonparametric Effects\n"
} else heading <- "DF for Terms\n\n"
aod <- as.vanova(data.frame(aod, check.names=FALSE), heading)
- if(is.R()) class(aod) = "data.frame"
+ if (is.R()) class(aod) = "data.frame"
}
- else aod <- if(is.R()) data.frame() else NULL
+ else aod <- if (is.R()) data.frame() else NULL
answer <-
new("summary.vgam",
@@ -84,11 +84,11 @@ summaryvgam <- function(object, dispersion=NULL, digits=options()$digits-2)
sigma=stuff at sigma)
slot(answer, "coefficients") = stuff at coefficients # Replace
- if(is.numeric(stuff at dispersion))
+ if (is.numeric(stuff at dispersion))
slot(answer, "dispersion") = stuff at dispersion
presid = residuals(object, type="pearson")
- if(length(presid))
+ if (length(presid))
answer at pearson.resid= as.matrix(presid)
slot(answer, "anova") = aod
@@ -110,39 +110,39 @@ printsummary.vgam <- function(x, quote=TRUE, prefix="", digits=options()$digits-
presid <- x at pearson.resid
rdf <- x at df[2]
- if(FALSE && !is.null(presid) && all(!is.na(presid))) {
+ if (FALSE && !is.null(presid) && all(!is.na(presid))) {
cat("\nPearson Residuals:\n")
- if(rdf/M > 5) {
+ if (rdf/M > 5) {
rq <- apply(as.matrix(presid), 2, quantile) # 5 x M
dimnames(rq) <- list(c("Min", "1Q", "Median", "3Q", "Max"),
x at misc$predictors.names)
print(t(rq), digits=digits)
} else
- if(rdf > 0) {
+ if (rdf > 0) {
print(presid, digits=digits)
}
}
cat("\nNumber of linear predictors: ", M, "\n")
- if(!is.null(x at misc$predictors.names))
- if(M==1)
+ if (!is.null(x at misc$predictors.names))
+ if (M==1)
cat("\nName of linear predictor:",
- paste(x at misc$predictors.names, collapse=", "), "\n") else if(M<=5)
+ paste(x at misc$predictors.names, collapse=", "), "\n") else if (M<=5)
cat("\nNames of linear predictors:",
paste(x at misc$predictors.names, collapse=", "), "\n")
prose <- ""
- if(length(x at dispersion)) {
- if(is.logical(x at misc$estimated.dispersion) &&
+ if (length(x at dispersion)) {
+ if (is.logical(x at misc$estimated.dispersion) &&
x at misc$estimated.dispersion)
prose <- "(Estimated) " else {
- if(is.numeric(x at misc$default.dispersion) &&
+ if (is.numeric(x at misc$default.dispersion) &&
x at dispersion==x at misc$default.dispersion)
prose <- "(Default) "
- if(is.numeric(x at misc$default.dispersion) &&
+ if (is.numeric(x at misc$default.dispersion) &&
x at dispersion!=x at misc$default.dispersion)
prose <- "(Pre-specified) "
}
@@ -151,25 +151,25 @@ printsummary.vgam <- function(x, quote=TRUE, prefix="", digits=options()$digits-
" family: ", format(round(x at dispersion, digits)), "\n", sep=""))
}
- if(length(deviance(x)))
+ if (length(deviance(x)))
cat("\nResidual Deviance: ", format(round(deviance(x), digits)),
"on", format(round(rdf, 3)), "degrees of freedom\n")
- if(length(logLik.vlm(x)))
+ if (length(logLik.vlm(x)))
cat("\nLog-likelihood:", format(round(logLik.vlm(x), digits)),
"on", format(round(rdf, 3)), "degrees of freedom\n")
- if(length(x at criterion)) {
+ if (length(x at criterion)) {
ncrit <- names(x at criterion)
for(i in ncrit)
- if(i!="loglikelihood" && i!="deviance")
+ if (i!="loglikelihood" && i!="deviance")
cat(paste(i, ":", sep=""), format(x at criterion[[i]]), "\n")
}
cat("\nNumber of Iterations: ", x at iter, "\n")
- if(length(x at anova)) {
+ if (length(x at anova)) {
printvanova(x at anova, dig=digits) # ".vanova" for Splus6
}
@@ -200,7 +200,7 @@ printvanova <- function(x, digits=.Options$digits, ...)
{
rrr <- row.names(x)
heading <- attr(x, "heading")
- if(!is.null(heading))
+ if (!is.null(heading))
cat(heading, sep="\n")
attr(x, "heading") <- NULL
for(i in 1:length(x)) {
@@ -210,7 +210,7 @@ printvanova <- function(x, digits=.Options$digits, ...)
xx[xna] <- ""
x[[i]] <- xx
}
- if(is.R()) {
+ if (is.R()) {
print.data.frame(as.data.frame(x, row.names=rrr))
invisible(x)
} else {
@@ -221,11 +221,11 @@ printvanova <- function(x, digits=.Options$digits, ...)
as.vanova <- function(x, heading)
{
- if(!is.data.frame(x))
+ if (!is.data.frame(x))
stop("x must be a data frame")
rrr <- row.names(x)
attr(x, "heading") <- heading
- if(is.R()) {
+ if (is.R()) {
x <- as.data.frame(x, row.names=rrr)
} else {
x <- as.data.frame(x, row.names=rrr)
diff --git a/R/summary.vglm.q b/R/summary.vglm.q
index 6b2617a..aa339cc 100644
--- a/R/summary.vglm.q
+++ b/R/summary.vglm.q
@@ -1,5 +1,5 @@
# These functions are
-# Copyright (C) 1998-2009 T.W. Yee, University of Auckland. All rights reserved.
+# Copyright (C) 1998-2010 T.W. Yee, University of Auckland. All rights reserved.
@@ -19,7 +19,7 @@ summaryvglm <- function(object, correlation=FALSE, dispersion=NULL, digits=NULL)
- if(length(dispersion) && dispersion == 0 &&
+ if (length(dispersion) && dispersion == 0 &&
length(object at family@summary.dispersion) &&
!object at family@summary.dispersion) {
stop("cannot use the general VGLM formula (based on a residual ",
@@ -42,12 +42,12 @@ summaryvglm <- function(object, correlation=FALSE, dispersion=NULL, digits=NULL)
sigma=stuff at sigma)
presid = resid(object, type="pearson")
- if(length(presid))
+ if (length(presid))
answer at pearson.resid = as.matrix(presid)
slot(answer, "misc") = stuff at misc # Replace
- if(is.numeric(stuff at dispersion))
+ if (is.numeric(stuff at dispersion))
slot(answer, "dispersion") = stuff at dispersion
answer
@@ -70,24 +70,24 @@ printsummary.vglm <- function(x, digits = NULL, quote = TRUE, prefix = "",
coef <- x at coef3 # icients
correl <- x at correlation
- digits <- if(is.null(digits)) options()$digits - 2 else digits
+ digits <- if (is.null(digits)) options()$digits - 2 else digits
cat("\nCall:\n")
dput(x at call)
Presid <- x at pearson.resid
rdf <- x at df[2]
- if(presid && length(Presid) && all(!is.na(Presid)) && is.finite(rdf))
+ if (presid && length(Presid) && all(!is.na(Presid)) && is.finite(rdf))
{
cat("\nPearson Residuals:\n")
- if(rdf/M > 5)
+ if (rdf/M > 5)
{
rq <- apply(as.matrix(Presid), 2, quantile) # 5 x M
dimnames(rq) <- list(c("Min", "1Q", "Median", "3Q", "Max"),
x at misc$predictors.names)
print(t(rq), digits = digits)
} else
- if(rdf > 0) {
+ if (rdf > 0) {
print(Presid, digits = digits)
}
}
@@ -97,24 +97,24 @@ printsummary.vglm <- function(x, digits = NULL, quote = TRUE, prefix = "",
cat("\nNumber of linear predictors: ", M, "\n")
- if(!is.null(x at misc$predictors.names))
- if(M==1)
+ if (!is.null(x at misc$predictors.names))
+ if (M==1)
cat("\nName of linear predictor:",
- paste(x at misc$predictors.names, collapse=", "), "\n") else if(M<=5)
+ paste(x at misc$predictors.names, collapse=", "), "\n") else if (M<=5)
cat("\nNames of linear predictors:",
paste(x at misc$predictors.names, collapse=", "), fill=TRUE)
prose <- ""
- if(length(x at dispersion)) {
- if(is.logical(x at misc$estimated.dispersion) &&
+ if (length(x at dispersion)) {
+ if (is.logical(x at misc$estimated.dispersion) &&
x at misc$estimated.dispersion)
prose <- "(Estimated) " else {
- if(is.numeric(x at misc$default.dispersion) &&
+ if (is.numeric(x at misc$default.dispersion) &&
x at dispersion==x at misc$default.dispersion)
prose <- "(Default) "
- if(is.numeric(x at misc$default.dispersion) &&
+ if (is.numeric(x at misc$default.dispersion) &&
x at dispersion!=x at misc$default.dispersion)
prose <- "(Pre-specified) "
}
@@ -123,23 +123,23 @@ printsummary.vglm <- function(x, digits = NULL, quote = TRUE, prefix = "",
" family: ", yformat(x at dispersion, digits), "\n", sep=""))
}
- if(length(deviance(x))) {
+ if (length(deviance(x))) {
cat("\nResidual Deviance:", yformat(deviance(x), digits))
- if(is.finite(rdf))
+ if (is.finite(rdf))
cat(" on", round(rdf, digits), "degrees of freedom\n") else
cat("\n")
}
- if(length(vll <- logLik.vlm(x))) {
+ if (length(vll <- logLik.vlm(x))) {
cat("\nLog-likelihood:", yformat(vll, digits))
- if(is.finite(rdf))
+ if (is.finite(rdf))
cat(" on", round(rdf, digits), "degrees of freedom\n") else
cat("\n")
}
- if(length(x at criterion)) {
+ if (length(x at criterion)) {
ncrit <- names(x at criterion)
for(i in ncrit)
- if(i!="loglikelihood" && i!="deviance")
+ if (i!="loglikelihood" && i!="deviance")
cat(paste(i, ":", sep=""), yformat(x at criterion[[i]], digits),
"\n")
}
@@ -147,10 +147,10 @@ printsummary.vglm <- function(x, digits = NULL, quote = TRUE, prefix = "",
cat("\nNumber of Iterations:", format(trunc(x at iter)), "\n")
- if(!is.null(correl))
+ if (!is.null(correl))
{
ncol_X_vlm <- dim(correl)[2]
- if(ncol_X_vlm > 1)
+ if (ncol_X_vlm > 1)
{
cat("\nCorrelation of Coefficients:\n")
ll <- lower.tri(correl)
@@ -184,48 +184,48 @@ printsummary.vglm <- function(x, digits = NULL, quote = TRUE, prefix = "",
vcovdefault <- function(object, ...) {
- if(is.null(object at vcov))
+ if (is.null(object at vcov))
stop("no default")
object at vcov
}
vcovvlm <- function(object, dispersion=NULL, untransform=FALSE) {
so <- summaryvlm(object, corr=FALSE, dispersion=dispersion)
- d = if(any(slotNames(so) == "dispersion") &&
+ d = if (any(slotNames(so) == "dispersion") &&
is.Numeric(so at dispersion)) so at dispersion else 1
answer = d * so at cov.unscaled
- if(is.logical(OKRC <- object at misc$RegCondOK) && !OKRC)
+ if (is.logical(OKRC <- object at misc$RegCondOK) && !OKRC)
warning("MLE regularity conditions were violated ",
"at the final iteration of the fitted object")
- if(!untransform) return(answer)
+ if (!untransform) return(answer)
- if(!is.logical(object at misc$intercept.only))
+ if (!is.logical(object at misc$intercept.only))
stop("cannot determine whether the object is",
"an intercept-only fit, i.e., 'y ~ 1' is the response")
- if(!object at misc$intercept.only)
+ if (!object at misc$intercept.only)
stop("object must be an intercept-only fit, i.e., ",
"y ~ 1 is the response")
- if(!all(trivial.constraints(constraints(object)) == 1))
+ if (!all(trivial.constraints(constraints(object)) == 1))
stop("object must have trivial constraints")
M = object at misc$M
Links = object at misc$link
- if(length(Links) != M && length(Links) != 1)
+ if (length(Links) != M && length(Links) != 1)
stop("cannot obtain the link functions to untransform the object")
tvector = numeric(M)
etavector = predict(object)[1,] # Contains transformed parameters
earg = object at misc$earg # This could be a NULL
- if(!is.null(earg) && M > 1 && (!is.list(earg) || length(earg) != M))
+ if (!is.null(earg) && M > 1 && (!is.list(earg) || length(earg) != M))
stop("the 'earg' component of 'object at misc' should be of length ", M)
for(ii in 1:M) {
TTheta = etavector[ii] # Transformed theta
- use.earg = if(M == 1 || is.null(earg)) earg else earg[[ii]]
- if(is.list(use.earg) && !length(use.earg))
+ use.earg = if (M == 1 || is.null(earg)) earg else earg[[ii]]
+ if (is.list(use.earg) && !length(use.earg))
use.earg = NULL
newcall = paste(Links[ii],
"(theta=TTheta, earg=use.earg, inverse=TRUE)", sep="")
@@ -238,7 +238,7 @@ vcovvlm <- function(object, dispersion=NULL, untransform=FALSE) {
}
tvector = abs(tvector)
answer = (cbind(tvector) %*% rbind(tvector)) * answer
- if(length(dmn2 <- names(object at misc$link)) == M)
+ if (length(dmn2 <- names(object at misc$link)) == M)
dimnames(answer) = list(dmn2, dmn2)
answer
}
diff --git a/R/summary.vlm.q b/R/summary.vlm.q
index 563144c..6f53a77 100644
--- a/R/summary.vlm.q
+++ b/R/summary.vlm.q
@@ -1,5 +1,5 @@
# These functions are
-# Copyright (C) 1998-2009 T.W. Yee, University of Auckland. All rights reserved.
+# Copyright (C) 1998-2010 T.W. Yee, University of Auckland. All rights reserved.
@@ -10,7 +10,7 @@ summaryvlm <- function(object, correlation=FALSE, dispersion=NULL)
{
- if(is.logical(object at misc$BFGS) && object at misc$BFGS)
+ if (is.logical(object at misc$BFGS) && object at misc$BFGS)
warning(paste("the estimated variance-covariance matrix is",
"usually inaccurate as the working weight matrices are a",
"crude BFGS quasi-Newton approximation"))
@@ -24,41 +24,41 @@ summaryvlm <- function(object, correlation=FALSE, dispersion=NULL)
cnames <- names(coef)
presid = residualsvlm(object, type="pearson") # NULL if pooled.weight
- if(any(is.na(coef))) {
+ if (any(is.na(coef))) {
warning(paste("Some NAs in the coefficients---no summary",
" provided; returning object\n"))
return(object)
}
rdf <- object at df.residual
- if(!length(dispersion)) {
- if(is.numeric(object at misc$dispersion)) {
+ if (!length(dispersion)) {
+ if (is.numeric(object at misc$dispersion)) {
dispersion <- object at misc$dispersion
- if(all(dispersion==0))
+ if (all(dispersion==0))
stop("dispersion shouldn't be zero here!")
} else {
dispersion <- 1
object at misc$estimated.dispersion <- FALSE
}
- } else if(dispersion==0) {
- dispersion <- if(!length(object at rss)) {
+ } else if (dispersion==0) {
+ dispersion <- if (!length(object at rss)) {
stop("object at rss is empty")
} else {
object at rss / object at df.residual
}
object at misc$estimated.dispersion <- TRUE
} else {
- if(is.numeric(object at misc$dispersion) &&
+ if (is.numeric(object at misc$dispersion) &&
object at misc$dispersion != dispersion)
warning("overriding the value of object at misc$dispersion")
object at misc$estimated.dispersion <- FALSE
}
sigma <- dispersion^0.5 # Can be a vector
- if(is.Numeric(ncol_X_vlm)) {
+ if (is.Numeric(ncol_X_vlm)) {
R <- object at R
- if(ncol_X_vlm < max(dim(R)))
+ if (ncol_X_vlm < max(dim(R)))
stop("R is rank deficient")
rinv = diag(ncol_X_vlm)
@@ -69,13 +69,13 @@ summaryvlm <- function(object, correlation=FALSE, dispersion=NULL)
}
coef <- matrix(rep(coef, 3), ncol=3)
dimnames(coef) <- list(cnames, c("Value", "Std. Error", "t value"))
- if(length(sigma) == 1 && is.Numeric(ncol_X_vlm)) {
+ if (length(sigma) == 1 && is.Numeric(ncol_X_vlm)) {
coef[, 2] <- rowlen %o% sigma # Fails here when sigma is a vector
coef[, 3] <- coef[, 1]/coef[, 2]
} else {
coef[,1] = coef[,2] = coef[,3] = NA
}
- if(correlation) {
+ if (correlation) {
correl <- covun * outer(1/rowlen, 1/rowlen)
dimnames(correl) <- list(cnames, cnames)
} else {
@@ -93,10 +93,10 @@ summaryvlm <- function(object, correlation=FALSE, dispersion=NULL)
df=c(ncol_X_vlm, rdf),
sigma=sigma)
- if(is.Numeric(ncol_X_vlm)) answer at cov.unscaled = covun
+ if (is.Numeric(ncol_X_vlm)) answer at cov.unscaled = covun
answer at dispersion = dispersion # Overwrite this
- if(length(presid))
+ if (length(presid))
answer at pearson.resid = as.matrix(presid)
@@ -114,7 +114,7 @@ printsummary.vlm <- function(x, digits=NULL, quote=TRUE, prefix="")
coef3 <- x at coef3 # ficients
correl <- x at correlation
- if(is.null(digits)) {
+ if (is.null(digits)) {
digits <- options()$digits
} else {
old.digits <- options(digits = digits)
@@ -126,29 +126,29 @@ printsummary.vlm <- function(x, digits=NULL, quote=TRUE, prefix="")
presid <- x at pearson.resid
rdf <- x at df[2]
- if(length(presid) && all(!is.na(presid)))
+ if (length(presid) && all(!is.na(presid)))
{
cat("\nPearson residuals:\n")
- if(rdf/M > 5) {
+ if (rdf/M > 5) {
rq <- apply(as.matrix(presid), 2, quantile) # 5 x M
dimnames(rq) <- list(c("Min", "1Q", "Median", "3Q", "Max"),
x at misc$predictors.names)
print(t(rq), digits=digits)
} else
- if(rdf > 0) {
+ if (rdf > 0) {
print(presid, digits=digits)
}
}
- if(!all(is.na(coef3))) {
+ if (!all(is.na(coef3))) {
cat("\nCoefficients:\n")
print(coef3, digits = digits)
}
cat("\nNumber of responses: ", M, "\n")
- if(length(x at misc$predictors.names))
- if(M==1) {
+ if (length(x at misc$predictors.names))
+ if (M==1) {
cat("\nName of response:",
paste(x at misc$predictors.names, collapse=", "), "\n")
} else {
@@ -158,13 +158,13 @@ printsummary.vlm <- function(x, digits=NULL, quote=TRUE, prefix="")
cat(uuu, fill=TRUE, sep=", ")
}
- if(!is.null(x at rss))
+ if (!is.null(x at rss))
cat("\nResidual Sum of Squares:", format(round(x at rss, digits)),
"on", round(rdf, digits), "degrees of freedom\n")
- if(length(correl)) {
+ if (length(correl)) {
ncol_X_vlm <- dim(correl)[2]
- if(ncol_X_vlm > 1) {
+ if (ncol_X_vlm > 1) {
cat("\nCorrelation of Coefficients:\n")
ll <- lower.tri(correl)
correl[ll] <- format(round(correl[ll], digits))
diff --git a/R/uqo.R b/R/uqo.R
index 6c6d2aa..5180f61 100644
--- a/R/uqo.R
+++ b/R/uqo.R
@@ -1,5 +1,5 @@
# These functions are
-# Copyright (C) 1998-2009 T.W. Yee, University of Auckland. All rights reserved.
+# Copyright (C) 1998-2010 T.W. Yee, University of Auckland. All rights reserved.
@@ -7,7 +7,7 @@
uqo.control = function(Rank=1,
- Bestof = if(length(lvstart) && !jitter.sitescores) 1 else 10,
+ Bestof = if (length(lvstart) && !jitter.sitescores) 1 else 10,
CA1 = FALSE,
Crow1positive = TRUE,
epsilon = 1.0e-07,
@@ -32,40 +32,40 @@ uqo.control = function(Rank=1,
{
Kinit = 0.001
- if(!is.Numeric(MUXfactor, posit=TRUE))
+ if (!is.Numeric(MUXfactor, posit=TRUE))
stop("bad input for \"MUXfactor\"")
- if(any(MUXfactor < 1 | MUXfactor > 10))
+ if (any(MUXfactor < 1 | MUXfactor > 10))
stop("MUXfactor values must lie between 1 and 10")
- if(!is.Numeric(isdlv, posit=TRUE)) stop("bad input for \"isdlv\"")
- if(any(isdlv < 0.2 | isdlv > 10))
+ if (!is.Numeric(isdlv, posit=TRUE)) stop("bad input for \"isdlv\"")
+ if (any(isdlv < 0.2 | isdlv > 10))
stop("isdlv values must lie between 0.2 and 10")
- if(length(isdlv) > 1 && any(diff(isdlv) > 0))
+ if (length(isdlv) > 1 && any(diff(isdlv) > 0))
stop("successive isdlv values must not increase")
- if(!is.Numeric(Rank, allow=1, integ=TRUE, posit=TRUE))
+ if (!is.Numeric(Rank, allow=1, integ=TRUE, posit=TRUE))
stop("Bad input for \"Rank\"")
- if(!is.Numeric(Bestof, allow=1, integ=TRUE, posit=TRUE))
+ if (!is.Numeric(Bestof, allow=1, integ=TRUE, posit=TRUE))
stop("Bad input for \"Bestof\"")
- if(!is.Numeric(Etamat.colmax, posit=TRUE, allow=1) || Etamat.colmax < Rank)
+ if (!is.Numeric(Etamat.colmax, posit=TRUE, allow=1) || Etamat.colmax < Rank)
stop("bad input for \"Etamat.colmax\"")
- if(!is.Numeric(maxitl, allow=1, integ=TRUE, posit=TRUE))
+ if (!is.Numeric(maxitl, allow=1, integ=TRUE, posit=TRUE))
stop("Bad input for \"maxitl\"")
- if(!is.Numeric(Maxit.optim, integ=TRUE, posit=TRUE, allow=1))
+ if (!is.Numeric(Maxit.optim, integ=TRUE, posit=TRUE, allow=1))
stop("Bad input for \"Maxit.optim\"")
- if(!is.Numeric(optim.maxit, allow=1, integ=TRUE, posit=TRUE))
+ if (!is.Numeric(optim.maxit, allow=1, integ=TRUE, posit=TRUE))
stop("Bad input for \"optim.maxit\"")
- if(!is.Numeric(nRmax, allow=1, integ=TRUE, posit=TRUE))
+ if (!is.Numeric(nRmax, allow=1, integ=TRUE, posit=TRUE))
stop("Bad input for \"nRmax\"")
- if(!is.Numeric(Hstep, allow=1, posit=TRUE))
+ if (!is.Numeric(Hstep, allow=1, posit=TRUE))
stop("Bad input for \"Hstep\"")
- if(!is.Numeric(epsilon, allow=1, posit=TRUE))
+ if (!is.Numeric(epsilon, allow=1, posit=TRUE))
stop("Bad input for \"epsilon\"")
- if(!is.Numeric(SmallNo, allow=1, posit=TRUE))
+ if (!is.Numeric(SmallNo, allow=1, posit=TRUE))
stop("Bad input for \"SmallNo\"")
- if((SmallNo < .Machine$double.eps) || (SmallNo > .0001))
+ if ((SmallNo < .Machine$double.eps) || (SmallNo > .0001))
stop("SmallNo is out of range")
- if(Use.Init.Poisson.QO && CA1)
+ if (Use.Init.Poisson.QO && CA1)
stop("cannot have both Use.Init.Poisson.QO=TRUE and CA1=TRUE")
ans = list(
@@ -122,7 +122,7 @@ uqo <- function(formula,
ocall <- match.call()
mt <- terms(formula, data = data)
- if(missing(data))
+ if (missing(data))
data <- environment(formula)
mf <- match.call(expand=FALSE)
@@ -132,7 +132,7 @@ uqo <- function(formula,
mf$drop.unused.levels <- TRUE
mf[[1]] <- as.name("model.frame")
mf <- eval(mf, parent.frame())
- if(method == "model.frame")
+ if (method == "model.frame")
return(mf)
na.act <- attr(mf, "na.action")
@@ -148,36 +148,36 @@ uqo <- function(formula,
x <- model.matrix(mt, mf, contrasts)
attr(x, "assign") = attrassigndefault(x, mt)
offset <- model.offset(mf)
- if(is.null(offset))
+ if (is.null(offset))
offset <- 0 # yyy ???
w <- model.weights(mf)
- if(!length(w))
+ if (!length(w))
w <- rep(1, nrow(mf))
- else if(ncol(as.matrix(w))==1 && any(w < 0))
+ else if (ncol(as.matrix(w))==1 && any(w < 0))
stop("negative weights not allowed")
- if(is.character(family))
+ if (is.character(family))
family <- get(family)
- if(is.function(family))
+ if (is.function(family))
family <- family()
- if(!inherits(family, "vglmff")) {
+ if (!inherits(family, "vglmff")) {
stop("'family=", family, "' is not a VGAM family function")
}
- if(!is.null(family at first))
+ if (!is.null(family at first))
eval(family at first)
uqo.fitter <- get(method)
- if(ncol(x) != 1 || dimnames(x)[[2]] != "(Intercept)")
+ if (ncol(x) != 1 || dimnames(x)[[2]] != "(Intercept)")
stop("uqo()'s formula must have ~ 1 on the RHS")
- if(control$FastAlgorithm &&
+ if (control$FastAlgorithm &&
length(as.list(family at deviance)) <= 1)
stop("The fast algorithm requires the family ",
"function to have a deviance slot")
deviance.Bestof = rep(as.numeric(NA), len=control$Bestof)
for(tries in 1:control$Bestof) {
- if(control$trace && (control$Bestof>1))
+ if (control$trace && (control$Bestof>1))
cat(paste("\n========================= Fitting model", tries,
"=========================\n"))
it <- uqo.fitter(x=x, y=y, w=w, offset=offset,
@@ -187,7 +187,7 @@ uqo <- function(formula,
qr.arg = qr.arg, Terms=mt, function.name=function.name,
ca1 = control$CA1 && tries==1, ...)
deviance.Bestof[tries] = it$crit.list$deviance
- if(tries==1||min(deviance.Bestof[1:(tries-1)]) > deviance.Bestof[tries])
+ if (tries==1||min(deviance.Bestof[1:(tries-1)]) > deviance.Bestof[tries])
fit = it
}
fit$misc$deviance.Bestof = deviance.Bestof
@@ -207,26 +207,26 @@ uqo <- function(formula,
"fitted.values"= as.matrix(fit$fitted.values),
"iter" = fit$iter,
"misc" = fit$misc,
- "model" = if(model) mf else data.frame(),
- "na.action" = if(length(na.act)) list(na.act) else list(),
+ "model" = if (model) mf else data.frame(),
+ "na.action" = if (length(na.act)) list(na.act) else list(),
"predictors" = as.matrix(fit$predictors))
answer at control$min.criterion = TRUE # Needed for calibrate; 21/1/05
- if(length(fit$weights))
+ if (length(fit$weights))
slot(answer, "weights") = as.matrix(fit$weights)
- if(x.arg)
+ if (x.arg)
slot(answer, "x") = x
- if(y.arg)
+ if (y.arg)
slot(answer, "y") = as.matrix(fit$y)
- slot(answer, "extra") = if(length(fit$extra)) {
- if(is.list(fit$extra)) fit$extra else {
+ 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
- if(length(fit$prior.weights))
+ if (length(fit$prior.weights))
slot(answer, "prior.weights") = fit$prior.weights
answer
@@ -239,22 +239,22 @@ calluqof = function(sitescores, etamat, ymat, wvec, modelno, nice31, xmat,
control = Control
Rank = control$Rank
itol = othint[14]
- inited = if(is.R()) {
+ inited = if (is.R()) {
as.numeric(existsinVGAMenv("etamat", prefix=".VGAM.UQO."))
} else 0
othint[5] = inited # Replacement
- usethiseta = if(inited==1)
+ usethiseta = if (inited==1)
getfromVGAMenv("etamat", prefix = ".VGAM.UQO.") else t(etamat)
usethisbeta = double(othint[13])
pstar = othint[3]
- nstar = if(nice31) ifelse(modelno==3 || modelno==5,n*2,n) else n*M
+ nstar = if (nice31) ifelse(modelno==3 || modelno==5,n*2,n) else n*M
NOS = ifelse(modelno == 3 || modelno==5, M/2, M)
sitescores = matrix(sitescores, ncol=Rank)
sitescores = scale(sitescores, center = TRUE, scale = FALSE)
- if(itol) {
+ if (itol) {
numat = matrix(sitescores, ncol=Rank)
- if(Rank > 1) {
+ if (Rank > 1) {
evnu = eigen(var(numat))
numat = numat %*% evnu$vector
}
@@ -263,23 +263,23 @@ calluqof = function(sitescores, etamat, ymat, wvec, modelno, nice31, xmat,
sdnumat = sd(numat)
for(lookat in 1:Rank)
- if(sdnumat[lookat]>control$MUXfactor[lookat]*control$isdlv[lookat]){
+ if (sdnumat[lookat]>control$MUXfactor[lookat]*control$isdlv[lookat]){
muxer = control$isdlv[lookat] * control$MUXfactor[lookat] /
sdnumat[lookat]
numat[,lookat] = numat[,lookat] * muxer
- if(control$trace) {
+ if (control$trace) {
}
}
} else {
numat = matrix(sitescores, ncol=Rank)
evnu = eigen(var(numat))
- temp7 = if(Rank > 1) evnu$vector %*% diag(evnu$value^(-0.5)) else
+ temp7 = if (Rank > 1) evnu$vector %*% diag(evnu$value^(-0.5)) else
evnu$vector %*% evnu$value^(-0.5)
numat = numat %*% temp7
}
ans1 <-
- dotFortran(name = if(nice31) "cqo1f" else "cqo2f",
+ dotFortran(name = if (nice31) "cqo1f" else "cqo2f",
numat=as.double(numat), as.double(ymat),
as.double(xmat),
as.double(wvec), etamat=as.double(usethiseta),
@@ -295,9 +295,9 @@ calluqof = function(sitescores, etamat, ymat, wvec, modelno, nice31, xmat,
twk=double(if(nice31) nstar*3 else M*n*2), wkmm=double(M*(M+pstar)),
othdbl=as.double(othdbl))
- if(ans1$errcode == 0) {
+ if (ans1$errcode == 0) {
assign2VGAMenv(c("etamat","numat"), ans1, prefix=".VGAM.UQO.")
- if(alldump) {
+ if (alldump) {
ans1$fv = matrix(ans1$fv,n,M,byrow=TRUE,dimnames=dimnames(ymat))
assign2VGAMenv(c("beta","fv"), ans1, prefix=".VGAM.UQO.")
assign2VGAMenv(c("z","U"), ans1, prefix=".VGAM.UQO.")
@@ -314,40 +314,40 @@ callduqof = function(sitescores, etamat, ymat, wvec, modelno, nice31, xmat,
n, M, maxMr5, othint, othdbl, bnumat, Hstep, alldump) {
control = Control
itol = othint[14]
- inited = if(is.R()) {
- if(exists(".VGAM.UQO.etamat", envir = VGAMenv)) 1 else 0
+ inited = if (is.R()) {
+ if (exists(".VGAM.UQO.etamat", envir = VGAMenv)) 1 else 0
} else 0 # 0 means fortran initializes the etamat
othint[5] = inited # Replacement
- usethiseta = if(inited==1)
+ usethiseta = if (inited==1)
getfromVGAMenv("etamat", prefix = ".VGAM.UQO.") else t(etamat)
usethisbeta = double(othint[13])
pstar = othint[3]
- nstar = if(nice31) ifelse(modelno==3 || modelno==5,n*2,n) else n*M
+ nstar = if (nice31) ifelse(modelno==3 || modelno==5,n*2,n) else n*M
NOS = ifelse(modelno == 3 || modelno==5, M/2, M)
Rank = othint[1]
sitescores = matrix(sitescores, ncol=Rank)
sitescores = scale(sitescores, center = TRUE, scale = FALSE)
- if(itol) {
+ if (itol) {
numat = matrix(sitescores, ncol=Rank)
- if(Rank > 1) {
+ if (Rank > 1) {
evnu = eigen(var(numat))
numat = numat %*% evnu$vector
}
sdnumat = sd(numat)
for(lookat in 1:Rank)
- if(sdnumat[lookat]>control$MUXfactor[lookat]*control$isdlv[lookat]){
+ if (sdnumat[lookat]>control$MUXfactor[lookat]*control$isdlv[lookat]){
muxer = control$isdlv[lookat] * control$MUXfactor[lookat] /
sdnumat[lookat]
numat[,lookat] = numat[,lookat] * muxer
- if(control$trace) {
+ if (control$trace) {
}
}
} else {
numat = matrix(sitescores, ncol=Rank)
evnu = eigen(var(numat))
- temp7 = if(Rank > 1) evnu$vector %*% diag(evnu$value^(-0.5)) else
+ temp7 = if (Rank > 1) evnu$vector %*% diag(evnu$value^(-0.5)) else
evnu$vector %*% evnu$value^(-0.5)
numat = numat %*% temp7
}
@@ -373,7 +373,7 @@ callduqof = function(sitescores, etamat, ymat, wvec, modelno, nice31, xmat,
deriv=double(n*Rank), hstep=as.double(Hstep),
betasave=usethisbeta)
- if(ans1$errcode == 0) {
+ if (ans1$errcode == 0) {
assign2VGAMenv(c("etamat"), ans1, prefix=".VGAM.UQO.")
} else {
cat("warning in callduqof: error code =", ans1$errcode, "\n")
@@ -391,7 +391,7 @@ uqo.fit <- function(x, y, w=rep(1, len=nrow(x)),
qr.arg=FALSE, constraints=NULL, extra=NULL,
Terms=Terms, function.name="uqo", ca1=TRUE, ...)
{
- if(!all(offset == 0)) stop("cqo.fit() cannot handle offsets")
+ if (!all(offset == 0)) stop("cqo.fit() cannot handle offsets")
nonparametric <- FALSE
epsilon <- control$epsilon
optim.maxit <- control$optim.maxit
@@ -416,36 +416,36 @@ uqo.fit <- function(x, y, w=rep(1, len=nrow(x)),
Rank <- control$Rank
rrcontrol <- control #
- if(length(family at initialize))
+ if (length(family at initialize))
eval(family at initialize) # Initialize mu and M (and optionally w)
n <- n.save
eval(rrr.init.expression)
- if(length(etastart)) {
+ if (length(etastart)) {
eta <- etastart
- mu <- if(length(mustart)) mustart else family at inverse(eta, extra)
+ mu <- if (length(mustart)) mustart else family at inverse(eta, extra)
} else {
- if(length(mustart))
+ if (length(mustart))
mu <- mustart
eta <- family at link(mu, extra)
}
- M <- if(is.matrix(eta)) ncol(eta) else 1
+ M <- if (is.matrix(eta)) ncol(eta) else 1
- if(is.character(rrcontrol$Dzero)) {
+ if (is.character(rrcontrol$Dzero)) {
index = match(rrcontrol$Dzero, dimnames(as.matrix(y))[[2]])
- if(any(is.na(index)))
+ if (any(is.na(index)))
stop("Dzero argument didn't fully match y-names")
- if(length(index) == M)
+ if (length(index) == M)
stop("all linear predictors are linear in the latent variable(s)")
rrcontrol$Dzero = control$Dzero = index
}
- if(length(family at constraints))
+ if (length(family at constraints))
eval(family at constraints)
@@ -460,10 +460,10 @@ uqo.fit <- function(x, y, w=rep(1, len=nrow(x)),
- sitescores <- if(length(rrcontrol$lvstart)) {
+ sitescores <- if (length(rrcontrol$lvstart)) {
matrix(rrcontrol$lvstart, n, Rank)
} else {
- if(rrcontrol$Use.Init.Poisson) {
+ if (rrcontrol$Use.Init.Poisson) {
.Init.Poisson.QO(ymat=as.matrix(y),
X1=x, X2=NULL,
Rank=rrcontrol$Rank, trace=rrcontrol$trace,
@@ -473,8 +473,8 @@ uqo.fit <- function(x, y, w=rep(1, len=nrow(x)),
constwt= any(family at vfamily[1] ==
c("negbinomial","gamma2","gaussianff")),
takelog= any(family at vfamily[1] != c("gaussianff")))
- } else if(ca1) {
- if(Rank == 1) .VGAM.UQO.CA(y)[,1:Rank] else {
+ } else if (ca1) {
+ if (Rank == 1) .VGAM.UQO.CA(y)[,1:Rank] else {
temp = .VGAM.UQO.CA(y)[,1:Rank]
temp %*% solve(chol(var(temp)))
}
@@ -482,7 +482,7 @@ uqo.fit <- function(x, y, w=rep(1, len=nrow(x)),
matrix((runif(n*Rank)-0.5)*rrcontrol$SD.sitescores,n,Rank)
}
}
- if(rrcontrol$jitter.sitescores)
+ if (rrcontrol$jitter.sitescores)
sitescores <- jitteruqo(sitescores)
@@ -496,34 +496,34 @@ uqo.fit <- function(x, y, w=rep(1, len=nrow(x)),
"negbinomial"=0,
"gamma2"=5,
0) # stop("can't fit this model using fast algorithm")
- if(!modelno) stop("the family function does not work with uqo()")
- if(modelno == 1) modelno = get("modelno", envir = VGAMenv)
+ if (!modelno) stop("the family function does not work with uqo()")
+ if (modelno == 1) modelno = get("modelno", envir = VGAMenv)
rmfromVGAMenv(c("etamat", "beta"), prefix=".VGAM.UQO.")
- cqofastok = if(is.R()) (exists("CQO.FastAlgorithm", envir = VGAMenv) &&
+ cqofastok = if (is.R()) (exists("CQO.FastAlgorithm", envir = VGAMenv) &&
get("CQO.FastAlgorithm", envir = VGAMenv)) else
(exists("CQO.FastAlgorithm", inherits=TRUE) && CQO.FastAlgorithm)
- if(!cqofastok)
+ if (!cqofastok)
stop("can't fit this model using fast algorithm")
nice31 = (!control$EqualTol || control$ITolerances) && control$Quadratic &&
all(trivial.constraints(Blist))
- X_vlm_1save <- if(nice31) {
+ X_vlm_1save <- if (nice31) {
NULL
} else {
lm2vlm.model.matrix(x, Blist, xij=control$xij)
}
NOS = ifelse(modelno==3 || modelno==5, M/2, M)
- p1star = if(nice31) p1*ifelse(modelno==3 || modelno==5,2,1) else ncol(X_vlm_1save)
- p2star = if(nice31)
+ p1star = if (nice31) p1*ifelse(modelno==3 || modelno==5,2,1) else ncol(X_vlm_1save)
+ 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))
pstar = p1star + p2star
- nstar = if(nice31) ifelse(modelno==3 || modelno==5,n*2,n) else n*M
+ nstar = if (nice31) ifelse(modelno==3 || modelno==5,n*2,n) else n*M
maxMr = max(M, Rank)
maxMr5 = maxMr*(maxMr+1)/2
lenbeta = pstar * ifelse(nice31, NOS, 1)
@@ -536,7 +536,7 @@ uqo.fit <- function(x, y, w=rep(1, len=nrow(x)),
.Machine$double.eps,
kinit=rep(control$Kinit, len=NOS),
shapeinit=rep(control$shapeinit, len=NOS))
- bnumat = if(nice31) matrix(0,nstar,pstar) else
+ bnumat = if (nice31) matrix(0,nstar,pstar) else
cbind(matrix(0,nstar,p2star), X_vlm_1save)
rmfromVGAMenv(c("etamat", "z", "U", "beta", "deviance", "fv",
@@ -544,11 +544,11 @@ uqo.fit <- function(x, y, w=rep(1, len=nrow(x)),
for(iter in 1:optim.maxit) {
- if(control$trace)
+ if (control$trace)
cat("\nIteration", iter, "\n")
conjgrad <- optim(par=sitescores, fn=calluqof,
- gr=if(control$GradientFunction) callduqof else NULL,
- method=if(n*Rank>control$nRmax) "CG" else "BFGS",
+ gr = if (control$GradientFunction) callduqof else NULL,
+ method = if (n*Rank>control$nRmax) "CG" else "BFGS",
control=list(fnscale=1, trace=as.integer(control$trace),
maxit=control$Maxit.optim),
etamat=eta, ymat=y, wvec=w, modelno=modelno,
@@ -561,13 +561,13 @@ uqo.fit <- function(x, y, w=rep(1, len=nrow(x)),
dim(sitescores) = c(n, Rank)
sitescores = scale(sitescores, center = TRUE, scale = FALSE)
sitescores = crow1C(sitescores, rrcontrol$Crow1positive)
- dimnames(sitescores) = list(dimnames(y)[[1]], if(Rank==1) "lv" else
+ dimnames(sitescores) = list(dimnames(y)[[1]], if (Rank==1) "lv" else
paste("lv", 1:Rank, sep=""))
- if(converged <- (conjgrad$convergence == 0)) break
+ if (converged <- (conjgrad$convergence == 0)) break
}
- if(!converged && optim.maxit>1)
+ if (!converged && optim.maxit>1)
warning("convergence not obtained")
@@ -587,13 +587,13 @@ uqo.fit <- function(x, y, w=rep(1, len=nrow(x)),
dim(wresids) = c(n,M)
- if(!intercept.only)
+ if (!intercept.only)
stop("can only handle intercept.only==TRUE currently")
- if(nice31) {
+ if (nice31) {
coefs = c(t(matrix(coefs, ncol=M))) # Get into right order
coefs = matrix(coefs, nrow=M)
Amat = coefs[,1:Rank,drop=FALSE]
- if(rrcontrol$IToleran) {
+ if (rrcontrol$IToleran) {
B1 = coefs[,-(1:Rank),drop=FALSE]
Dmat = matrix(0, M, Rank*(Rank+1)/2)
Dmat[,1:Rank] = -0.5
@@ -610,9 +610,9 @@ uqo.fit <- function(x, y, w=rep(1, len=nrow(x)),
B1 = coefs[(cptr1+1):length(coefs)]
}
- lv.names = if(Rank==1) "lv" else paste("lv", 1:Rank, sep="")
+ lv.names = if (Rank==1) "lv" else paste("lv", 1:Rank, sep="")
lp.names = predictors.names
- if(!length(lp.names)) lp.names = NULL
+ if (!length(lp.names)) lp.names = NULL
extra$Amat = matrix(Amat, M, Rank, dimnames = list(lp.names, lv.names))
extra$B1 = matrix(B1, ncol=M, dimnames =
list(names.colx1.index, predictors.names))
@@ -627,7 +627,7 @@ uqo.fit <- function(x, y, w=rep(1, len=nrow(x)),
rmfromVGAMenv(c("etamat", "beta", "fv"), prefix=".VGAM.UQO.")
- if(length(family at fini))
+ if (length(family at fini))
eval(family at fini)
misc <- list(function.name = function.name,
@@ -666,7 +666,7 @@ uqo.fit <- function(x, y, w=rep(1, len=nrow(x)),
printuqo <- function(x, ...)
{
- if(!is.null(cl <- x at call)) {
+ if (!is.null(cl <- x at call)) {
cat("Call:\n")
dput(cl)
}
@@ -677,7 +677,7 @@ printuqo <- function(x, ...)
cat(",", ifelse(x at control$EqualToler, "equal-tolerances",
"unequal-tolerances"), "\n")
- if(length(deviance(x)))
+ if (length(deviance(x)))
cat("\nResidual Deviance:", format(deviance(x)), "\n")
invisible(x)
@@ -719,7 +719,7 @@ residualsuqo <- function(object,
type = c("deviance", "pearson", "working", "response"),
matrix.arg= TRUE) {
- if(mode(type) != "character" && mode(type) != "name")
+ if (mode(type) != "character" && mode(type) != "name")
type = as.character(substitute(type))
type = match.arg(type, c("deviance", "pearson", "working", "response"))[1]
@@ -745,7 +745,7 @@ setMethod("fitted.values", "uqo", function(object, ...)
predict.uqo <- function(object, newdata = NULL, ...) {
- if(length(newdata) > 0)
+ if (length(newdata) > 0)
stop("can't handle newdata argument yet")
object at predictors
}
@@ -788,15 +788,15 @@ setMethod("lvplot", "uqo", function(object, ...)
-if(FALSE) {
+if (FALSE) {
scores.uqo <- function (x, type = c("sites", "species"), ...) {
- if(mode(type) != "character" && mode(type) != "name")
+ if (mode(type) != "character" && mode(type) != "name")
type = as.character(substitute(type))
type = match.arg(type, c("sites", "species"))[1]
switch(type,
- sites=if(any(slotNames(x)=="lv")) x at lv else Coef(x)@lv,
- species=if(any(slotNames(x)=="Optimum")) x at Optimum else Coef(x)@Optimum
+ sites = if (any(slotNames(x)=="lv")) x at lv else Coef(x)@lv,
+ species = if (any(slotNames(x)=="Optimum")) x at Optimum else Coef(x)@Optimum
)
}
@@ -813,7 +813,7 @@ setMethod("lv", "uqo", function(object, ...) lv.qrrvglm(object, ...))
-if(!isGeneric("calibrate"))
+if (!isGeneric("calibrate"))
setGeneric("calibrate", function(object, ...) standardGeneric("calibrate"))
setMethod("calibrate", "uqo", function(object, ...)
calibrate.qrrvglm(object, ...))
@@ -837,7 +837,7 @@ printsummary.uqo = function(x, ...) {
cat("\nNumber of responses/species: ", x at NOS, "\n")
- if(length(x at misc$dispersion) == 1)
+ if (length(x at misc$dispersion) == 1)
cat("\nDispersion parameter(s): ", x at misc$dispersion, "\n")
invisible(x)
}
@@ -864,11 +864,11 @@ Tol.uqo = function(object, ...) {
}
Tol.Coef.uqo = function(object, ...) {
- if(length(list(...))) warning("Too late! Ignoring the extra arguments")
+ if (length(list(...))) warning("Too late! Ignoring the extra arguments")
Coef(object, ...)@Tolerance
}
-if(!isGeneric("Tol"))
+if (!isGeneric("Tol"))
setGeneric("Tol", function(object, ...) standardGeneric("Tol"))
setMethod("Tol", "uqo", function(object, ...) Tol.uqo(object, ...))
setMethod("Tol", "Coef.uqo", function(object, ...) Tol.Coef.uqo(object, ...))
diff --git a/R/vgam.R b/R/vgam.R
index 92628db..bb057fd 100644
--- a/R/vgam.R
+++ b/R/vgam.R
@@ -1,5 +1,5 @@
# These functions are
-# Copyright (C) 1998-2009 T.W. Yee, University of Auckland. All rights reserved.
+# Copyright (C) 1998-2010 T.W. Yee, University of Auckland. All rights reserved.
@@ -29,10 +29,10 @@ vgam <- function(formula,
ocall <- match.call()
- if(smart)
+ if (smart)
setup.smart("write")
- if(missing(data))
+ if (missing(data))
data <- environment(formula)
mtsave <- terms(formula, "s", data = data)
@@ -55,21 +55,21 @@ vgam <- function(formula,
attr(x, "assign") = attrassigndefault(x, mt)
offset <- model.offset(mf)
- if(is.null(offset))
+ if (is.null(offset))
offset <- 0 # yyy ???
mf2 = mf
- if(!missing(subset)) {
+ if (!missing(subset)) {
mf2$subset <- NULL
mf2 <- eval(mf2, parent.frame()) # mf2 is the full data frame.
spars2 = lapply(mf2, attr, "spar")
dfs2 = lapply(mf2, attr, "df")
sx2 = lapply(mf2, attr, "s.xargument")
for(i in 1:length(mf)) {
- if(length(sx2[[i]])) {
+ if (length(sx2[[i]])) {
attr(mf[[i]], "spar") = spars2[[i]]
attr(mf[[i]], "dfs2") = dfs2[[i]]
attr(mf[[i]], "s.xargument") = sx2[[i]]
@@ -81,9 +81,9 @@ vgam <- function(formula,
w <- model.weights(mf)
- if(!length(w))
+ if (!length(w))
w <- rep(1, nrow(mf))
- else if(ncol(as.matrix(w))==1 && any(w < 0))
+ else if (ncol(as.matrix(w))==1 && any(w < 0))
stop("negative weights not allowed")
@@ -93,7 +93,7 @@ vgam <- function(formula,
family <- get(family)
if (is.function(family))
family <- family()
- if(!inherits(family, "vglmff")) {
+ if (!inherits(family, "vglmff")) {
stop("'family=", family, "' is not a VGAM family function")
}
@@ -101,18 +101,18 @@ vgam <- function(formula,
n <- dim(x)[1]
- if(FALSE && is.R()) {
+ if (FALSE && is.R()) {
family at inverse <- eval(family at inverse)
family at link <- eval(family at link)
for(i in names(.min.criterion.VGAM))
- if(length(family[[i]])) family[[i]] <- eval(family[[i]])
+ if (length(family[[i]])) family[[i]] <- eval(family[[i]])
}
- if(length(slot(family, "first")))
+ if (length(slot(family, "first")))
eval(slot(family, "first"))
- if(method != "vgam.fit")
+ if (method != "vgam.fit")
stop("method must be \"model.frame\" or \"vgam.fit\"")
# --------------------------------------------------------------
@@ -123,10 +123,10 @@ vgam <- function(formula,
nonparametric <- length(smoothers$s) > 0
- if(nonparametric) {
+ if (nonparametric) {
ff <- apply(aa$factors[smoothers[["s"]],,drop=FALSE], 2, any)
- smoothers[["s"]] <- if(any(ff)) seq(along=ff)[aa$order==1 & ff] else
+ smoothers[["s"]] <- if (any(ff)) seq(along=ff)[aa$order==1 & ff] else
NULL
smooth.labels <- aa$term.labels[unlist(smoothers)]
@@ -145,13 +145,13 @@ vgam <- function(formula,
function.name=function.name, ...)
- if(is.Numeric(fit$nl.df) && any(fit$nl.df < 0)) {
+ if (is.Numeric(fit$nl.df) && any(fit$nl.df < 0)) {
fit$nl.df[fit$nl.df < 0] = 0
}
# --------------------------------------------------------------
- if(!is.null(fit[["smooth.frame"]])) {
+ if (!is.null(fit[["smooth.frame"]])) {
fit <- fit[-1] # Strip off smooth.frame
} else {
}
@@ -159,21 +159,21 @@ vgam <- function(formula,
fit$smooth <- NULL # Not needed
fit$call <- ocall
- if(model)
+ if (model)
fit$model <- mf
- if(!x.arg)
+ if (!x.arg)
fit$x <- NULL
- if(!y.arg)
+ if (!y.arg)
fit$y <- NULL
- if(nonparametric)
+ if (nonparametric)
fit$misc$smooth.labels <- smooth.labels
fit$misc$dataname <- dataname
- if(smart)
+ if (smart)
fit$smart.prediction <- get.smart.prediction()
@@ -188,7 +188,7 @@ vgam <- function(formula,
"dispersion" = 1,
"family" = fit$family,
"misc" = fit$misc,
- "model" = if(model) mf else data.frame(),
+ "model" = if (model) mf else data.frame(),
"R" = fit$R,
"rank" = fit$rank,
"residuals" = as.matrix(fit$residuals),
@@ -196,34 +196,34 @@ vgam <- function(formula,
"smart.prediction" = as.list(fit$smart.prediction),
"terms" = list(terms=fit$terms))
- if(!smart) answer at smart.prediction <- list(smart.arg=FALSE)
+ if (!smart) answer at smart.prediction <- list(smart.arg=FALSE)
- if(qr.arg) {
+ if (qr.arg) {
class(fit$qr) = "list"
slot(answer, "qr") = fit$qr
}
- if(length(attr(x, "contrasts")))
+ if (length(attr(x, "contrasts")))
slot(answer, "contrasts") = attr(x, "contrasts")
- if(length(fit$fitted.values))
+ 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")))
+ slot(answer, "na.action") = if (length(aaa <- attr(mf, "na.action")))
list(aaa) else list()
- if(length(offset))
+ if (length(offset))
slot(answer, "offset") = as.matrix(offset)
- if(length(fit$weights))
+ if (length(fit$weights))
slot(answer, "weights") = as.matrix(fit$weights)
- if(x.arg)
+ if (x.arg)
slot(answer, "x") = x # The 'small' design matrix
- if(length(xlev))
+ if (length(xlev))
slot(answer, "xlevels") = xlev
- if(y.arg)
+ if (y.arg)
slot(answer, "y") = as.matrix(fit$y)
answer at misc$formula = formula
slot(answer, "control") = fit$control
- if(length(fit$extra)) {
+ if (length(fit$extra)) {
slot(answer, "extra") = fit$extra
}
slot(answer, "iter") = fit$iter
@@ -233,18 +233,18 @@ vgam <- function(formula,
dimnames(fit$predictors) = list(dimnames(fit$predictors)[[1]],
fit$misc$predictors.names)
slot(answer, "predictors") = fit$predictors
- if(length(fit$prior.weights))
+ if (length(fit$prior.weights))
slot(answer, "prior.weights") = fit$prior.weights
- if(nonparametric) {
+ if (nonparametric) {
slot(answer, "Bspline") = fit$Bspline
slot(answer, "nl.chisq") = fit$nl.chisq
- if(is.Numeric(fit$nl.df))
+ if (is.Numeric(fit$nl.df))
slot(answer, "nl.df") = fit$nl.df
slot(answer, "spar") = fit$spar
slot(answer, "s.xargument") = fit$s.xargument
- if(length(fit$var)) {
+ if (length(fit$var)) {
slot(answer, "var") = fit$var
}
@@ -254,7 +254,7 @@ vgam <- function(formula,
}
- if(length(fit$effects))
+ if (length(fit$effects))
slot(answer, "effects") = fit$effects
@@ -265,8 +265,7 @@ attr(vgam, "smart") <- TRUE
-care.exp <- function(x, thresh = -log(.Machine$double.eps))
-{
+care.exp <- function(x, thresh = -log(.Machine$double.eps)) {
x[x > thresh] <- thresh
x[x < (-thresh)] <- -thresh
exp(x)
diff --git a/R/vgam.control.q b/R/vgam.control.q
index a4efd46..3282ef5 100644
--- a/R/vgam.control.q
+++ b/R/vgam.control.q
@@ -1,5 +1,5 @@
# These functions are
-# Copyright (C) 1998-2009 T.W. Yee, University of Auckland. All rights reserved.
+# Copyright (C) 1998-2010 T.W. Yee, University of Auckland. All rights reserved.
@@ -23,38 +23,38 @@ vgam.control <- function(all.knots=FALSE,
- if(mode(criterion) != "character" && mode(criterion) != "name")
+ if (mode(criterion) != "character" && mode(criterion) != "name")
criterion <- as.character(substitute(criterion))
criterion <- pmatch(criterion[1], names(.min.criterion.VGAM), nomatch=1)
criterion <- names(.min.criterion.VGAM)[criterion]
- if(!is.logical(checkwz) || length(checkwz) != 1)
+ if (!is.logical(checkwz) || length(checkwz) != 1)
stop("bad input for 'checkwz'")
- if(!is.Numeric(wzepsilon, allow=1, positive=TRUE))
+ if (!is.Numeric(wzepsilon, allow=1, positive=TRUE))
stop("bad input for 'wzepsilon'")
- if(length(all.knots) > 1)
+ if (length(all.knots) > 1)
warning("all.knots should be of length 1; using first value only")
- if(!is.Numeric(bf.epsilon, allow=1, posit=TRUE)) {
+ if (!is.Numeric(bf.epsilon, allow=1, posit=TRUE)) {
warning("bad input for 'bf.epsilon'; using 0.00001 instead")
bf.epsilon <- 0.00001
}
- if(!is.Numeric(bf.maxit, allow=1, posit=TRUE, integ=TRUE)) {
+ if (!is.Numeric(bf.maxit, allow=1, posit=TRUE, integ=TRUE)) {
warning("bad input for 'bf.maxit'; using 20 instead")
bf.maxit <- 20
}
- if(!is.Numeric(epsilon, allow=1, posit=TRUE)) {
+ if (!is.Numeric(epsilon, allow=1, posit=TRUE)) {
warning("bad input for 'epsilon'; using 0.0001 instead")
epsilon <- 0.0001
}
- if(!is.Numeric(maxit, allow=1, posit=TRUE, integ=TRUE)) {
+ if (!is.Numeric(maxit, allow=1, posit=TRUE, integ=TRUE)) {
warning("bad input for 'maxit'; using 20 instead")
maxit <- 20
}
convergence <- expression({
switch(criterion,
- coefficients=if(iter==1) iter<maxit else (iter<maxit &&
+ coefficients = if (iter == 1) iter < maxit else (iter < maxit &&
max(abs(new.coeffs - old.coeffs)/(abs(old.coeffs)+epsilon)) > epsilon),
abs(old.crit-new.crit)/(abs(old.crit)+epsilon) > epsilon && iter<maxit)
})
@@ -83,10 +83,10 @@ vgam.nlchisq <- function(qr, resid, wz, s, deriv, U, smooth.labels,
attr(qr, "class") = "qr"
class(qr) <- "qr"
- if(!is.matrix(s)) s <- as.matrix(s)
- if(!is.matrix(wz)) wz <- as.matrix(wz)
- if(!is.matrix(deriv)) deriv <- as.matrix(deriv)
- if(!is.matrix(resid)) resid <- as.matrix(resid)
+ if (!is.matrix(s)) s <- as.matrix(s)
+ if (!is.matrix(wz)) wz <- as.matrix(wz)
+ if (!is.matrix(deriv)) deriv <- as.matrix(deriv)
+ if (!is.matrix(resid)) resid <- as.matrix(resid)
trivc <- trivial.constraints(constraints)
diff --git a/R/vgam.fit.q b/R/vgam.fit.q
index 2448cb9..df32fb0 100644
--- a/R/vgam.fit.q
+++ b/R/vgam.fit.q
@@ -1,5 +1,5 @@
# These functions are
-# Copyright (C) 1998-2009 T.W. Yee, University of Auckland. All rights reserved.
+# Copyright (C) 1998-2010 T.W. Yee, University of Auckland. All rights reserved.
@@ -31,17 +31,17 @@ vgam.fit <- function(x, y, w, mf,
# --------------------------------------------------------------
new.s.call <- expression({
- if(c.list$one.more) {
+ if (c.list$one.more) {
fv <- c.list$fit
new.coeffs <- c.list$coeff
- if(length(family at middle))
+ if (length(family at middle))
eval(family at middle)
eta <- fv + offset
mu <- family at inverse(eta, extra)
- if(length(family at middle2))
+ if (length(family at middle2))
eval(family at middle2)
old.crit <- new.crit
@@ -49,7 +49,7 @@ vgam.fit <- function(x, y, w, mf,
new.crit <- switch(criterion,
coefficients=new.coeffs,
tfun(mu=mu, y=y, w=w, res=FALSE, eta=eta, extra))
- if(trace) {
+ if (trace) {
cat("VGAM ", bf, " loop ", iter, ": ", criterion, "= ")
uuuu = switch(criterion, coefficients=
@@ -66,12 +66,12 @@ vgam.fit <- function(x, y, w, mf,
flush.console()
- if(!is.finite(one.more) || !is.logical(one.more)) one.more = FALSE
- if(one.more) {
+ if (!is.finite(one.more) || !is.logical(one.more)) one.more = FALSE
+ if (one.more) {
iter <- iter + 1
deriv.mu <- eval(family at deriv)
wz <- eval(family at weight)
- if(control$checkwz)
+ if (control$checkwz)
wz = checkwz(wz, M=M, trace=trace, wzeps=control$wzepsilon)
U <- vchol(wz, M=M, n=n, silent=!trace)
@@ -100,23 +100,23 @@ vgam.fit <- function(x, y, w, mf,
y.names <- predictors.names <- NULL # May be overwritten in @initialize
n.save <- n
- if(length(slot(family, "initialize")))
+ if (length(slot(family, "initialize")))
eval(slot(family, "initialize")) # Initialize mu & M (and optionally w)
- if(length(etastart)) {
+ if (length(etastart)) {
eta <- etastart
- mu <- if(length(mustart)) mustart else
+ mu <- if (length(mustart)) mustart else
slot(family, "inverse")(eta, extra)
} else {
- if(length(mustart))
+ if (length(mustart))
mu <- mustart
eta <- slot(family, "link")(mu, extra)
}
- M <- if(is.matrix(eta)) ncol(eta) else 1
+ M <- if (is.matrix(eta)) ncol(eta) else 1
- if(length(family at constraints))
+ if (length(family at constraints))
eval(family at constraints)
Blist <- process.constraints(constraints, x, M, specialCM=specialCM)
@@ -124,7 +124,7 @@ vgam.fit <- function(x, y, w, mf,
dimB <- sum(ncolBlist)
- if(nonparametric) {
+ if (nonparametric) {
@@ -142,8 +142,8 @@ vgam.fit <- function(x, y, w, mf,
qbig <- sum(ncolBlist[smooth.labels]) # Number of component funs
s <- matrix(0, n, qbig)
- dy <- if(is.matrix(y)) dimnames(y)[[1]] else names(y)
- d2 <- if(is.null(predictors.names))
+ dy <- if (is.matrix(y)) dimnames(y)[[1]] else names(y)
+ d2 <- if (is.null(predictors.names))
paste("(Additive predictor ",1:M,")", sep="") else
predictors.names
dimnames(s) <- list(dy, vlabel(smooth.labels,
@@ -160,15 +160,15 @@ vgam.fit <- function(x, y, w, mf,
X_vlm_save <- lm2vlm.model.matrix(x, Blist, xij=control$xij)
- if(length(coefstart)) {
- eta <- if(ncol(X_vlm_save)>1) X_vlm_save %*% coefstart +
+ 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)
+ eta <- if (M > 1) matrix(eta, ncol=M, byrow=TRUE) else c(eta)
mu <- family at inverse(eta, extra)
}
- if(criterion != "coefficients") {
+ if (criterion != "coefficients") {
tfun <- slot(family, criterion) # Needed for R, so have to follow suit
}
@@ -176,11 +176,11 @@ vgam.fit <- function(x, y, w, mf,
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
+ old.crit <- if (minimize.criterion) 10*new.crit+10 else -10*new.crit-10
deriv.mu <- eval(family at deriv)
wz <- eval(family at weight)
- if(control$checkwz)
+ if (control$checkwz)
wz = checkwz(wz, M=M, trace=trace, wzeps=control$wzepsilon)
U <- vchol(wz, M=M, n=n, silent=!trace)
@@ -196,7 +196,7 @@ vgam.fit <- function(x, y, w, mf,
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)
+ if (nrow_X_vlm < ncol_X_vlm)
stop(ncol_X_vlm, " parameters but only ", nrow_X_vlm, " observations")
while(c.list$one.more) {
@@ -211,7 +211,7 @@ vgam.fit <- function(x, y, w, mf,
NULL
}
- if(maxit>1 && iter>=maxit)
+ if (maxit>1 && iter>=maxit)
warning("convergence not obtained in ", maxit, " iterations")
@@ -219,7 +219,7 @@ vgam.fit <- function(x, y, w, mf,
xnrow_X_vlm <- dnrow_X_vlm[[2]]
ynrow_X_vlm <- dnrow_X_vlm[[1]]
- if(length(family at fini))
+ if (length(family at fini))
eval(family at fini)
coefs <- tfit$coefficients
@@ -228,9 +228,9 @@ vgam.fit <- function(x, y, w, mf,
names(coefs) <- xnrow_X_vlm
cnames <- xnrow_X_vlm
- if(!is.null(tfit$rank)) {
+ if (!is.null(tfit$rank)) {
rank <- tfit$rank
- if(rank < ncol(x))
+ if (rank < ncol(x))
stop("rank < ncol(x) is bad")
} else rank <- ncol(x)
@@ -246,11 +246,11 @@ vgam.fit <- function(x, y, w, mf,
- if(is.matrix(mu)) {
- if(length(dimnames(mu)[[2]])) {
+ if (is.matrix(mu)) {
+ if (length(dimnames(mu)[[2]])) {
y.names <- dimnames(mu)[[2]]
} else
- if(length(dimnames(y)[[2]])) {
+ if (length(dimnames(y)[[2]])) {
y.names <- dimnames(y)[[2]]
}
dimnames(mu) <- list(yn, y.names)
@@ -273,18 +273,18 @@ vgam.fit <- function(x, y, w, mf,
df.residual <- nrow_X_vlm - rank
- if(!se.fit) {
+ if (!se.fit) {
fit$var <- NULL
}
- if(M==1) {
+ if (M==1) {
wz <- as.vector(wz) # Convert wz into a vector
} # else
- fit$weights <- if(save.weight) wz else NULL
+ fit$weights <- if (save.weight) wz else NULL
- if(M==1) {
+ if (M==1) {
fit$predictors <- as.vector(fit$predictors)
fit$residuals <- as.vector(fit$residuals)
names(fit$residuals) <- names(fit$predictors) <- yn
@@ -313,28 +313,28 @@ vgam.fit <- function(x, y, w, mf,
ynames = dimnames(y)[[2]])
- if(criterion != "coefficients")
+ if (criterion != "coefficients")
fit[[criterion]] <- new.crit
- if(se.fit && length(fit$s.xargument)) {
+ if (se.fit && length(fit$s.xargument)) {
misc$varassign <-
varassign(Blist, names(fit$s.xargument))
}
- if(nonparametric) {
+ if (nonparametric) {
misc$smooth.labels <- smooth.labels
}
crit.list <- list()
- if(criterion != "coefficients")
+ if (criterion != "coefficients")
crit.list[[criterion]] <- fit[[criterion]] <- new.crit
for(ii in names(.min.criterion.VGAM)) {
- if(ii != criterion &&
+ 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)
@@ -345,7 +345,7 @@ vgam.fit <- function(x, y, w, mf,
- if(M==1) {
+ if (M==1) {
fit$predictors <- as.vector(fit$predictors)
fit$residuals <- as.vector(fit$residuals)
names(fit$residuals) <- names(fit$predictors) <- yn
@@ -356,14 +356,14 @@ vgam.fit <- function(x, y, w, mf,
- if(w[1] != 1 || any(w != w[1]))
+ if (w[1] != 1 || any(w != w[1]))
fit$prior.weights <- w
- if(length(family at last))
+ if (length(family at last))
eval(family at last)
- if(!is.null(fit$smooth)) {
+ if (!is.null(fit$smooth)) {
fit$nl.chisq <- vgam.nlchisq(fit$qr, fit$resid, wz=wz,
s=fit$smooth, deriv=deriv.mu, U=U,
smooth.labels, attr(x, "assign"),
@@ -371,7 +371,7 @@ vgam.fit <- function(x, y, w, mf,
}
- if(!qr.arg) {
+ if (!qr.arg) {
fit$qr <- NULL
}
diff --git a/R/vgam.match.q b/R/vgam.match.q
index cb3c6d7..a351282 100644
--- a/R/vgam.match.q
+++ b/R/vgam.match.q
@@ -1,13 +1,13 @@
# These functions are
-# Copyright (C) 1998-2009 T.W. Yee, University of Auckland. All rights reserved.
+# Copyright (C) 1998-2010 T.W. Yee, University of Auckland. All rights reserved.
vgam.match <- function(x, all.knots=FALSE, nk=NULL) {
- if(is.list(x)) {
+ if (is.list(x)) {
nvar <- length(x)
- if(length(nk))
+ if (length(nk))
nk = rep(nk, length=nvar)
temp <- vgam.match(x[[1]], all.knots=all.knots, nk=nk[1])
@@ -19,7 +19,7 @@ vgam.match <- function(x, all.knots=FALSE, nk=NULL) {
knots <- vector("list", nvar)
knots[[1]] <- temp$knots
- if(nvar > 1)
+ if (nvar > 1)
for(i in 2:nvar) {
temp = vgam.match(x[[i]], all.knots=all.knots, nk=nk[i])
o[, i] <- temp$o
@@ -37,14 +37,14 @@ vgam.match <- function(x, all.knots=FALSE, nk=NULL) {
xmin=xmin, xmax=xmax))
}
- if(!is.null(attributes(x)$NAs) || any(is.na(x)))
+ if (!is.null(attributes(x)$NAs) || any(is.na(x)))
stop("cannot smooth on variables with NAs")
sx <- unique(sort(as.vector(x))) # "as.vector()" strips off attributes
o <- match(x, sx) # as.integer(match(x, sx)) # sx[o]==x
nef <- length(sx) # as.integer(length(sx))
- if(nef < 7)
+ if (nef < 7)
stop("smoothing variables must have at least 7 unique values")
xmin <- sx[1] # Don't use rounded value
@@ -52,23 +52,23 @@ vgam.match <- function(x, all.knots=FALSE, nk=NULL) {
xbar <- (sx - xmin) / (xmax - xmin)
noround = TRUE # Improvement 3/8/02
- if(all.knots) {
- if(noround) {
+ if (all.knots) {
+ if (noround) {
knot = valid.vknotl2(c(rep(xbar[1], 3), xbar, rep(xbar[nef], 3)))
} else {
knot <- c(rep(xbar[1], 3), xbar, rep(xbar[nef], 3))
}
- if(length(nk)) warning("overriding nk by all.knots=T")
+ if (length(nk)) warning("overriding nk by all.knots=T")
nk <- length(knot) - 4 # No longer: nef + 2
} else {
chosen = length(nk)
- if(chosen && (nk > nef+2 || nk <= 5))
+ if (chosen && (nk > nef+2 || nk <= 5))
stop("bad value for nk")
- if(!chosen) nk = 0
+ if (!chosen) nk = 0
knot.list <- dotFortran(name="vknotl2", as.double(xbar), as.integer(nef),
knot=double(nef+6), k=as.integer(nk+4),
chosen=as.integer(chosen))
- if(noround) {
+ if (noround) {
knot = valid.vknotl2(knot.list$knot[1:(knot.list$k)])
knot.list$k = length(knot)
} else {
@@ -76,7 +76,7 @@ vgam.match <- function(x, all.knots=FALSE, nk=NULL) {
}
nk <- knot.list$k - 4
}
- if(nk <= 5) stop("not enough distinct knots found")
+ if (nk <= 5) stop("not enough distinct knots found")
return(list(o=o, nef=nef, nknots=nk, knots=knot, xmin=xmin, xmax=xmax))
}
diff --git a/R/vglm.R b/R/vglm.R
index 0ceb6fb..9ba5fdd 100644
--- a/R/vglm.R
+++ b/R/vglm.R
@@ -1,5 +1,5 @@
# These functions are
-# Copyright (C) 1998-2009 T.W. Yee, University of Auckland. All rights reserved.
+# Copyright (C) 1998-2010 T.W. Yee, University of Auckland. All rights reserved.
@@ -24,10 +24,10 @@ vglm <- function(formula,
ocall <- match.call()
- if(smart)
+ if (smart)
setup.smart("write")
- if(missing(data))
+ if (missing(data))
data <- environment(formula)
mf <- match.call(expand.dots = FALSE)
@@ -52,8 +52,8 @@ vglm <- function(formula,
-if(!is.null(form2)) {
- if(!is.null(subset))
+if (!is.null(form2)) {
+ if (!is.null(subset))
stop("argument 'subset' cannot be used when argument 'form2' is used")
retlist = shadowvglm(formula=
form2,
@@ -69,12 +69,12 @@ if(!is.null(form2)) {
Ym2 <- retlist$Ym2
Xm2 <- retlist$Xm2
- if(length(Ym2)) {
- if(nrow(as.matrix(Ym2)) != nrow(as.matrix(y)))
+ if (length(Ym2)) {
+ 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)))
+ if (length(Xm2)) {
+ if (nrow(as.matrix(Xm2)) != nrow(as.matrix(x)))
stop("number of rows of y and Ym2 are unequal")
}
} else {
@@ -83,25 +83,25 @@ if(!is.null(form2)) {
offset <- model.offset(mf)
- if(is.null(offset))
+ if (is.null(offset))
offset <- 0 # yyy ???
w <- model.weights(mf)
- if(!length(w))
+ if (!length(w))
w <- rep(1, nrow(mf))
- else if(ncol(as.matrix(w))==1 && any(w < 0))
+ else if (ncol(as.matrix(w))==1 && any(w < 0))
stop("negative weights not allowed")
- if(is.character(family))
+ if (is.character(family))
family <- get(family)
- if(is.function(family))
+ if (is.function(family))
family <- family()
- if(!inherits(family, "vglmff")) {
+ if (!inherits(family, "vglmff")) {
stop("'family=", family, "' is not a VGAM family function")
}
eval(vcontrol.expression)
- if(length(slot(family, "first")))
+ if (length(slot(family, "first")))
eval(slot(family, "first"))
@@ -120,7 +120,7 @@ if(!is.null(form2)) {
fit$misc$dataname <- dataname
- if(smart) {
+ if (smart) {
fit$smart.prediction <- get.smart.prediction()
wrapup.smart()
}
@@ -138,7 +138,7 @@ if(!is.null(form2)) {
"effects" = fit$effects,
"family" = fit$family,
"misc" = fit$misc,
- "model" = if(model) mf else data.frame(),
+ "model" = if (model) mf else data.frame(),
"R" = fit$R,
"rank" = fit$rank,
"residuals" = as.matrix(fit$residuals),
@@ -146,44 +146,44 @@ if(!is.null(form2)) {
"smart.prediction" = as.list(fit$smart.prediction),
"terms" = list(terms=mt))
- if(!smart) answer at smart.prediction <- list(smart.arg=FALSE)
+ if (!smart) answer at smart.prediction <- list(smart.arg=FALSE)
- if(qr.arg) {
+ if (qr.arg) {
class(fit$qr) = "list"
slot(answer, "qr") = fit$qr
}
- if(length(attr(x, "contrasts")))
+ if (length(attr(x, "contrasts")))
slot(answer, "contrasts") = attr(x, "contrasts")
- if(length(fit$fitted.values))
+ 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")))
+ slot(answer, "na.action") = if (length(aaa <- attr(mf, "na.action")))
list(aaa) else list()
- if(length(offset))
+ if (length(offset))
slot(answer, "offset") = as.matrix(offset)
- if(length(fit$weights))
+ if (length(fit$weights))
slot(answer, "weights") = as.matrix(fit$weights)
- if(x.arg)
+ if (x.arg)
slot(answer, "x") = fit$x # The 'small' (lm) design matrix
- if(x.arg && length(Xm2))
+ if (x.arg && length(Xm2))
slot(answer, "Xm2") = Xm2 # The second (lm) design matrix
- if(y.arg && length(Ym2))
+ if (y.arg && length(Ym2))
slot(answer, "Ym2") = as.matrix(Ym2) # The second response
- if(!is.null(form2))
+ if (!is.null(form2))
slot(answer, "callXm2") = retlist$call
answer at misc$formula = formula
answer at misc$form2 = form2
- if(length(xlev))
+ if (length(xlev))
slot(answer, "xlevels") = xlev
- if(y.arg)
+ 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 {
+ 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)
}
@@ -194,7 +194,7 @@ if(!is.null(form2)) {
dimnames(fit$predictors) = list(dimnames(fit$predictors)[[1]],
fit$misc$predictors.names)
slot(answer, "predictors") = fit$predictors
- if(length(fit$prior.weights))
+ if (length(fit$prior.weights))
slot(answer, "prior.weights") = fit$prior.weights
@@ -226,7 +226,7 @@ shadowvglm <-
ocall <- match.call()
- if(missing(data))
+ if (missing(data))
data <- environment(formula)
mf <- match.call(expand.dots = FALSE)
diff --git a/R/vglm.control.q b/R/vglm.control.q
index 692ec82..b3c72ef 100644
--- a/R/vglm.control.q
+++ b/R/vglm.control.q
@@ -1,5 +1,5 @@
# These functions are
-# Copyright (C) 1998-2009 T.W. Yee, University of Auckland. All rights reserved.
+# Copyright (C) 1998-2010 T.W. Yee, University of Auckland. All rights reserved.
@@ -11,13 +11,13 @@
vlm.control <- function(save.weight=TRUE, tol=1e-7, method="qr",
checkwz=TRUE, wzepsilon = .Machine$double.eps^0.75,
...) {
- if(tol <= 0) {
+ if (tol <= 0) {
warning("tol not positive; using 1e-7 instead")
tol <- 1e-7
}
- if(!is.logical(checkwz) || length(checkwz) != 1)
+ if (!is.logical(checkwz) || length(checkwz) != 1)
stop("bad input for 'checkwz'")
- if(!is.Numeric(wzepsilon, allow=1, positive=TRUE))
+ if (!is.Numeric(wzepsilon, allow=1, positive=TRUE))
stop("bad input for 'wzepsilon'")
list(save.weight=save.weight, tol=tol, method=method,
@@ -41,36 +41,36 @@ vglm.control <- function(checkwz=TRUE,
- if(mode(criterion) != "character" && mode(criterion) != "name")
+ if (mode(criterion) != "character" && mode(criterion) != "name")
criterion <- as.character(substitute(criterion))
criterion <- pmatch(criterion[1], names(.min.criterion.VGAM), nomatch=1)
criterion <- names(.min.criterion.VGAM)[criterion]
- if(!is.logical(checkwz) || length(checkwz) != 1)
+ if (!is.logical(checkwz) || length(checkwz) != 1)
stop("bad input for 'checkwz'")
- if(!is.Numeric(wzepsilon, allow=1, positive=TRUE))
+ if (!is.Numeric(wzepsilon, allow=1, positive=TRUE))
stop("bad input for 'wzepsilon'")
convergence <- expression({
switch(criterion,
- coefficients=if(iter==1) iter<maxit else (iter<maxit &&
+ coefficients = if (iter == 1) iter<maxit else (iter<maxit &&
max(abs(new.crit - old.crit)/(abs(old.crit)+epsilon)) > epsilon),
abs(old.crit-new.crit)/(abs(old.crit)+epsilon) > epsilon && iter<maxit)
})
- if(!is.Numeric(epsilon, allow=1, posit=TRUE)) {
+ if (!is.Numeric(epsilon, allow=1, posit=TRUE)) {
warning("bad input for 'epsilon'; using 0.00001 instead")
epsilon <- 0.00001
}
- if(!is.Numeric(maxit, allow=1, posit=TRUE, integ=TRUE)) {
+ if (!is.Numeric(maxit, allow=1, posit=TRUE, integ=TRUE)) {
warning("bad input for 'maxit'; using 20 instead")
maxit <- 20
}
- if(!is.Numeric(stepsize, allow=1, posit=TRUE)) {
+ if (!is.Numeric(stepsize, allow=1, posit=TRUE)) {
warning("bad input for 'stepsize'; using 1 instead")
stepsize <- 1
}
@@ -86,7 +86,7 @@ vglm.control <- function(checkwz=TRUE,
stepsize=stepsize,
trace=as.logical(trace)[1],
wzepsilon = wzepsilon,
- xij=if(is(xij, "formula")) list(xij) else xij)
+ xij = if (is(xij, "formula")) list(xij) else xij)
}
@@ -100,9 +100,9 @@ vcontrol.expression <- expression({
for(ii in 1:2) {
temp <- paste(if(ii==1) "" else paste(function.name, ".", sep=""),
mylist[i], ".control", sep="")
- tempexists = if(is.R()) exists(temp, envir = VGAMenv) else
+ tempexists = if (is.R()) exists(temp, envir = VGAMenv) else
exists(temp, inherit=TRUE)
- if(tempexists) {
+ if (tempexists) {
temp <- get(temp)
temp <- temp(...)
for(k in names(temp))
@@ -113,10 +113,10 @@ vcontrol.expression <- expression({
orig.criterion = control$criterion
- if(control$criterion != "coefficients") {
+ if (control$criterion != "coefficients") {
try.crit = c(names(.min.criterion.VGAM), "coefficients")
for(i in try.crit) {
- if(any(slotNames(family) == i) &&
+ if (any(slotNames(family) == i) &&
(( is.R() && length(body(slot(family, i)))) ||
((!is.R() && length(slot(family, i)) > 1)))) {
control$criterion <- i
@@ -135,7 +135,7 @@ vcontrol.expression <- expression({
temp <- paste(if(ii==1) "" else paste(function.name, ".", sep=""),
family at vfamily[1],
".", control$criterion, ".control", sep="")
- if(exists(temp, inherit=T)) {
+ if (exists(temp, inherit=T)) {
temp <- get(temp)
temp <- temp(...)
for(k in names(temp))
diff --git a/R/vglm.fit.q b/R/vglm.fit.q
index fa55bc5..fb2b6ed 100644
--- a/R/vglm.fit.q
+++ b/R/vglm.fit.q
@@ -1,5 +1,5 @@
# These functions are
-# Copyright (C) 1998-2009 T.W. Yee, University of Auckland. All rights reserved.
+# Copyright (C) 1998-2010 T.W. Yee, University of Auckland. All rights reserved.
@@ -30,17 +30,17 @@ vglm.fit <- function(x, y, w=rep(1, length(x[, 1])),
n <- dim(x)[1]
new.s.call <- expression({
- if(c.list$one.more) {
+ if (c.list$one.more) {
fv <- c.list$fit
new.coeffs <- c.list$coeff
- if(length(slot(family, "middle")))
+ if (length(slot(family, "middle")))
eval(slot(family, "middle"))
eta <- fv + offset
mu <- slot(family, "inverse")(eta, extra)
- if(length(slot(family, "middle2")))
+ if (length(slot(family, "middle2")))
eval(slot(family, "middle2"))
old.crit <- new.crit
@@ -50,7 +50,7 @@ vglm.fit <- function(x, y, w=rep(1, length(x[, 1])),
tfun(mu=mu, y=y, w=w, res=FALSE, eta=eta, extra))
- if(trace && orig.stepsize==1) {
+ if (trace && orig.stepsize==1) {
cat("VGLM linear loop ", iter, ": ", criterion, "= ")
uuuu =
switch(criterion,
@@ -70,35 +70,35 @@ vglm.fit <- function(x, y, w=rep(1, length(x[, 1])),
(criterion!="coefficients" &&
(if(minimize.criterion) new.crit > old.crit else
new.crit < old.crit)))
- if(!is.logical(take.half.step))
+ if (!is.logical(take.half.step))
take.half.step = TRUE
- if(take.half.step) {
+ if (take.half.step) {
stepsize <- 2 * min(orig.stepsize, 2*stepsize)
new.coeffs.save <- new.coeffs
- if(trace)
+ if (trace)
cat("Taking a modified step")
repeat {
- if(trace) {
+ if (trace) {
cat(".")
flush.console()
}
stepsize <- stepsize / 2
- if(too.small <- stepsize < 0.001)
+ if (too.small <- stepsize < 0.001)
break
new.coeffs <- (1-stepsize)*old.coeffs +
stepsize*new.coeffs.save
- if(length(slot(family, "middle")))
+ if (length(slot(family, "middle")))
eval(slot(family, "middle"))
fv <- X_vlm_save %*% new.coeffs
- if(M > 1)
+ if (M > 1)
fv <- matrix(fv, n, M, byrow=TRUE)
eta <- fv + offset
mu <- slot(family, "inverse")(eta, extra)
- if(length(slot(family, "middle2")))
+ if (length(slot(family, "middle2")))
eval(slot(family, "middle2"))
@@ -107,20 +107,20 @@ vglm.fit <- function(x, y, w=rep(1, length(x[, 1])),
coefficients=new.coeffs,
tfun(mu=mu,y=y,w=w,res=FALSE,eta=eta,extra))
- if((criterion=="coefficients") ||
+ if ((criterion=="coefficients") ||
( minimize.criterion && new.crit < old.crit) ||
(!minimize.criterion && new.crit > old.crit))
break
} # of repeat
- if(trace)
+ if (trace)
cat("\n")
- if(too.small) {
+ if (too.small) {
warning("iterations terminated because ",
"half-step sizes are very small")
one.more <- FALSE
} else {
- if(trace) {
+ if (trace) {
cat("VGLM linear loop ",
iter, ": ", criterion, "= ")
@@ -142,12 +142,12 @@ vglm.fit <- function(x, y, w=rep(1, length(x[, 1])),
}
flush.console()
- if(!is.logical(one.more)) one.more = FALSE
- if(one.more) {
+ 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)
+ if (control$checkwz)
wz = checkwz(wz, M=M, trace=trace, wzeps=control$wzepsilon)
U <- vchol(wz, M=M, n=n, silent=!trace)
@@ -156,7 +156,7 @@ vglm.fit <- function(x, y, w=rep(1, length(x[, 1])),
c.list$z <- z
c.list$U <- U
- if(copy_X_vlm) c.list$X_vlm <- X_vlm_save
+ if (copy_X_vlm) c.list$X_vlm <- X_vlm_save
}
c.list$one.more <- one.more
@@ -180,26 +180,26 @@ vglm.fit <- function(x, y, w=rep(1, length(x[, 1])),
n.save <- n
- if(length(slot(family, "initialize")))
+ if (length(slot(family, "initialize")))
eval(slot(family, "initialize")) # Initialize mu & M (and optionally w)
- if(length(etastart)) {
+ if (length(etastart)) {
eta <- etastart
- mu <- if(length(mustart)) mustart else
+ mu <- if (length(mustart)) mustart else
slot(family, "inverse")(eta, extra)
} else {
- if(length(mustart))
+ if (length(mustart))
mu <- mustart
eta <- slot(family, "link")(mu, extra)
}
- M <- if(is.matrix(eta)) ncol(eta) else 1
+ M <- if (is.matrix(eta)) ncol(eta) else 1
- if(length(slot(family, "constraints")))
+ if (length(slot(family, "constraints")))
eval(slot(family, "constraints"))
@@ -213,15 +213,15 @@ vglm.fit <- function(x, y, w=rep(1, length(x[, 1])),
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 +
+ 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)
+ eta <- if (M > 1) matrix(eta, ncol=M, byrow=TRUE) else c(eta)
mu <- slot(family, "inverse")(eta, extra)
}
- if(criterion != "coefficients") {
+ if (criterion != "coefficients") {
tfun <- slot(family, criterion) # family[[criterion]]
}
@@ -229,11 +229,11 @@ vglm.fit <- function(x, y, w=rep(1, length(x[, 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
+ 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)
+ if (control$checkwz)
wz = checkwz(wz, M=M, trace=trace, wzeps=control$wzepsilon)
U <- vchol(wz, M=M, n=n, silent=!trace)
@@ -243,14 +243,14 @@ vglm.fit <- function(x, y, w=rep(1, length(x[, 1])),
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))
+ X_vlm = if (copy_X_vlm) as.double(X_vlm_save) else double(3))
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)
+ if (nrow_X_vlm < ncol_X_vlm)
stop(ncol_X_vlm, "parameters but only ", nrow_X_vlm, " observations")
@@ -271,7 +271,7 @@ vglm.fit <- function(x, y, w=rep(1, length(x[, 1])),
NULL
}
- if(maxit>1 && iter>=maxit)
+ if (maxit>1 && iter>=maxit)
warning("convergence not obtained in ", maxit, " iterations")
@@ -280,10 +280,10 @@ vglm.fit <- function(x, y, w=rep(1, length(x[, 1])),
xnrow_X_vlm <- dnrow_X_vlm[[2]]
ynrow_X_vlm <- dnrow_X_vlm[[1]]
- if(length(slot(family, "fini")))
+ if (length(slot(family, "fini")))
eval(slot(family, "fini"))
- if(M>1)
+ if (M>1)
tfit$predictors <- matrix(tfit$predictors, n, M)
coefs <- tfit$coefficients
@@ -294,7 +294,7 @@ vglm.fit <- function(x, y, w=rep(1, length(x[, 1])),
rank <- tfit$rank
cnames <- xnrow_X_vlm
- if(check.rank && rank < ncol_X_vlm)
+ if (check.rank && rank < ncol_X_vlm)
stop("vglm only handles full-rank models (currently)")
R <- tfit$qr$qr[1:ncol_X_vlm, 1:ncol_X_vlm, drop=FALSE]
@@ -314,7 +314,7 @@ vglm.fit <- function(x, y, w=rep(1, length(x[, 1])),
residuals <- z - tfit$predictors
- if(M==1) {
+ if (M==1) {
tfit$predictors <- as.vector(tfit$predictors)
residuals <- as.vector(residuals)
names(residuals) <- names(tfit$predictors) <- yn
@@ -323,11 +323,11 @@ vglm.fit <- function(x, y, w=rep(1, length(x[, 1])),
list(yn, predictors.names)
}
- if(is.matrix(mu)) {
- if(length(dimnames(y)[[2]])) {
+ if (is.matrix(mu)) {
+ if (length(dimnames(y)[[2]])) {
y.names <- dimnames(y)[[2]]
}
- if(length(dimnames(mu)[[2]])) {
+ if (length(dimnames(mu)[[2]])) {
y.names <- dimnames(mu)[[2]]
}
dimnames(mu) <- list(yn, y.names)
@@ -350,15 +350,15 @@ vglm.fit <- function(x, y, w=rep(1, length(x[, 1])),
R=R,
terms=Terms) # terms: This used to be done in vglm()
- if(qr.arg) {
+ if (qr.arg) {
fit$qr <- tfit$qr
dimnames(fit$qr$qr) <- dnrow_X_vlm
}
- if(M==1) {
+ if (M==1) {
wz <- as.vector(wz) # Convert wz into a vector
} # else
- fit$weights <- if(save.weight) wz else NULL
+ fit$weights <- if (save.weight) wz else NULL
misc <- list(
@@ -379,11 +379,11 @@ vglm.fit <- function(x, y, w=rep(1, length(x[, 1])),
crit.list <- list()
- if(criterion != "coefficients")
+ if (criterion != "coefficients")
crit.list[[criterion]] <- fit[[criterion]] <- new.crit
for(ii in names(.min.criterion.VGAM)) {
- if(ii != criterion &&
+ 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)
@@ -392,10 +392,10 @@ vglm.fit <- function(x, y, w=rep(1, length(x[, 1])),
- if(w[1] != 1 || any(w != w[1]))
+ if (w[1] != 1 || any(w != w[1]))
fit$prior.weights <- w
- if(length(slot(family, "last")))
+ if (length(slot(family, "last")))
eval(slot(family, "last"))
structure(c(fit, list(predictors=tfit$predictors,
diff --git a/R/vlm.R b/R/vlm.R
index 23905e6..06d9716 100644
--- a/R/vlm.R
+++ b/R/vlm.R
@@ -1,5 +1,5 @@
# These functions are
-# Copyright (C) 1998-2009 T.W. Yee, University of Auckland. All rights reserved.
+# Copyright (C) 1998-2010 T.W. Yee, University of Auckland. All rights reserved.
@@ -21,7 +21,7 @@ vlm <- function(formula,
ocall <- match.call()
- if(smart)
+ if (smart)
setup.smart("write")
mt <- terms(formula, data = data) # attr(m, "terms")
@@ -35,9 +35,9 @@ vlm <- function(formula,
mf$drop.unused.levels <- TRUE
mf[[1]] <- as.name("model.frame")
mf <- eval(mf, parent.frame())
- if(method == "model.frame")
+ if (method == "model.frame")
return(mf)
- if(method != "qr")
+ if (method != "qr")
stop("only method=\"qr\" is implemented")
na.act <- attr(mf, "na.action")
@@ -54,9 +54,9 @@ vlm <- function(formula,
x <- model.matrix(mt, mf, contrasts)
attr(x, "assign") <- attrassigndefault(x, mt) # So as to make it like Splus
offset <- model.offset(mf)
- if(is.null(offset))
+ if (is.null(offset))
offset <- 0 # yyy ???
- if(length(offset) && any(offset!=0))
+ if (length(offset) && any(offset!=0))
stop("offsets are redundant for (vector) linear models")
wz <- model.weights(mf)
@@ -64,24 +64,24 @@ vlm <- function(formula,
M <- ncol(as.matrix(y))
n <- nrow(x)
dy <- dimnames(y)
- dy1 <- if(length(dy[[1]])) dy[[1]] else dimnames(mf)[[1]]
- dy2 <- if(length(dy[[2]])) dy[[2]] else paste("Y", 1:M, sep="")
+ dy1 <- if (length(dy[[1]])) dy[[1]] else dimnames(mf)[[1]]
+ dy2 <- if (length(dy[[2]])) dy[[2]] else paste("Y", 1:M, sep="")
dimnames(y) <- list(dy1, dy2)
predictors.names = dy2
- if(!length(prior.weights)) {
+ if (!length(prior.weights)) {
prior.weights = rep(1, len=n)
names(prior.weights) = dy1
}
- if(any(prior.weights <= 0))
+ if (any(prior.weights <= 0))
stop("only positive weights allowed")
- if(!length(wz)) {
+ if (!length(wz)) {
wz <- matrix(prior.weights, n, M)
identity.wts <- TRUE
} else {
identity.wts <- FALSE
temp = ncol(as.matrix(wz))
- if(temp < M || temp > M*(M+1)/2)
+ if (temp < M || temp > M*(M+1)/2)
stop("input 'w' must have between ", M, " and ", M*(M+1)/2,
" columns")
wz <- prior.weights * wz
@@ -132,7 +132,7 @@ vlm <- function(formula,
- if(smart) {
+ if (smart) {
fit$smart.prediction <- get.smart.prediction()
wrapup.smart()
}
@@ -151,7 +151,7 @@ vlm <- function(formula,
"effects" = fit$effects,
"fitted.values"= as.matrix(fit$fitted.values),
"misc" = fit$misc,
- "model" = if(model) mf else data.frame(),
+ "model" = if (model) mf else data.frame(),
"R" = fit$R,
"rank" = fit$rank,
"residuals" = as.matrix(fit$residuals),
@@ -159,26 +159,26 @@ vlm <- function(formula,
"smart.prediction" = as.list(fit$smart.prediction),
"terms" = list(terms=mt))
- if(!smart) answer at smart.prediction <- list(smart.arg=FALSE)
+ if (!smart) answer at smart.prediction <- list(smart.arg=FALSE)
slot(answer, "prior.weights") = prior.weights
- if(length(attr(x, "contrasts")))
+ if (length(attr(x, "contrasts")))
slot(answer, "contrasts") = attr(x, "contrasts")
- slot(answer, "na.action") = if(length(na.act)) list(na.act) else list()
- if(length(offset))
+ slot(answer, "na.action") = if (length(na.act)) list(na.act) else list()
+ if (length(offset))
slot(answer, "offset") = as.matrix(offset)
- if(qr.arg) {
+ if (qr.arg) {
class(fit$qr) = "list"
slot(answer, "qr") = fit$qr
}
- if(x.arg)
+ if (x.arg)
slot(answer, "x") = x # The 'small' design matrix
- if(control$save.weight)
+ if (control$save.weight)
slot(answer, "weights") = wz
- if(length(xlev))
+ if (length(xlev))
slot(answer, "xlevels") = xlev
- if(y.arg)
+ if (y.arg)
slot(answer, "y") = as.matrix(y)
answer
diff --git a/R/vlm.wfit.q b/R/vlm.wfit.q
index 12304fc..952ee41 100644
--- a/R/vlm.wfit.q
+++ b/R/vlm.wfit.q
@@ -1,5 +1,5 @@
# These functions are
-# Copyright (C) 1998-2009 T.W. Yee, University of Auckland. All rights reserved.
+# Copyright (C) 1998-2010 T.W. Yee, University of Auckland. All rights reserved.
@@ -10,31 +10,32 @@ vlm.wfit <- function(xmat, zmat, Blist, wz=NULL, U=NULL,
matrix.out=FALSE, is.vlmX=FALSE, rss=TRUE, qr=FALSE, x.ret=FALSE,
offset=NULL,
omit.these=NULL, only.rss=FALSE,
- ncolx=if(matrix.out && is.vlmX) stop("need argument 'ncolx'") else ncol(xmat),
+ ncolx = if (matrix.out && is.vlmX) stop("need argument 'ncolx'") else
+ ncol(xmat),
xij=NULL,
lp.names=NULL, Eta.range=NULL, Xm2=NULL, ...) {
missing.Blist <- missing(Blist)
zmat = as.matrix(zmat)
n <- nrow(zmat)
M <- ncol(zmat)
- if(!only.rss) {
+ if (!only.rss) {
contrast.save <- attr(xmat, "contrasts")
znames <- dimnames(zmat)[[2]]
}
- if(length(offset))
+ if (length(offset))
zmat <- zmat - offset
- if(missing(U) || !length(U)) {
+ if (missing(U) || !length(U)) {
U <- vchol(wz, M=M, n=n, silent=FALSE)
}
dU <- dim(U)
- if(dU[2] != n)
+ if (dU[2] != n)
stop("input unconformable")
- X_vlm_save <- if(is.vlmX) {
+ X_vlm_save <- if (is.vlmX) {
xmat
} else {
- if(missing.Blist || !length(Blist))
+ if (missing.Blist || !length(Blist))
Blist = replace.constraints(vector("list", ncol(xmat)),
diag(M), 1:ncol(xmat)) # NULL
lm2vlm.model.matrix(x=xmat, Blist=Blist, M=M, assign.attributes=FALSE,
@@ -45,19 +46,19 @@ vlm.wfit <- function(xmat, zmat, Blist, wz=NULL, U=NULL,
z_vlm <- mux22(U, zmat, M=M, upper=TRUE, as.mat=FALSE)
- if(length(omit.these)) {
+ if (length(omit.these)) {
X_vlm = X_vlm[!omit.these,,drop=FALSE]
z_vlm = z_vlm[!omit.these]
}
ans <- lm.fit(X_vlm, z_vlm, ...)
- if(rss) {
+ if (rss) {
ans$rss <- sum(ans$resid^2)
- if(only.rss) return(list(rss=ans$rss))
+ if (only.rss) return(list(rss=ans$rss))
}
- if(length(omit.these) && any(omit.these))
+ if (length(omit.these) && any(omit.these))
stop("code beyond here cannot handle omitted observations")
@@ -66,40 +67,40 @@ vlm.wfit <- function(xmat, zmat, Blist, wz=NULL, U=NULL,
fv <- vbacksub(U, fv, M=M, n=n) # Have to premultiply fv by U
- if(length(Eta.range)) {
- if(length(Eta.range) != 2)
+ if (length(Eta.range)) {
+ if (length(Eta.range) != 2)
stop("length(Eta.range) must equal 2")
fv = ifelse(fv < Eta.range[1], Eta.range[1], fv)
fv = ifelse(fv > Eta.range[2], Eta.range[2], fv)
}
- ans$fitted.values <- if(M==1) c(fv) else fv
- if(M > 1)
+ ans$fitted.values <- if (M==1) c(fv) else fv
+ if (M > 1)
dimnames(ans$fitted.values) <- list(dimnames(zmat)[[1]], znames)
- ans$residuals <- if(M==1) c(zmat-fv) else zmat-fv
- if(M > 1)
+ ans$residuals <- if (M==1) c(zmat-fv) else zmat-fv
+ if (M > 1)
dimnames(ans$residuals) <- list(dimnames(ans$residuals)[[1]], znames)
ans$misc <- list(M=M, n=n)
ans$call <- match.call()
ans$constraints <- Blist
ans$contrasts <- contrast.save
- if(x.ret)
+ if (x.ret)
ans$X_vlm <- X_vlm_save
- if(!is.null(offset))
+ if (!is.null(offset))
ans$fitted.values <- ans$fitted.values + offset
- if(!matrix.out)
+ if (!matrix.out)
return(ans)
- dx2 = if(is.vlmX) NULL else dimnames(xmat)[[2]]
+ dx2 = if (is.vlmX) NULL else dimnames(xmat)[[2]]
B <- matrix(as.numeric(NA), nrow=M, ncol=ncolx, dimnames=list(lp.names, dx2))
- if(is.null(Blist)) {
+ if (is.null(Blist)) {
Blist = replace.constraints(vector("list", ncolx), diag(M), 1:ncolx)
}
ncolBlist <- unlist(lapply(Blist, ncol))
@@ -115,7 +116,7 @@ vlm.wfit <- function(xmat, zmat, Blist, wz=NULL, U=NULL,
print.vlm.wfit <- function(x, ...) {
- if(!is.null(cl <- x$call)) {
+ if (!is.null(cl <- x$call)) {
cat("Call:\n")
dput(cl)
}
@@ -125,16 +126,16 @@ print.vlm.wfit <- function(x, ...) {
print(coef, ...)
rank <- x$rank
- if(is.null(rank))
+ if (is.null(rank))
rank <- sum(!is.na(coef))
n <- x$misc$n
M <- x$misc$M
rdf <- x$df.resid
- if(is.null(rdf))
+ if (is.null(rdf))
rdf <- (n - rank) * M
cat("\nDegrees of Freedom:", n*M, "Total;", rdf, "Residual\n")
- if(!is.null(x$rss))
+ if (!is.null(x$rss))
cat("Residual Sum of Squares:", format(x$rss), "\n")
invisible(x)
diff --git a/R/vsmooth.spline.q b/R/vsmooth.spline.q
index fa0d987..1d91157 100644
--- a/R/vsmooth.spline.q
+++ b/R/vsmooth.spline.q
@@ -1,11 +1,11 @@
# These functions are
-# Copyright (C) 1998-2009 T.W. Yee, University of Auckland. All rights reserved.
+# Copyright (C) 1998-2010 T.W. Yee, University of Auckland. All rights reserved.
-if(!exists("is.R")) is.R <- function()
+if (!exists("is.R")) is.R <- function()
exists("version") && !is.null(version$language) && version$language=="R"
setClass("vsmooth.spline.fit", representation(
@@ -68,7 +68,7 @@ setMethod("show", "vsmooth.spline",
printvsmooth.spline(object))
setMethod("plot", "vsmooth.spline",
function(x, y, ...) {
- if(!missing(y)) stop("cannot process the 'y' argument")
+ if (!missing(y)) stop("cannot process the 'y' argument")
invisible(plotvsmooth.spline(x, ...))})
setMethod("predict", "vsmooth.spline.fit",
function(object, ...)
@@ -85,28 +85,28 @@ vsmooth.spline <- function(x, y, w, df=rep(5,M), spar=NULL, # rep(0,M),
nk=NULL) {
- if(var.arg) {
+ if (var.arg) {
warning("@var will be returned, but no use will be made of it")
}
missing.constraints <- missing(constraints)
- if(!(missing.spar <- missing(spar)) && !missing(df))
+ if (!(missing.spar <- missing(spar)) && !missing(df))
stop("cannot specify both 'spar' and 'df'")
my.call <- match.call()
- if(missing(y)) {
- if(is.list(x)) {
- if(any(is.na(match(c("x", "y"), names(x)))))
+ if (missing(y)) {
+ if (is.list(x)) {
+ if (any(is.na(match(c("x", "y"), names(x)))))
stop("cannot find 'x' and 'y' in list")
y <- x$y
x <- x$x
- } else if(is.complex(x)) {
+ } else if (is.complex(x)) {
y <- Im(x)
x <- Re(x)
- } else if(is.matrix(x)) {
+ } else if (is.matrix(x)) {
y <- x[,-1]
x <- x[,1]
} else {
@@ -119,38 +119,38 @@ vsmooth.spline <- function(x, y, w, df=rep(5,M), spar=NULL, # rep(0,M),
y <- as.matrix(y)
ny2 <- dimnames(y)[[2]] # NULL if vector
M <- ncol(y)
- if(n != nrow(y))
+ if (n != nrow(y))
stop("lengths of 'x' and 'y' must match")
- if(any(is.na(x)) || any(is.na(y)))
+ if (any(is.na(x)) || any(is.na(y)))
stop("NAs not allowed in 'x' or 'y'")
- if(missing(w)) {
+ if (missing(w)) {
w <- matrix(1, n, M)
} else {
- if(any(is.na(w)))
+ if (any(is.na(w)))
stop("NAs not allowed in 'w'")
w <- as.matrix(w)
- if(nrow(y) != nrow(w) || ncol(w)>M*(M+1)/2)
+ if (nrow(y) != nrow(w) || ncol(w)>M*(M+1)/2)
stop("'w' and 'y' don't match")
- if(scale.w)
+ if (scale.w)
w <- w / mean(w[,1:M]) # 'Average' value is 1
}
dimw <- ncol(w)
- if(missing.constraints)
+ if (missing.constraints)
constraints <- list("(Intercepts)"=eval(iconstraint),
x=eval(xconstraint))
constraints <- eval(constraints)
- if(is.matrix(constraints))
+ if (is.matrix(constraints))
constraints <- list("(Intercepts)"=constraints, x=constraints)
- if(!is.list(constraints) || length(constraints)!=2)
+ if (!is.list(constraints) || length(constraints)!=2)
stop("'constraints' must equal a list (of length 2) or a matrix")
for(i in 1:2)
- if(!is.numeric(constraints[[i]]) || !is.matrix(constraints[[i]]) ||
+ if (!is.numeric(constraints[[i]]) || !is.matrix(constraints[[i]]) ||
nrow(constraints[[i]])!=M || ncol(constraints[[i]])>M)
stop("something wrong with 'constraints'")
names(constraints) <- c("(Intercepts)", "x")
@@ -159,7 +159,7 @@ vsmooth.spline <- function(x, y, w, df=rep(5,M), spar=NULL, # rep(0,M),
sx <- unique(sort(as.vector(x)))
o <- match(x, sx) # sx[o]==x
nef <- length(sx)
- if(nef < 7)
+ if (nef < 7)
stop("not enough unique 'x' values (need 7 or more)")
@@ -180,12 +180,12 @@ vsmooth.spline <- function(x, y, w, df=rep(5,M), spar=NULL, # rep(0,M),
triv=as.integer(1), wuwbar=as.integer(0), ok=as.integer(0))
- if(collaps$ok != 1)
+ if (collaps$ok != 1)
stop("some non-positive-definite weight matrices detected in 'vsuff9'")
dim(collaps$ybar) <- dim(collaps$wz) <- c(nef, M)
- if(FALSE) {
+ if (FALSE) {
} else {
yin = collaps$ybar # Includes both linear and nonlinear parts
junk.frame = data.frame(x=collaps$xbar, yin = yin)
@@ -199,26 +199,26 @@ vsmooth.spline <- function(x, y, w, df=rep(5,M), spar=NULL, # rep(0,M),
}
ncb <- ncol(constraints[[2]]) # Of x and not of the intercept
- spar <- if(length(spar)) rep(spar, length=ncb) else rep(0, length=ncb)
+ spar <- if (length(spar)) rep(spar, length=ncb) else rep(0, length=ncb)
df <- rep(df, length=ncb)
- if(!missing.spar) {
+ if (!missing.spar) {
ispar <- 1
- if(any(spar <= 0) || !is.numeric(spar))
+ if (any(spar <= 0) || !is.numeric(spar))
stop("not allowed non-positive or non-numeric smoothing parameters")
nonlin <- (spar != Inf)
} else {
ispar <- 0
- if(!is.numeric(df) || any(df < 2 | df > nef))
+ if (!is.numeric(df) || any(df < 2 | df > nef))
stop("you must supply '2 <= df <= ", nef, "'")
- if(tol.nl <= 0) stop("bad value for 'tol.nl'")
+ if (tol.nl <= 0) stop("bad value for 'tol.nl'")
nonlin <- abs(df-2) > tol.nl
}
- if(all(!nonlin)) {
+ if (all(!nonlin)) {
junk.fill = new("vsmooth.spline.fit",
"Bcoefficients"= matrix(as.numeric(NA), 1, 1),
@@ -229,10 +229,10 @@ vsmooth.spline <- function(x, y, w, df=rep(5,M), spar=NULL, # rep(0,M),
new("vsmooth.spline",
"call" = my.call,
"constraints" = constraints,
- "df" = if(ispar==0) df else rep(2, length(spar)),
+ "df" = if (ispar==0) df else rep(2, length(spar)),
"lfit" = lfit,
"nlfit" = junk.fill,
- "spar" = if(ispar==1) spar else rep(Inf, length(df)),
+ "spar" = if (ispar==1) spar else rep(Inf, length(df)),
"w" = as.matrix(collaps$wbar),
"x" = sx,
"y" = lfit at fitted.values,
@@ -246,23 +246,23 @@ vsmooth.spline <- function(x, y, w, df=rep(5,M), spar=NULL, # rep(0,M),
xbar <- (sx - sx[1]) / (sx[nef] - sx[1])
noround = TRUE # Improvement 3/8/02
- if(all.knots) {
- if(noround) {
+ if (all.knots) {
+ if (noround) {
knot = valid.vknotl2(c(rep(xbar[1], 3), xbar, rep(xbar[nef], 3)))
} else {
knot <- c(rep(xbar[1], 3), xbar, rep(xbar[nef], 3))
}
- if(length(nk)) warning("overriding 'nk' by 'all.knots=TRUE'")
+ if (length(nk)) warning("overriding 'nk' by 'all.knots=TRUE'")
nk <- length(knot) - 4 # No longer nef + 2
} else {
chosen = length(nk)
- if(chosen && (nk > nef+2 || nk <= 5))
+ if (chosen && (nk > nef+2 || nk <= 5))
stop("bad value for 'nk'")
- if(!chosen) nk = 0
+ if (!chosen) nk = 0
knot.list <- dotFortran(name="vknotl2", as.double(xbar), as.integer(nef),
knot=double(nef+6), k=as.integer(nk+4),
chosen=as.integer(chosen))
- if(noround) {
+ if (noround) {
knot = valid.vknotl2(knot.list$knot[1:(knot.list$k)])
knot.list$k = length(knot)
} else {
@@ -270,7 +270,7 @@ vsmooth.spline <- function(x, y, w, df=rep(5,M), spar=NULL, # rep(0,M),
}
nk <- knot.list$k - 4
}
- if(nk <= 5) stop("not enough distinct knots found")
+ if (nk <= 5) stop("not enough distinct knots found")
conmat <- (constraints[[2]])[,nonlin,drop=FALSE]
ncb <- sum(nonlin)
@@ -279,8 +279,8 @@ vsmooth.spline <- function(x, y, w, df=rep(5,M), spar=NULL, # rep(0,M),
spar.nl <- spar[nonlin]
df.nl <- df[nonlin]
- edimu <- if(trivc != 0) dimw else max(ncb*(ncb+1)/2, dimw) # for wbar's size
- dimu <- if(trivc != 0) dimw else ncb*(ncb+1)/2
+ edimu <- if (trivc != 0) dimw else max(ncb*(ncb+1)/2, dimw) # for wbar's size
+ dimu <- if (trivc != 0) dimw else ncb*(ncb+1)/2
o <- 1:nef # Already sorted
collaps <- dotFortran(name="vsuff9",
@@ -293,7 +293,7 @@ vsmooth.spline <- function(x, y, w, df=rep(5,M), spar=NULL, # rep(0,M),
double(M*(M+1)), double(ncb*(ncb+1)),
as.double(conmat), as.integer(ncb),
as.integer(trivc), wuwbar=as.integer(0), ok=as.integer(0))
- if(collaps$ok != 1)
+ if (collaps$ok != 1)
stop("some non-positive-definite weight matrices detected in 'vsuff9'")
dim(collaps$ybar) <- dim(collaps$wz) <- c(nef, M)
@@ -303,11 +303,11 @@ vsmooth.spline <- function(x, y, w, df=rep(5,M), spar=NULL, # rep(0,M),
ldk = 3 * ncb + 1 # 10/7/02; Previously 4 * ncb
- lev <- if(ncb > 1) matrix(0, nef, ncb) else rep(0, nef)
- varmat <- if(var.arg) {if(ncb > 1) matrix(0, nef, ncb) else
+ lev <- if (ncb > 1) matrix(0, nef, ncb) else rep(0, nef)
+ varmat <- if (var.arg) {if(ncb > 1) matrix(0, nef, ncb) else
rep(0, nef)} else double(1)
index <- iam(NA, NA, ncb, both=TRUE, diagonal=TRUE)
- dimwbar <- if(trivc != 0) dimw else ncb*(ncb+1)/2
+ dimwbar <- if (trivc != 0) dimw else ncb*(ncb+1)/2
vsplin <- dotFortran(name="vsplin",
xs=as.double(xbar), wz=as.double(collaps$wz),
@@ -329,17 +329,17 @@ vsmooth.spline <- function(x, y, w, df=rep(5,M), spar=NULL, # rep(0,M),
truen=as.integer(nef))
- if(vsplin$ier != 0) {
+ if (vsplin$ier != 0) {
stop("vsplin$ier == ", vsplin$ier, ". Something gone wrong in 'vsplin'")
}
- if(vsplin$info != 0)
+ if (vsplin$info != 0)
stop("leading minor of order ", vsplin$info,
" is not positive-definite")
dim(vsplin$lev) <- c(nef, ncb) # A matrix even when ncb==1
- if(ncb > 1) {
+ if (ncb > 1) {
dim(vsplin$fv) <- c(nef, ncb)
- if(var.arg)
+ if (var.arg)
dim(vsplin$var) <- c(nef, ncb)
}
@@ -347,12 +347,12 @@ vsmooth.spline <- function(x, y, w, df=rep(5,M), spar=NULL, # rep(0,M),
fv <- lfit at fitted.values + vsplin$fv %*% t(conmat)
- if(M > 1)
+ if (M > 1)
dimnames(fv) <- list(NULL, ny2)
df[!nonlin] = 2
df[ nonlin] = df.nl
- if(ispar==0) {
+ if (ispar==0) {
spar[!nonlin] = Inf
spar[ nonlin] = vsplin$spar.nl # Actually used
}
@@ -371,13 +371,13 @@ vsmooth.spline <- function(x, y, w, df=rep(5,M), spar=NULL, # rep(0,M),
"nlfit" = fit.object,
"lev" = vsplin$lev,
"lfit" = lfit,
- "spar" = spar, # if(ispar==1) spar else vsplin$spar,
+ "spar" = spar, # if (ispar==1) spar else vsplin$spar,
"w" = collaps$wbar,
"x" = sx,
"y" = fv,
"yin" = yin)
- if(var.arg)
+ if (var.arg)
object at var = vsplin$var
object
@@ -385,21 +385,21 @@ vsmooth.spline <- function(x, y, w, df=rep(5,M), spar=NULL, # rep(0,M),
printvsmooth.spline <- function(x, ...) {
- if(!is.null(cl <- x at call)) {
+ if (!is.null(cl <- x at call)) {
cat("Call:\n")
dput(cl)
}
- ncb <- if(length(x at nlfit)) ncol(x at nlfit@Bcoefficients) else NULL
+ ncb <- if (length(x at nlfit)) ncol(x at nlfit@Bcoefficients) else NULL
cat("\nSmoothing Parameter (Spar):",
- if(length(ncb) && ncb==1) format(x at spar) else
+ if (length(ncb) && ncb==1) format(x at spar) else
paste(format(x at spar), collapse=", "), "\n")
cat("\nEquivalent Degrees of Freedom (Df):",
- if(length(ncb) && ncb==1) format(x at df) else
+ if (length(ncb) && ncb==1) format(x at df) else
paste(format(x at df), collapse=", "), "\n")
- if(!all(trivial.constraints(x at constraints) == 1)) {
+ if (!all(trivial.constraints(x at constraints) == 1)) {
cat("\nConstraint matrices:\n")
print(x at constraints)
}
@@ -442,10 +442,10 @@ plotvsmooth.spline <- function(x, xlab="x", ylab="", points=TRUE,
lcol = rep(lcol, length=M)
lwd = rep(lwd, length=M)
lty = rep(lty, length=M)
- if(!add)
+ if (!add)
matplot(x at x, x at yin, type="n", xlab=xlab, ylab=ylab, ...)
for(i in 1:ncol(x at y)) {
- if(points)
+ if (points)
points(x at x, x at yin[,i], col=pcol[i], pch=pch[i], cex=pcex[i])
lines(x at x, x at y[,i], col=lcol[i], lwd=lwd[i], lty=lty[i])
}
@@ -455,15 +455,15 @@ plotvsmooth.spline <- function(x, xlab="x", ylab="", points=TRUE,
predictvsmooth.spline <- function(object, x, deriv=0, se.fit=FALSE) {
- if(se.fit)
+ if (se.fit)
warning("'se.fit=TRUE' is not currently implemented. ",
"Using 'se.fit=FALSE'")
lfit <- object at lfit # Linear part of the vector spline
nlfit <- object at nlfit # Nonlinear part of the vector spline
- if(missing(x)) {
- if(deriv==0) {
+ if (missing(x)) {
+ if (deriv==0) {
return(list(x=object at x, y=object at y))
} else {
x <- object at x
@@ -474,18 +474,18 @@ predictvsmooth.spline <- function(object, x, deriv=0, se.fit=FALSE) {
mat.coef = coefvlm(lfit, matrix=TRUE)
coeflfit <- t(mat.coef) # M x p now
- M <- nrow(coeflfit) # if(is.matrix(object at y)) ncol(object at y) else 1
+ M <- nrow(coeflfit) # if (is.matrix(object at y)) ncol(object at y) else 1
- pred <- if(deriv==0) predict(lfit, data.frame(x=x)) else
- if(deriv==1) matrix(coeflfit[,2], length(x), M, byrow=TRUE) else
+ pred <- if (deriv==0) predict(lfit, data.frame(x=x)) else
+ if (deriv==1) matrix(coeflfit[,2], length(x), M, byrow=TRUE) else
matrix(0, length(x), M)
- if(!length(nlfit at knots))
+ if (!length(nlfit at knots))
return(list(x=x, y=pred))
nonlin <- (object at spar != Inf)
- conmat <- if(!length(lfit at constraints)) diag(M) else lfit at constraints[[2]]
+ conmat <- if (!length(lfit at constraints)) diag(M) else lfit at constraints[[2]]
conmat <- conmat[,nonlin,drop=FALSE] # Of nonlinear functions
list(x=x, y=pred + predict(nlfit, x, deriv)$y %*% t(conmat))
@@ -495,7 +495,7 @@ predictvsmooth.spline <- function(object, x, deriv=0, se.fit=FALSE) {
predictvsmooth.spline.fit <- function(object, x, deriv=0) {
nk = nrow(object at Bcoefficients)
drangex <- object at xmax - object at xmin
- if(missing(x))
+ if (missing(x))
x <- seq(from=object at xmin, to=object at xmax, length=nk-4)
xs <- as.double((x - object at xmin)/drangex)
@@ -506,7 +506,7 @@ predictvsmooth.spline.fit <- function(object, x, deriv=0) {
ncb <- ncol(object at Bcoefficients)
y <- matrix(as.numeric(NA), length(xs), ncb)
- if(any(good)) {
+ if (any(good)) {
ngood <- sum(good)
junk <- dotFortran(name="vbvs", as.integer(ngood),
as.double(object at knots), as.double(object at Bcoefficients),
@@ -515,33 +515,33 @@ predictvsmooth.spline.fit <- function(object, x, deriv=0) {
as.integer(deriv), as.integer(ncb))
y[good,] <- junk$s
- if(TRUE && deriv > 1) {
+ if (TRUE && deriv > 1) {
edges <- xs <= 0 | xs >= 1 # Zero the edges & beyond explicitly
y[edges,] <- 0
}
}
- if(any(!good)) {
+ if (any(!good)) {
xrange <- c(object at xmin, object at xmax)
- if(deriv == 0) {
+ if (deriv == 0) {
end.object <- Recall(object, xrange)$y
end.slopes <- Recall(object, xrange, 1)$y * drangex
- if(any(bad.left))
+ if (any(bad.left))
y[bad.left,] = rep(end.object[1,], rep(sum(bad.left), ncb)) +
rep(end.slopes[1,], rep(sum(bad.left), ncb)) *
xs[bad.left]
- if(any(bad.right))
+ if (any(bad.right))
y[bad.right,] = rep(end.object[2,], rep(sum(bad.right), ncb)) +
rep(end.slopes[2,], rep(sum(bad.right), ncb)) *
(xs[bad.right] - 1)
- } else if(deriv == 1) {
+ } else if (deriv == 1) {
end.slopes <- Recall(object, xrange, 1)$y * drangex
y[bad.left,] <- rep(end.slopes[1,], rep(sum(bad.left), ncb))
y[bad.right,] <- rep(end.slopes[2,], rep(sum(bad.right), ncb))
} else
y[!good,] <- 0
}
- if(deriv > 0)
+ if (deriv > 0)
y <- y / (drangex^deriv)
list(x=x, y=y)
}
@@ -553,7 +553,7 @@ valid.vknotl2 = function(knot, tol=1/1000) {
keep=integer(length(knot)), as.double(tol))
keep = as.logical(junk$keep)
knot = junk$knot[keep]
- if(length(knot) <= 11)
+ if (length(knot) <= 11)
stop("too few (distinct) knots")
knot
}
diff --git a/R/zzz.R b/R/zzz.R
index 22a118a..a630d09 100644
--- a/R/zzz.R
+++ b/R/zzz.R
@@ -1,5 +1,5 @@
# These functions are
-# Copyright (C) 1998-2009 T.W. Yee, University of Auckland. All rights reserved.
+# Copyright (C) 1998-2010 T.W. Yee, University of Auckland. All rights reserved.
diff --git a/data/backPain.R b/data/backPain.R
new file mode 100644
index 0000000..de37d29
--- /dev/null
+++ b/data/backPain.R
@@ -0,0 +1,5 @@
+backPain <- read.table("backPain.txt")
+backPain$pain <- ordered(backPain$pain,
+ levels = c("worse", "same", "slight.improvement",
+ "moderate.improvement", "marked.improvement",
+ "complete.relief"))
diff --git a/data/backPain.txt b/data/backPain.txt
new file mode 100644
index 0000000..fa23f57
--- /dev/null
+++ b/data/backPain.txt
@@ -0,0 +1,102 @@
+ x1 x2 x3 pain
+1 1 1 1 same
+2 1 1 1 marked.improvement
+3 1 1 1 complete.relief
+4 1 2 1 same
+5 1 2 1 slight.improvement
+6 1 2 1 marked.improvement
+7 1 2 1 complete.relief
+8 1 1 2 moderate.improvement
+9 1 1 2 marked.improvement
+10 1 3 1 marked.improvement
+11 1 3 1 complete.relief
+12 1 2 2 same
+13 1 2 2 moderate.improvement
+14 1 2 2 complete.relief
+15 2 1 1 slight.improvement
+16 2 1 1 marked.improvement
+17 2 1 1 complete.relief
+18 1 3 2 slight.improvement
+19 1 3 2 moderate.improvement
+20 1 3 2 marked.improvement
+21 2 2 1 same
+22 2 2 1 slight.improvement
+23 2 2 1 moderate.improvement
+24 2 2 1 marked.improvement
+25 2 2 1 complete.relief
+26 2 1 2 same
+27 2 1 2 marked.improvement
+28 2 3 1 worse
+29 2 3 1 same
+30 2 3 1 slight.improvement
+31 2 3 1 moderate.improvement
+32 2 3 1 marked.improvement
+33 2 2 2 worse
+34 2 2 2 same
+35 2 2 2 slight.improvement
+36 2 2 2 moderate.improvement
+37 2 2 2 complete.relief
+38 2 3 2 worse
+39 2 3 2 slight.improvement
+40 2 3 2 moderate.improvement
+41 1 1 1 marked.improvement
+42 1 1 1 complete.relief
+43 1 1 1 complete.relief
+44 1 1 1 complete.relief
+45 1 2 1 same
+46 1 2 1 slight.improvement
+47 1 2 1 slight.improvement
+48 1 2 1 marked.improvement
+49 1 2 1 marked.improvement
+50 1 2 1 marked.improvement
+51 1 2 1 marked.improvement
+52 1 2 1 marked.improvement
+53 1 2 1 complete.relief
+54 1 2 1 complete.relief
+55 1 2 1 complete.relief
+56 1 1 2 marked.improvement
+57 1 1 2 marked.improvement
+58 1 3 1 marked.improvement
+59 1 3 1 complete.relief
+60 1 2 2 moderate.improvement
+61 2 1 1 slight.improvement
+62 2 1 1 slight.improvement
+63 2 1 1 complete.relief
+64 1 3 2 marked.improvement
+65 1 3 2 marked.improvement
+66 2 2 1 same
+67 2 2 1 same
+68 2 2 1 slight.improvement
+69 2 2 1 slight.improvement
+70 2 2 1 slight.improvement
+71 2 2 1 moderate.improvement
+72 2 2 1 moderate.improvement
+73 2 2 1 moderate.improvement
+74 2 2 1 moderate.improvement
+75 2 2 1 marked.improvement
+76 2 2 1 marked.improvement
+77 2 2 1 marked.improvement
+78 2 2 1 marked.improvement
+79 2 2 1 marked.improvement
+80 2 2 1 complete.relief
+81 2 1 2 marked.improvement
+82 2 1 2 marked.improvement
+83 2 3 1 worse
+84 2 3 1 same
+85 2 3 1 moderate.improvement
+86 2 3 1 moderate.improvement
+87 2 3 1 moderate.improvement
+88 2 3 1 moderate.improvement
+89 2 3 1 marked.improvement
+90 2 2 2 same
+91 2 2 2 same
+92 2 2 2 same
+93 2 2 2 slight.improvement
+94 2 2 2 slight.improvement
+95 2 2 2 slight.improvement
+96 2 2 2 moderate.improvement
+97 2 2 2 moderate.improvement
+98 2 3 2 worse
+99 2 3 2 slight.improvement
+100 2 3 2 moderate.improvement
+101 2 3 2 moderate.improvement
\ No newline at end of file
diff --git a/data/chest.txt b/data/chestnz.txt
similarity index 100%
rename from data/chest.txt
rename to data/chestnz.txt
diff --git a/data/nzmarital.R b/data/nzmarital.R
new file mode 100644
index 0000000..c821469
--- /dev/null
+++ b/data/nzmarital.R
@@ -0,0 +1,1809 @@
+nzmarital <-
+structure(list(age = c(29, 55, 44, 53, 45, 30, 31, 24, 47, 51,
+35, 35, 39, 33, 30, 47, 29, 43, 31, 56, 32, 46, 33, 44, 33, 45,
+47, 35, 34, 50, 50, 38, 44, 34, 27, 50, 48, 51, 28, 43, 32, 51,
+49, 53, 33, 52, 41, 24, 51, 46, 26, 35, 28, 34, 36, 60, 54, 33,
+40, 52, 41, 64, 27, 44, 47, 46, 35, 39, 48, 46, 40, 40, 37, 31,
+49, 31, 33, 50, 48, 43, 40, 40, 33, 45, 50, 44, 40, 61, 45, 39,
+44, 22, 41, 27, 36, 25, 30, 35, 22, 50, 25, 37, 46, 38, 39, 46,
+23, 54, 29, 43, 58, 53, 29, 57, 31, 29, 36, 46, 51, 56, 59, 41,
+44, 50, 40, 34, 26, 58, 36, 31, 52, 32, 40, 48, 53, 49, 54, 56,
+28, 24, 27, 43, 30, 44, 54, 54, 42, 55, 34, 43, 48, 34, 39, 44,
+52, 37, 33, 21, 34, 56, 29, 47, 31, 28, 42, 48, 44, 53, 37, 42,
+54, 45, 46, 34, 29, 40, 54, 53, 48, 52, 25, 43, 48, 51, 53, 32,
+30, 41, 57, 29, 53, 57, 29, 54, 46, 26, 34, 44, 35, 52, 44, 29,
+50, 57, 25, 54, 35, 31, 48, 25, 50, 31, 37, 48, 39, 41, 52, 59,
+39, 26, 41, 35, 31, 26, 32, 35, 35, 36, 26, 35, 37, 41, 54, 49,
+33, 31, 34, 24, 42, 24, 57, 48, 29, 37, 58, 41, 43, 27, 47, 33,
+56, 25, 49, 41, 42, 32, 31, 45, 41, 30, 41, 42, 59, 46, 51, 26,
+42, 25, 25, 37, 42, 45, 49, 29, 24, 46, 50, 53, 31, 24, 38, 54,
+58, 28, 57, 54, 50, 52, 41, 48, 46, 42, 19, 45, 29, 32, 51, 52,
+40, 28, 40, 51, 43, 34, 58, 52, 56, 57, 56, 46, 31, 44, 35, 26,
+53, 48, 43, 60, 31, 33, 49, 55, 34, 51, 34, 32, 31, 36, 41, 40,
+39, 70, 48, 76, 45, 22, 36, 50, 35, 43, 37, 34, 41, 38, 24, 35,
+41, 51, 29, 44, 56, 34, 40, 31, 37, 37, 31, 60, 37, 58, 60, 36,
+27, 29, 48, 37, 43, 39, 46, 34, 50, 43, 41, 46, 49, 53, 30, 31,
+38, 33, 52, 30, 46, 35, 40, 54, 48, 44, 50, 37, 48, 48, 53, 41,
+46, 34, 35, 33, 51, 28, 53, 44, 30, 37, 48, 30, 38, 22, 20, 26,
+30, 36, 33, 31, 39, 35, 30, 51, 27, 28, 38, 47, 48, 56, 48, 60,
+41, 41, 31, 45, 34, 36, 36, 27, 34, 53, 45, 49, 57, 51, 45, 42,
+40, 27, 27, 47, 41, 29, 38, 50, 34, 45, 42, 48, 46, 42, 45, 47,
+42, 53, 31, 20, 30, 44, 28, 24, 36, 54, 58, 44, 40, 22, 46, 27,
+36, 51, 49, 55, 42, 39, 42, 57, 45, 49, 42, 50, 35, 44, 40, 36,
+54, 22, 46, 53, 19, 39, 48, 22, 23, 39, 23, 51, 50, 46, 42, 44,
+25, 33, 21, 20, 51, 31, 59, 21, 43, 19, 49, 37, 41, 27, 19, 58,
+45, 42, 46, 45, 52, 23, 52, 44, 32, 41, 59, 37, 45, 47, 60, 29,
+39, 49, 52, 47, 48, 52, 29, 28, 45, 51, 38, 44, 46, 25, 31, 37,
+56, 39, 59, 59, 43, 59, 34, 36, 36, 30, 55, 46, 36, 43, 56, 43,
+51, 36, 44, 46, 44, 50, 48, 45, 39, 54, 25, 50, 52, 32, 48, 42,
+55, 59, 55, 49, 32, 23, 64, 60, 52, 39, 46, 55, 47, 38, 28, 57,
+36, 42, 34, 49, 32, 39, 41, 51, 25, 36, 38, 43, 53, 21, 48, 32,
+54, 46, 55, 36, 48, 40, 37, 41, 36, 58, 24, 42, 30, 30, 45, 36,
+45, 49, 42, 28, 47, 46, 43, 33, 51, 34, 40, 27, 23, 41, 50, 23,
+31, 38, 60, 39, 23, 48, 54, 29, 27, 53, 26, 31, 41, 56, 44, 57,
+61, 42, 55, 23, 48, 25, 47, 23, 34, 28, 55, 47, 35, 34, 29, 51,
+49, 24, 50, 41, 47, 40, 58, 30, 53, 30, 57, 33, 47, 20, 35, 62,
+53, 35, 19, 24, 18, 22, 24, 46, 43, 21, 27, 35, 42, 36, 31, 20,
+20, 45, 27, 35, 20, 21, 44, 84, 29, 45, 36, 20, 21, 20, 44, 21,
+34, 29, 28, 43, 38, 32, 20, 18, 28, 24, 43, 24, 55, 42, 35, 69,
+33, 28, 40, 43, 44, 44, 33, 45, 28, 20, 20, 29, 32, 60, 45, 41,
+32, 48, 36, 45, 59, 61, 52, 45, 35, 52, 42, 32, 25, 34, 31, 58,
+64, 30, 41, 62, 49, 35, 31, 42, 37, 32, 46, 41, 37, 29, 43, 38,
+40, 44, 24, 41, 50, 34, 22, 41, 31, 46, 44, 26, 40, 46, 28, 47,
+41, 40, 30, 43, 26, 43, 41, 30, 51, 23, 35, 39, 46, 27, 24, 38,
+58, 33, 35, 55, 50, 45, 34, 42, 26, 24, 28, 32, 38, 48, 32, 44,
+31, 36, 40, 33, 30, 59, 33, 67, 40, 41, 58, 39, 35, 51, 47, 51,
+33, 32, 43, 44, 30, 63, 51, 28, 26, 25, 54, 30, 28, 29, 44, 47,
+57, 45, 29, 32, 45, 44, 20, 29, 19, 43, 56, 24, 31, 26, 51, 32,
+37, 34, 41, 51, 36, 31, 25, 58, 25, 56, 41, 38, 26, 48, 26, 32,
+28, 37, 25, 44, 20, 47, 59, 46, 49, 28, 51, 31, 26, 51, 45, 41,
+51, 43, 33, 46, 29, 33, 46, 53, 50, 23, 36, 42, 51, 36, 26, 29,
+40, 52, 17, 53, 23, 40, 33, 48, 37, 57, 44, 30, 47, 36, 42, 58,
+24, 25, 58, 46, 44, 26, 29, 42, 25, 28, 29, 38, 38, 24, 67, 40,
+33, 23, 42, 33, 48, 33, 26, 44, 55, 23, 28, 51, 23, 20, 25, 30,
+44, 50, 30, 26, 54, 43, 56, 32, 36, 43, 21, 57, 27, 53, 48, 27,
+24, 50, 60, 57, 54, 29, 34, 25, 55, 51, 32, 43, 32, 29, 31, 53,
+21, 52, 41, 23, 39, 30, 28, 33, 26, 40, 51, 46, 23, 50, 39, 48,
+46, 37, 57, 56, 57, 53, 56, 49, 53, 32, 36, 57, 52, 36, 32, 44,
+52, 39, 28, 38, 45, 46, 47, 44, 40, 43, 49, 47, 44, 28, 25, 43,
+29, 37, 27, 44, 39, 31, 34, 20, 34, 22, 31, 32, 30, 56, 30, 20,
+39, 23, 39, 48, 38, 30, 41, 28, 49, 27, 40, 35, 28, 40, 31, 19,
+25, 51, 57, 35, 48, 46, 40, 41, 52, 59, 36, 45, 49, 50, 35, 26,
+47, 23, 42, 26, 26, 37, 58, 39, 47, 23, 36, 28, 52, 40, 39, 42,
+30, 42, 30, 56, 46, 22, 36, 20, 41, 35, 33, 33, 33, 41, 23, 55,
+51, 52, 33, 52, 35, 26, 44, 54, 31, 44, 43, 18, 54, 42, 55, 29,
+33, 52, 30, 31, 43, 41, 26, 54, 29, 43, 39, 40, 59, 27, 57, 53,
+39, 47, 24, 46, 17, 23, 25, 24, 56, 52, 38, 20, 37, 30, 31, 46,
+25, 43, 19, 46, 44, 45, 41, 36, 31, 23, 37, 49, 42, 30, 36, 37,
+28, 20, 43, 60, 56, 26, 64, 61, 53, 44, 40, 40, 52, 49, 36, 35,
+40, 50, 45, 56, 21, 47, 54, 53, 24, 41, 34, 26, 30, 36, 30, 56,
+44, 48, 54, 22, 53, 39, 28, 43, 53, 53, 43, 42, 27, 33, 25, 54,
+47, 37, 44, 47, 40, 44, 33, 26, 24, 30, 56, 43, 62, 45, 24, 34,
+31, 22, 46, 53, 52, 43, 45, 40, 47, 44, 48, 53, 43, 42, 43, 48,
+41, 53, 52, 27, 56, 46, 43, 54, 44, 49, 38, 54, 35, 46, 46, 54,
+46, 32, 36, 28, 51, 54, 41, 57, 35, 47, 34, 56, 36, 47, 58, 44,
+55, 40, 25, 55, 53, 55, 32, 34, 28, 21, 42, 42, 37, 41, 47, 30,
+20, 48, 31, 48, 29, 50, 56, 43, 32, 37, 27, 21, 26, 38, 56, 40,
+43, 60, 28, 27, 41, 39, 56, 46, 27, 46, 44, 25, 53, 38, 76, 56,
+60, 56, 35, 73, 74, 52, 84, 39, 44, 50, 55, 82, 51, 43, 73, 54,
+82, 49, 70, 48, 52, 65, 72, 71, 49, 76, 45, 75, 38, 39, 69, 60,
+68, 82, 53, 40, 48, 63, 44, 78, 73, 71, 42, 65, 53, 68, 77, 68,
+72, 74, 49, 82, 60, 54, 69, 55, 78, 61, 76, 54, 73, 56, 52, 51,
+58, 54, 71, 64, 55, 43, 84, 80, 68, 57, 49, 75, 38, 41, 56, 40,
+61, 58, 61, 46, 47, 60, 64, 73, 50, 72, 53, 43, 58, 52, 64, 75,
+57, 52, 67, 83, 48, 76, 51, 56, 60, 71, 63, 81, 51, 64, 65, 64,
+74, 61, 59, 44, 38, 80, 50, 66, 58, 78, 35, 60, 66, 36, 36, 65,
+53, 56, 82, 77, 48, 50, 36, 42, 75, 75, 35, 71, 44, 43, 35, 39,
+36, 65, 46, 37, 46, 46, 46, 56, 51, 73, 59, 50, 49, 68, 53, 48,
+77, 78, 41, 44, 61, 80, 66, 51, 73, 80, 67, 44, 73, 60, 37, 53,
+70, 65, 37, 53, 79, 81, 82, 71, 43, 42, 69, 76, 58, 68, 42, 38,
+37, 41, 61, 42, 44, 63, 65, 60, 63, 81, 55, 70, 56, 73, 60, 81,
+66, 54, 69, 40, 84, 68, 70, 49, 52, 74, 40, 58, 46, 39, 64, 52,
+58, 56, 75, 78, 74, 79, 64, 45, 51, 40, 53, 40, 44, 58, 78, 41,
+42, 63, 79, 63, 40, 46, 54, 39, 60, 78, 59, 67, 55, 44, 42, 49,
+39, 56, 74, 41, 74, 67, 52, 59, 58, 76, 66, 82, 59, 58, 44, 50,
+77, 55, 68, 73, 68, 46, 45, 45, 62, 75, 40, 85, 78, 61, 80, 46,
+65, 37, 48, 64, 77, 45, 68, 58, 61, 42, 58, 75, 68, 77, 60, 62,
+52, 48, 73, 84, 62, 54, 70, 49, 72, 58, 65, 83, 44, 57, 48, 64,
+58, 70, 44, 59, 42, 44, 76, 38, 62, 37, 58, 40, 49, 54, 38, 85,
+62, 81, 56, 51, 66, 51, 42, 67, 61, 74, 65, 46, 71, 52, 69, 71,
+69, 42, 43, 59, 36, 40, 45, 52, 69, 57, 44, 66, 38, 44, 69, 36,
+61, 42, 67, 61, 66, 73, 83, 85, 67, 76, 52, 67, 69, 78, 77, 81,
+69, 43, 40, 40, 43, 38, 67, 71, 58, 43, 59, 45, 75, 39, 80, 72,
+50, 83, 40, 67, 46, 78, 48, 78, 42, 49, 57, 67, 55, 70, 70, 57,
+78, 61, 53, 60, 48, 37, 70, 42, 70, 38, 71, 47, 73, 83, 81, 40,
+42, 66, 49, 64, 70, 70, 55, 64, 74, 61, 68, 49, 64, 79, 61, 65,
+39, 54, 66, 60, 67, 53, 61, 47, 80, 43, 60, 49, 65, 79, 42, 81,
+46, 41, 69, 46, 56, 58, 35, 42, 41, 68, 44, 50, 36, 61, 62, 51,
+83, 43, 75, 49, 81, 44, 62, 45, 75, 78, 68, 78, 62, 60, 58, 75,
+37, 44, 51, 71, 58, 48, 66, 48, 63, 63, 46, 56, 63, 83, 78, 43,
+81, 57, 45, 70, 68, 65, 43, 78, 71, 55, 83, 67, 78, 68, 50, 63,
+85, 49, 72, 82, 47, 79, 44, 51, 84, 70, 77, 61, 48, 54, 49, 73,
+38, 61, 61, 65, 57, 77, 76, 70, 74, 66, 66, 56, 78, 36, 36, 49,
+50, 62, 80, 85, 54, 54, 76, 51, 68, 52, 56, 48, 78, 80, 64, 75,
+43, 69, 61, 81, 42, 72, 79, 79, 45, 61, 38, 71, 49, 45, 65, 80,
+41, 44, 64, 70, 69, 65, 72, 78, 65, 79, 35, 78, 63, 58, 48, 85,
+36, 55, 53, 67, 73, 77, 39, 51, 71, 44, 58, 61, 65, 65, 66, 36,
+73, 78, 70, 56, 66, 77, 76, 80, 44, 36, 62, 61, 46, 60, 54, 55,
+61, 53, 66, 68, 67, 74, 64, 72, 57, 75, 74, 79, 61, 51, 60, 66,
+61, 44, 52, 73, 60, 36, 70, 49, 78, 61, 64, 74, 41, 62, 70, 78,
+74, 59, 80, 81, 42, 74, 53, 62, 51, 62, 78, 62, 53, 70, 81, 45,
+78, 66, 44, 54, 54, 68, 73, 65, 80, 40, 80, 79, 55, 85, 70, 53,
+50, 69, 67, 76, 59, 62, 64, 70, 59, 67, 40, 55, 57, 67, 83, 73,
+72, 65, 60, 79, 52, 65, 56, 60, 46, 60, 36, 59, 60, 40, 59, 60,
+61, 37, 67, 64, 84, 82, 67, 58, 45, 45, 40, 44, 69, 52, 44, 43,
+67, 46, 38, 61, 37, 76, 79, 77, 64, 67, 56, 60, 75, 39, 48, 56,
+73, 72, 48, 43, 63, 53, 69, 44, 63, 79, 83, 78, 47, 63, 74, 53,
+73, 68, 55, 45, 72, 47, 79, 56, 71, 78, 55, 41, 85, 77, 51, 64,
+52, 49, 62, 70, 81, 50, 62, 70, 73, 65, 52, 57, 56, 63, 42, 55,
+41, 59, 66, 45, 84, 80, 75, 80, 70, 82, 36, 74, 78, 75, 47, 37,
+42, 75, 63, 61, 39, 71, 51, 66, 79, 40, 82, 38, 51, 65, 37, 72,
+72, 72, 80, 62, 81, 47, 72, 72, 76, 51, 58, 40, 58, 59, 60, 59,
+51, 76, 68, 45, 51, 80, 49, 57, 84, 84, 77, 63, 55, 45, 81, 77,
+78, 80, 39, 50, 36, 79, 58, 46, 77, 78, 65, 73, 81, 77, 59, 78,
+40, 78, 77, 76, 73, 74, 77, 56, 43, 76, 78, 64, 51, 82, 64, 77,
+83, 72, 84, 79, 80, 60, 74, 80, 51, 76, 50, 82, 61, 75, 51, 48,
+78, 60, 44, 43, 82, 57, 85, 58, 42, 77, 77, 71, 44, 58, 53, 59,
+59, 48, 43, 45, 74, 60, 56, 59, 63, 37, 64, 49, 49, 78, 54, 55,
+40, 72, 76, 46, 72, 54, 45, 65, 46, 78, 64, 43, 57, 79, 50, 74,
+45, 58, 64, 65, 58, 81, 78, 52, 64, 84, 54, 57, 66, 72, 52, 51,
+57, 46, 58, 78, 40, 52, 60, 79, 83, 78, 64, 46, 36, 57, 73, 81,
+53, 39, 77, 76, 39, 48, 65, 60, 76, 48, 67, 48, 65, 81, 84, 84,
+81, 82, 41, 54, 65, 63, 44, 64, 62, 39, 70, 73, 78, 53, 57, 65,
+48, 49, 60, 55, 58, 56, 69, 58, 54, 63, 65, 47, 67, 52, 81, 79,
+54, 54, 48, 53, 42, 44, 68, 44, 37, 54, 60, 39, 37, 42, 42, 46,
+52, 81, 82, 79, 61, 57, 37, 46, 66, 83, 41, 43, 74, 39, 76, 73,
+77, 75, 68, 78, 39, 73, 85, 73, 74, 73, 39, 74, 79, 81, 83, 75,
+74, 83, 83, 86, 75, 75, 85, 72, 72, 74, 72, 76, 77, 80, 75, 76,
+49, 73, 73, 40, 71, 55, 74, 77, 72, 76, 78, 53, 39, 84, 53, 73,
+37, 50, 53, 74, 44, 54, 73, 51, 74, 72, 78, 75, 36, 75, 49, 54,
+82, 86, 83, 41, 42, 38, 54, 75, 72, 52, 40, 38, 73, 57, 49, 47,
+30, 31, 49, 18, 46, 31, 52, 30, 54, 61, 28, 47, 48, 32, 47, 57,
+43, 53, 60, 39, 34, 60, 61, 51, 28, 30, 58, 49, 42, 26, 35, 18,
+61, 40, 27, 55, 56, 41, 51, 43, 61, 55, 46, 44, 29, 36, 33, 24,
+35, 43, 47, 41, 45, 23, 50, 56, 41, 50, 46, 33, 54, 32, 41, 21,
+50, 51, 59, 60, 45, 46, 50, 53, 52, 60, 55, 38, 49, 44, 59, 55,
+48, 51, 41, 52, 33, 46, 37, 29, 42, 43, 27, 43, 31, 32, 35, 41,
+25, 35, 27, 49, 32, 29, 20, 28, 39, 39, 40, 54, 33, 56, 23, 51,
+24, 55, 49, 42, 45, 57, 56, 47, 29, 19, 48, 45, 51, 32, 54, 47,
+56, 41, 39, 45, 36, 42, 51, 44, 48, 41, 34, 41, 47, 36, 56, 59,
+46, 52, 47, 46, 55, 23, 57, 45, 53, 23, 38, 20, 43, 35, 23, 55,
+41, 44, 40, 35, 47, 54, 35, 49, 48, 40, 35, 57, 43, 47, 52, 28,
+36, 25, 35, 21, 45, 56, 43, 45, 22, 56, 18, 20, 61, 21, 35, 47,
+27, 23, 21, 28, 41, 27, 21, 42, 24, 47, 40, 50, 24, 28, 28, 51,
+59, 57, 51, 31, 35, 54, 53, 33, 38, 72, 49, 60, 25, 36, 23, 29,
+28, 31, 52, 35, 51, 46, 46, 51, 36, 52, 34, 51, 33, 40, 29, 37,
+30, 58, 55, 27, 40, 24, 42, 59, 28, 22, 21, 37, 56, 35, 30, 26,
+27, 31, 54, 20, 35, 34, 51, 35, 37, 50, 51, 60, 36, 23, 46, 60,
+31, 28, 32, 23, 27, 56, 54, 46, 46, 31, 21, 46, 36, 51, 58, 34,
+59, 35, 27, 28, 54, 54, 48, 47, 23, 49, 57, 50, 24, 23, 51, 58,
+26, 49, 19, 51, 29, 23, 50, 59, 49, 60, 26, 25, 36, 47, 24, 36,
+47, 31, 53, 34, 36, 46, 40, 26, 24, 49, 19, 40, 33, 52, 48, 30,
+46, 54, 18, 55, 53, 47, 23, 53, 55, 56, 47, 41, 30, 45, 42, 41,
+46, 35, 51, 53, 18, 49, 52, 45, 26, 42, 43, 25, 18, 45, 55, 43,
+26, 47, 48, 31, 46, 49, 54, 36, 53, 51, 48, 59, 59, 23, 41, 22,
+25, 50, 69, 30, 23, 25, 26, 28, 24, 31, 23, 51, 29, 23, 44, 46,
+50, 25, 43, 33, 48, 39, 38, 37, 51, 35, 40, 49, 44, 41, 42, 31,
+54, 41, 45, 43, 40, 43, 34, 44, 44, 42, 58, 43, 53, 28, 47, 39,
+52, 30, 36, 41, 29, 37, 23, 35, 19, 29, 20, 37, 34, 37, 32, 54,
+33, 47, 46, 35, 27, 46, 21, 29, 37, 34, 37, 22, 46, 21, 26, 30,
+28, 27, 34, 51, 19, 40, 23, 26, 37, 53, 25, 55, 32, 28, 21, 43,
+23, 19, 37, 64, 25, 32, 17, 40, 22, 33, 30, 21, 36, 21, 30, 51,
+21, 27, 31, 28, 30, 37, 55, 45, 54, 57, 60, 50, 41, 54, 27, 48,
+40, 27, 56, 37, 38, 25, 26, 22, 18, 48, 56, 45, 54, 56, 37, 30,
+47, 26, 40, 51, 32, 39, 55, 48, 58, 41, 28, 24, 32, 48, 40, 44,
+40, 52, 51, 34, 34, 49, 57, 33, 53, 36, 29, 27, 28, 51, 23, 40,
+53, 45, 54, 52, 57, 49, 55, 36, 57, 44, 47, 45, 58, 39, 63, 47,
+27, 46, 45, 53, 32, 52, 55, 40, 34, 53, 50, 31, 46, 41, 52, 32,
+43, 52, 58, 19, 36, 57, 47, 54, 31, 39, 42, 32, 28, 39, 48, 27,
+52, 50, 58, 48, 32, 36, 37, 20, 37, 20, 24, 61, 33, 54, 30, 23,
+44, 59, 34, 43, 28, 37, 51, 27, 34, 39, 38, 37, 48, 37, 33, 39,
+46, 47, 34, 46, 26, 30, 30, 47, 62, 39, 50, 51, 35, 42, 42, 49,
+45, 29, 44, 43, 39, 44, 51, 42, 47, 55, 50, 25, 22, 27, 31, 39,
+47, 34, 54, 45, 33, 24, 41, 36, 28, 46, 21, 19, 47, 37, 39, 35,
+53, 41, 54, 51, 46, 57, 27, 58, 35, 43, 34, 37, 27, 33, 49, 27,
+48, 34, 17, 20, 48, 36, 40, 38, 46, 54, 18, 29, 26, 28, 17, 43,
+26, 21, 28, 21, 28, 47, 33, 18, 20, 17, 29, 27, 52, 58, 44, 35,
+24, 42, 39, 63, 30, 23, 30, 42, 35, 49, 33, 36, 45, 58, 38, 38,
+33, 24, 20, 55, 43, 26, 51, 49, 57, 47, 54, 54, 45, 39, 45, 25,
+34, 60, 32, 23, 29, 31, 34, 44, 49, 38, 40, 24, 51, 40, 30, 32,
+50, 44, 43, 24, 22, 33, 37, 43, 39, 55, 37, 35, 44, 36, 31, 44,
+34, 86, 43, 44, 29, 41, 36, 44, 46, 35, 58, 50, 25, 20, 50, 21,
+35, 47, 35, 31, 37, 37, 55, 39, 36, 27, 53, 28, 47, 34, 44, 42,
+19, 34, 45, 41, 39, 41, 38, 40, 41, 55, 58, 40, 36, 52, 42, 57,
+45, 33, 26, 35, 35, 32, 38, 41, 59, 21, 40, 49, 27, 40, 20, 46,
+34, 57, 23, 30, 32, 29, 27, 32, 54, 36, 30, 37, 33, 35, 35, 32,
+38, 27, 34, 34, 35, 30, 29, 20, 19, 39, 24, 51, 24, 45, 47, 45,
+42, 47, 44, 35, 48, 54, 51, 25, 37, 33, 33, 51, 66, 39, 24, 31,
+32, 58, 60, 46, 29, 47, 36, 34, 22, 25, 42, 29, 33, 24, 32, 23,
+22, 23, 36, 36, 35, 21, 20, 20, 29, 38, 26, 36, 30, 20, 59, 40,
+49, 42, 60, 41, 51, 62, 24, 30, 25, 35, 32, 29, 30, 32, 33, 29,
+38, 40, 31, 53, 29, 56, 24, 21, 33, 24, 41, 41, 32, 29, 49, 61,
+47, 60, 61, 57, 49, 54, 50, 34, 51, 51, 46, 46, 50, 50, 32, 58,
+48, 51, 45, 46, 37, 44, 38, 50, 51, 44, 47, 51, 43, 38, 31, 54,
+48, 27, 51, 56, 50, 40, 26, 28, 43, 53, 39, 52, 33, 46, 43, 42,
+29, 30, 25, 51, 55, 58, 33, 28, 56, 54, 43, 26, 44, 53, 42, 49,
+32, 43, 48, 52, 50, 29, 44, 43, 32, 52, 25, 53, 50, 36, 32, 35,
+57, 57, 38, 49, 53, 27, 50, 59, 63, 34, 41, 49, 60, 26, 54, 49,
+53, 57, 43, 57, 41, 58, 47, 42, 54, 57, 42, 26, 36, 23, 39, 46,
+54, 58, 40, 34, 43, 27, 50, 33, 20, 45, 49, 39, 46, 31, 53, 52,
+54, 40, 39, 39, 31, 49, 53, 58, 42, 20, 58, 46, 26, 27, 46, 29,
+34, 51, 23, 53, 35, 41, 51, 31, 40, 30, 23, 43, 37, 48, 31, 30,
+40, 35, 43, 61, 54, 41, 28, 32, 55, 28, 26, 30, 43, 38, 45, 21,
+60, 53, 31, 59, 23, 36, 40, 37, 44, 30, 21, 40, 37, 46, 36, 54,
+50, 52, 54, 45, 46, 39, 53, 42, 38, 38, 37, 49, 43, 44, 25, 43,
+51, 44, 49, 47, 46, 42, 43, 45, 32, 42, 20, 29, 20, 34, 34, 29,
+34, 45, 33, 31, 29, 49, 35, 38, 45, 44, 51, 33, 51, 36, 51, 29,
+47, 46, 40, 24, 51, 37, 30, 53, 38, 57, 19, 57, 42, 28, 55, 35,
+54, 39, 32, 31, 30, 49, 56, 34, 27, 26, 34, 47, 45, 47, 47, 46,
+39, 36, 52, 45, 49, 26, 44, 18, 31, 38, 27, 35, 28, 26, 43, 36,
+48, 27, 57, 33, 28, 39, 29, 44, 22, 54, 44, 54, 28, 46, 40, 27,
+44, 48, 22, 30, 39, 27, 43, 44, 36, 32, 28, 46, 37, 40, 42, 40,
+53, 36, 40, 36, 36, 43, 42, 33, 36, 58, 47, 35, 58, 40, 50, 31,
+40, 18, 44, 57, 41, 38, 43, 33, 50, 44, 42, 24, 24, 39, 31, 53,
+49, 51, 43, 47, 45, 29, 52, 59, 41, 29, 53, 19, 50, 22, 42, 59,
+51, 18, 20, 21, 23, 57, 37, 42, 36, 47, 20, 42, 53, 19, 46, 28,
+30, 30, 40, 37, 36, 23, 45, 52, 21, 60, 34, 30, 53, 32, 29, 56,
+43, 38, 38, 46, 58, 34, 53, 31, 30, 31, 39, 39, 30, 53, 34, 31,
+29, 33, 28, 28, 46, 43, 42, 26, 37, 36, 33, 40, 29, 32, 45, 28,
+54, 41, 48, 44, 45, 29, 31, 39, 43, 43, 29, 30, 21, 28, 20, 34,
+51, 40, 32, 27, 25, 27, 59, 55, 43, 33, 32, 33, 62, 45, 40, 48,
+28, 50, 36, 59, 36, 26, 23, 25, 53, 28, 33, 31, 31, 25, 24, 27,
+42, 40, 27, 49, 61, 50, 49, 63, 23, 28, 51, 32, 48, 45, 46, 28,
+54, 21, 57, 54, 43, 51, 55, 64, 34, 58, 41, 25, 52, 52, 50, 62,
+49, 54, 34, 55, 34, 29, 53, 56, 29, 28, 48, 32, 30, 51, 56, 43,
+55, 30, 52, 25, 52, 58, 45, 56, 59, 49, 40, 50, 30, 48, 46, 45,
+49, 26, 27, 54, 50, 53, 50, 32, 28, 39, 19, 22, 39, 52, 42, 24,
+53, 29, 58, 54, 35, 58, 34, 41, 26, 46, 27, 38, 56, 32, 44, 41,
+32, 23, 43, 54, 21, 60, 34, 47, 43, 39, 52, 21, 45, 41, 56, 28,
+58, 49, 30, 51, 24, 30, 47, 61, 29, 26, 38, 54, 25, 37, 41, 58,
+53, 54, 37, 36, 47, 39, 51, 44, 35, 19, 56, 44, 40, 32, 30, 21,
+30, 32, 43, 56, 46, 32, 52, 28, 43, 50, 27, 58, 55, 35, 43, 54,
+32, 37, 46, 23, 48, 60, 29, 43, 24, 24, 39, 40, 52, 47, 53, 51,
+35, 52, 26, 52, 33, 47, 24, 34, 47, 36, 40, 37, 45, 33, 31, 31,
+55, 50, 61, 44, 33, 51, 41, 34, 61, 50, 55, 52, 61, 39, 63, 51,
+57, 28, 45, 54, 45, 20, 52, 39, 37, 51, 35, 34, 57, 37, 58, 32,
+55, 50, 42, 24, 35, 58, 49, 22, 30, 40, 22, 20, 56, 36, 45, 20,
+47, 30, 36, 56, 42, 45, 54, 57, 52, 31, 44, 31, 32, 59, 36, 58,
+33, 31, 43, 42, 56, 35, 52, 48, 37, 35, 39, 39, 44, 23, 48, 26,
+45, 48, 31, 30, 32, 46, 36, 44, 41, 35, 44, 21, 39, 48, 28, 34,
+31, 29, 49, 31, 21, 40, 38, 39, 27, 25, 39, 51, 31, 38, 33, 31,
+41, 37, 39, 29, 55, 26, 34, 23, 45, 39, 34, 35, 24, 31, 30, 29,
+45, 33, 37, 45, 37, 51, 30, 32, 46, 28, 38, 43, 38, 52, 29, 28,
+46, 43, 39, 41, 35, 35, 48, 48, 39, 42, 38, 37, 26, 57, 40, 32,
+35, 47, 24, 49, 39, 40, 47, 33, 33, 40, 32, 32, 32, 38, 29, 28,
+30, 44, 32, 43, 47, 37, 33, 49, 30, 39, 44, 31, 51, 57, 22, 27,
+36, 26, 34, 34, 29, 45, 33, 49, 37, 30, 33, 32, 43, 45, 29, 43,
+27, 35, 43, 40, 48, 35, 33, 44, 51, 25, 41, 59, 43, 51, 42, 38,
+47, 41, 44, 42, 40, 45, 27, 34, 48, 43, 29, 47, 30, 38, 28, 51,
+51, 26, 38, 37, 49, 30, 38, 40, 39, 45, 41, 31, 36, 32, 38, 33,
+32, 33, 34, 36, 35, 43, 39, 45, 38, 54, 39, 32, 36, 28, 40, 44,
+40, 32, 43, 34, 31, 34, 51, 34, 38, 43, 52, 41, 49, 35, 39, 51,
+47, 36, 35, 29, 49, 36, 36, 37, 32, 31, 50, 18, 44, 37, 39, 50,
+59, 24, 36, 27, 48, 31, 51, 30, 33, 32, 46, 48, 24, 53, 38, 43,
+35, 47, 31, 45, 41, 41, 31, 45, 38, 48, 18, 40, 23, 57, 48, 30,
+32, 32, 49, 33, 33, 34, 31, 35, 38, 46, 41, 29, 51, 45, 40, 36,
+24, 39, 40, 44, 52, 35, 55, 47, 36, 49, 43, 42, 19, 33, 26, 50,
+56, 40, 38, 30, 32, 34, 50, 44, 37, 54, 46, 36, 51, 41, 47, 47,
+36, 42, 45, 47, 41, 59, 46, 46, 56, 40, 43, 51, 31, 35, 60, 45,
+30, 24, 44, 34, 48, 58, 25, 59, 45, 41, 54, 58, 33, 31, 33, 46,
+35, 47, 48, 56, 34, 35, 24, 41, 24, 40, 24, 21, 49, 49, 45, 47,
+38, 41, 19, 21, 27, 23, 47, 23, 43, 27, 35, 22, 24, 27, 41, 38,
+38, 35, 44, 36, 23, 45, 38, 38, 35, 45, 33, 29, 30, 32, 54, 41,
+43, 48, 43, 35, 29, 43, 24, 34, 46, 46, 28, 35, 30, 42, 53, 41,
+50, 46, 47, 30, 54, 32, 33, 32, 55, 25, 53, 36, 46, 32, 45, 44,
+46, 44, 55, 41, 59, 39, 40, 23, 41, 35, 34, 46, 58, 52, 59, 55,
+53, 48, 43, 34, 55, 19, 42, 43, 56, 29, 35, 44, 29, 23, 23, 57,
+31, 38, 28, 25, 44, 26, 59, 33, 29, 34, 53, 50, 55, 44, 28, 25,
+32, 33, 27, 30, 46, 38, 40, 40, 46, 48, 24, 51, 38, 32, 54, 34,
+17, 37, 32, 45, 55, 31, 29, 26, 31, 55, 57, 40, 33, 46, 38, 30,
+62, 23, 30, 30, 59, 63, 35, 37, 25, 39, 42, 39, 47, 46, 26, 60,
+36, 29, 34, 42, 46, 39, 24, 31, 44, 27, 41, 51, 51, 22, 58, 41,
+39, 37, 33, 66, 35, 37, 48, 60, 40, 39, 31, 49, 60, 22, 21, 37,
+44, 39, 48, 38, 65, 36, 56, 36, 31, 36, 33, 35, 43, 40, 32, 21,
+26, 38, 31, 32, 46, 41, 34, 44, 44, 35, 31, 44, 40, 29, 33, 55,
+39, 20, 40, 29, 27, 35, 35, 33, 38, 42, 45, 44, 30, 51, 35, 21,
+22, 34, 55, 34, 18, 23, 41, 36, 35, 20, 53, 57, 35, 55, 22, 35,
+39, 37, 39, 32, 46, 29, 37, 34, 40, 54, 31, 23, 34, 36, 28, 34,
+33, 30, 35, 27, 20, 19, 48, 56, 45, 35, 56, 19, 20, 37, 22, 36,
+42, 19, 35, 35, 51, 45, 55, 45, 32, 48, 39, 54, 29, 16, 17, 44,
+60, 28, 18, 36, 24, 24, 25, 56, 41, 21, 22, 31, 42, 42, 35, 45,
+50, 52, 48, 54, 58, 52, 53, 48, 56, 40, 59, 29, 54, 30, 51, 28,
+41, 44, 50, 40, 47, 38, 34, 42, 44, 23, 27, 40, 29, 39, 28, 54,
+48, 52, 23, 52, 33, 46, 45, 48, 45, 41, 47, 36, 37, 45, 47, 47,
+37, 43, 33, 28, 32, 29, 48, 44, 31, 45, 39, 32, 45, 59, 31, 59,
+42, 37, 42, 47, 38, 21, 41, 40, 28, 20, 38, 28, 37, 36, 37, 37,
+45, 39, 25, 47, 55, 40, 36, 34, 36, 34, 54, 20, 20, 54, 44, 29,
+26, 20, 37, 24, 56, 45, 57, 53, 56, 30, 55, 23, 45, 37, 51, 54,
+55, 44, 26, 57, 40, 64, 17, 21, 29, 26, 32, 49, 36, 57, 34, 34,
+38, 51, 32, 49, 40, 61, 46, 50, 45, 19, 51, 27, 46, 59, 33, 46,
+30, 44, 35, 31, 41, 37, 25, 54, 43, 36, 45, 42, 33, 50, 45, 50,
+52, 53, 33, 26, 39, 45, 39, 29, 40, 41, 49, 26, 34, 41, 48, 42,
+41, 43, 30, 31, 43, 42, 45, 44, 22, 36, 50, 26, 40, 35, 40, 31,
+33, 36, 39, 28, 25, 40, 31, 44, 26, 54, 36, 22, 33, 22, 35, 42,
+43, 53, 46, 45, 40, 33, 42, 44, 58, 46, 52, 63, 32, 55, 21, 41,
+21, 20, 39, 37, 44, 29, 31, 40, 33, 33, 50, 52, 37, 43, 51, 23,
+24, 23, 23, 28, 42, 42, 52, 56, 56, 44, 24, 53, 25, 49, 44, 41,
+23, 39, 43, 49, 41, 48, 29, 55, 39, 27, 36, 21, 44, 28, 47, 44,
+42, 35, 41, 32, 31, 20, 47, 30, 37, 56, 50, 43, 58, 32, 56, 28,
+26, 25, 50, 42, 21, 45, 21, 20, 53, 43, 38, 56, 40, 25, 50, 34,
+52, 45, 29, 51, 29, 34, 43, 35, 44, 42, 42, 23, 45, 53, 49, 30,
+25, 22, 57, 28, 33, 32, 49, 30, 26, 22, 37, 51, 56, 58, 48, 23,
+38, 26, 36, 48, 58, 48, 39, 48, 35, 55, 52, 37, 42, 47, 33, 25,
+50, 35, 33, 50, 48, 44, 37, 60, 21, 20, 23, 22, 30, 33, 35, 50,
+31, 35, 33, 25, 22, 38, 20, 52, 44, 29, 42, 45, 20, 29, 51, 39,
+37, 46, 33, 43, 27, 39, 46, 46, 49, 20, 46, 41, 20, 23, 23, 32,
+30, 23, 50, 34, 31, 20, 34, 24, 33, 54, 23, 33, 48, 31, 58, 37,
+23, 38, 57, 50, 58, 53, 26, 32, 48, 41, 59, 29, 33, 32, 45, 24,
+33, 20, 23, 54, 56, 30, 21, 22, 53, 24, 29, 23, 48, 51, 27, 26,
+28, 48, 58, 57, 29, 48, 44, 54, 22, 34, 48, 30, 55, 34, 22, 55,
+42, 58, 24, 33, 22, 33, 56, 55, 59, 45, 21, 52, 22, 35, 35, 52,
+47, 48, 51, 33, 38, 53, 49, 28, 46, 54, 26, 38, 36, 35, 28, 40,
+44, 30, 33, 44, 41, 22, 34, 33, 51, 21, 41, 30, 57, 32, 21, 47,
+24, 63, 21, 47, 29, 50, 48, 40, 54, 54, 56, 51, 36, 37, 21, 48,
+44, 47, 55, 44, 30, 28, 23, 25, 50, 55, 36, 48, 37, 34, 38, 36,
+43, 30, 36, 50, 50, 26, 25, 30, 26, 33, 36, 43, 33, 47, 37, 54,
+32, 19, 33, 45, 19, 45, 44, 30, 60, 42, 35, 31, 35, 34, 40, 61,
+32, 49, 44, 42, 41, 47, 41, 54, 29, 33, 27, 36, 32, 46, 41, 52,
+51, 40, 49, 24, 34, 55, 43, 47, 57, 62, 38, 63, 25, 41, 31, 48,
+42, 51, 30, 37, 58, 36, 35, 24, 46, 45, 46, 58, 17, 31, 29, 60,
+44, 25, 42, 54, 18, 56, 34, 34, 39, 48, 33, 40, 34, 45, 31, 52,
+34, 59, 43, 45, 34, 42, 41, 59, 36, 38, 36, 50, 51, 55, 29, 24,
+41, 59, 28, 51, 33, 31, 52, 45, 44, 42, 46, 38, 37, 40, 52, 40,
+33, 32, 49, 34, 32, 35, 56, 23, 41, 23, 39, 65, 24, 36, 33, 28,
+45, 66, 51, 44, 35, 47, 27, 44, 36, 31, 59, 50, 47, 37, 28, 50,
+40, 43, 45, 20, 40, 56, 33, 29, 59, 32, 45, 38, 43, 46, 40, 29,
+39, 42, 42, 32, 35, 46, 35, 50, 22, 30, 30, 36, 42, 34, 29, 52,
+28, 41, 38, 40, 51, 43, 36, 19, 29, 54, 37, 33, 43, 59, 35, 43,
+28, 38, 58, 46, 55, 26, 59, 33, 34, 38, 28, 53, 26, 26, 33, 28,
+24, 32, 27, 52, 22, 38, 35, 39, 39, 33, 34, 21, 53, 34, 44, 33,
+28, 56, 57, 52, 46, 46, 20, 53, 41, 35, 46, 55, 35, 50, 56, 47,
+23, 52, 24, 53, 28, 19, 49, 27, 37, 37, 41, 32, 47, 44, 36, 52,
+38, 44, 47, 33, 58, 29, 48, 37, 50, 53, 55, 32, 26, 60, 58, 23,
+32, 30, 45, 46, 59, 45, 54, 36, 29, 44, 20, 36, 32, 60, 42, 59,
+35, 24, 21, 22, 32, 37, 23, 52, 45, 21, 34, 44, 48, 26, 30, 47,
+24, 33, 25, 38, 42, 41, 33, 30, 45, 36, 42, 36, 45, 34, 52, 53,
+25, 44, 53, 45, 31, 23, 52, 35, 45, 31, 42, 26, 43, 47, 31, 48,
+41, 42, 24, 48, 40, 36, 45, 52, 29, 52, 52, 34, 45, 47, 26, 26,
+48, 32, 26, 48, 37, 27, 38, 59, 20, 55, 50, 52, 32, 45, 42, 62,
+33, 24, 22, 35, 32, 22, 27, 40, 60, 53, 35, 40, 39, 28, 49, 23,
+53, 20, 35, 50, 32, 40, 31, 26, 56, 36, 25, 47, 45, 30, 37, 55,
+86, 36, 48, 37, 57, 44, 49, 22, 54, 50, 48, 25, 26, 23, 40, 35,
+53, 51, 42, 50, 54, 48, 54, 37, 45, 55, 46, 36, 44, 52, 43, 34,
+43, 38, 36, 25, 27, 19, 37, 42, 36, 51, 39, 37, 46, 35, 43, 46,
+37, 39, 36, 21, 26, 50, 36, 20, 34, 43, 20, 47, 24, 38, 58, 43,
+39, 29, 45, 26, 26, 46, 28, 34, 35, 27, 37, 28, 28, 29, 30, 30,
+27, 23, 35, 46, 45, 88, 47, 42, 37, 24, 32, 28, 40, 27, 50, 34,
+36, 30, 41, 50, 22, 19, 21, 36, 31, 57, 42, 32, 28, 88, 25, 34,
+57, 54, 49, 56, 37, 40, 27, 23, 57, 46, 35, 38, 29, 59, 49, 26,
+26, 29, 27, 35, 32, 38, 32, 41, 26, 30, 36, 40, 28, 24, 47, 41,
+40, 34, 23, 35, 60, 40, 34, 47, 30, 42, 28), ethnicity = structure(c(1L,
+1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L,
+1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L,
+1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L,
+1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L,
+1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L,
+1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L,
+1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L,
+1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L,
+1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L,
+1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L,
+1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L,
+1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L,
+1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L,
+1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L,
+1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L,
+1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L,
+1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L,
+1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L,
+1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L,
+1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L,
+1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L,
+1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L,
+1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L,
+1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L,
+1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L,
+1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L,
+1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L,
+1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L,
+1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L,
+1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L,
+1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L,
+1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L,
+1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L,
+1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L,
+1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L,
+1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L,
+1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L,
+1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L,
+1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L,
+1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L,
+1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L,
+1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L,
+1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L,
+1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L,
+1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L,
+1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L,
+1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L,
+1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L,
+1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L,
+1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L,
+1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L,
+1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L,
+1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L,
+1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L,
+1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L,
+1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L,
+1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L,
+1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L,
+1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L,
+1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L,
+1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L,
+1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L,
+1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L,
+1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L,
+1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L,
+1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L,
+1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L,
+1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L,
+1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L,
+1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L,
+1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L,
+1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L,
+1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L,
+1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L,
+1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L,
+1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L,
+1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L,
+1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L,
+1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L,
+1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L,
+1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L,
+1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L,
+1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L,
+1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L,
+1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L,
+1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L,
+1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L,
+1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L,
+1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L,
+1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L,
+1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L,
+1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L,
+1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L,
+1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L,
+1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L,
+1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L,
+1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L,
+1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L,
+1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L,
+1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L,
+1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L,
+1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L,
+1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L,
+1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L,
+1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L,
+1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L,
+1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L,
+1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L,
+1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L,
+1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L,
+1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L,
+1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L,
+1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L,
+1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L,
+1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L,
+1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L,
+1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L,
+1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L,
+1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L,
+1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L,
+1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L,
+1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L,
+1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L,
+1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L,
+1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L,
+1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L,
+1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L,
+1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L,
+1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L,
+1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L,
+1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L,
+1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L,
+1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L,
+1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L,
+1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L,
+1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L,
+1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L,
+1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L,
+1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L,
+1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L,
+1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L,
+1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L,
+1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L,
+1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L,
+1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L,
+1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L,
+1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L,
+1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L,
+1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L,
+1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L,
+1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L,
+1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L,
+1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L,
+1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L,
+1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L,
+1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L,
+1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L,
+1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L,
+1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L,
+1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L,
+1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L,
+1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L,
+1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L,
+1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L,
+1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L,
+1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L,
+1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L,
+1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L,
+1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L,
+1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L,
+1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L,
+1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L,
+1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L,
+1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L,
+1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L,
+1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L,
+1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L,
+1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L,
+1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L,
+1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L,
+1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L,
+1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L,
+1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L,
+1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L,
+1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L,
+1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L,
+1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L,
+1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L,
+1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L,
+1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L,
+1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L,
+1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L,
+1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L,
+1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L,
+1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L,
+1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L,
+1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L,
+1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L,
+1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L,
+1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L,
+1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L,
+1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L,
+1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L,
+1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L,
+1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L,
+1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L,
+1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L,
+1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L,
+1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L,
+1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L,
+1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L,
+1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L,
+1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L,
+1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L,
+1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L,
+1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L,
+1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L,
+1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L,
+1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L,
+1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L,
+1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L,
+1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L,
+1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L,
+1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L,
+1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L,
+1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L,
+1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L,
+1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L,
+1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L,
+1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L,
+1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L,
+1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L,
+1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L,
+1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L,
+1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L,
+1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L,
+1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L,
+1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L,
+1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L,
+1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L,
+1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L,
+1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L,
+1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L,
+1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L,
+1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L,
+1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L,
+1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L,
+1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L,
+1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L,
+1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L,
+1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L,
+1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L,
+1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L,
+1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L,
+1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L,
+1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L,
+1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L,
+1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L,
+1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L,
+1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L,
+1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L,
+1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L,
+1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L,
+1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L,
+1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L,
+1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L,
+1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L,
+1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L,
+1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L,
+1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L,
+1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L,
+1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L,
+1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L,
+1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L,
+1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L,
+1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L,
+1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L,
+1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L,
+1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L,
+1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L,
+1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L,
+1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L,
+1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L,
+1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L,
+1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L,
+1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L,
+1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L,
+1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L,
+1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L,
+1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L,
+1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L,
+1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L,
+1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L,
+1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L,
+1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L,
+1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L,
+1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L,
+1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L,
+1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L,
+1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L,
+1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L,
+1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L,
+1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L,
+1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L,
+1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L,
+1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L,
+1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L,
+1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L,
+1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L,
+1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L,
+1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L,
+1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L,
+1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L,
+1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L,
+1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L,
+1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L,
+1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L,
+1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L,
+1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L,
+1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L,
+1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L,
+1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L,
+1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L,
+1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L,
+1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L,
+1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L,
+1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L,
+1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L,
+1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L,
+1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L,
+1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L,
+1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L,
+1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L,
+1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L,
+1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L,
+1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L,
+1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L,
+1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L,
+1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L,
+1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L,
+1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L,
+1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L,
+1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L,
+1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L,
+1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L,
+1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L,
+1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L,
+1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L,
+1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L,
+1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L,
+1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L,
+1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L,
+1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L,
+1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L,
+1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L,
+1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L,
+1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L,
+1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L,
+1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L,
+1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L,
+1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L,
+1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L,
+1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L,
+1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L,
+1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L,
+1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L,
+1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L,
+1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L,
+1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L,
+1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L,
+1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L,
+1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L,
+1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L,
+1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L,
+1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L,
+1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L,
+1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L,
+1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L,
+1L, 1L, 1L, 1L), .Label = c("European", "Maori", "Other", "Polynesian"
+), class = "factor"), mstatus = structure(c(3L, 2L, 2L, 1L, 2L,
+3L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 3L, 2L, 2L, 2L, 2L,
+3L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 4L, 2L, 2L, 2L, 3L, 2L, 2L, 2L,
+2L, 2L, 1L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 3L, 2L, 2L, 3L, 2L, 2L,
+3L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 3L, 2L, 1L, 2L, 2L, 2L, 2L,
+2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 1L, 2L, 1L,
+2L, 2L, 2L, 1L, 3L, 2L, 3L, 2L, 3L, 2L, 2L, 2L, 2L, 3L, 2L, 3L,
+2L, 2L, 2L, 2L, 2L, 3L, 2L, 2L, 2L, 4L, 2L, 1L, 2L, 3L, 1L, 2L,
+2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 3L, 2L, 2L, 2L, 2L, 2L, 2L,
+2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 1L, 2L, 2L,
+2L, 2L, 2L, 2L, 2L, 2L, 2L, 3L, 3L, 2L, 2L, 2L, 2L, 2L, 2L, 2L,
+2L, 2L, 2L, 1L, 2L, 2L, 1L, 2L, 2L, 3L, 2L, 3L, 2L, 2L, 2L, 3L,
+3L, 2L, 2L, 2L, 2L, 3L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L,
+2L, 2L, 2L, 2L, 3L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 3L, 2L, 2L, 1L,
+2L, 2L, 2L, 2L, 2L, 2L, 3L, 2L, 2L, 2L, 2L, 2L, 3L, 2L, 2L, 2L,
+2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 3L, 1L, 3L, 2L, 2L, 2L, 2L, 2L,
+2L, 2L, 2L, 2L, 2L, 2L, 3L, 2L, 2L, 2L, 3L, 2L, 2L, 2L, 2L, 2L,
+2L, 2L, 2L, 2L, 2L, 2L, 3L, 3L, 2L, 2L, 2L, 2L, 2L, 3L, 2L, 1L,
+2L, 2L, 3L, 3L, 2L, 2L, 2L, 2L, 2L, 1L, 1L, 2L, 2L, 2L, 2L, 1L,
+2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 1L, 2L, 2L,
+1L, 1L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 3L,
+2L, 3L, 3L, 2L, 2L, 3L, 2L, 2L, 2L, 2L, 3L, 2L, 2L, 2L, 2L, 2L,
+2L, 3L, 2L, 2L, 2L, 2L, 2L, 2L, 1L, 2L, 3L, 2L, 2L, 2L, 2L, 2L,
+2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 1L, 2L, 1L, 2L, 1L, 2L, 2L, 2L,
+2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 3L, 1L, 2L, 2L, 2L, 2L, 2L, 2L,
+2L, 2L, 2L, 2L, 1L, 2L, 2L, 2L, 2L, 1L, 2L, 2L, 2L, 2L, 2L, 1L,
+3L, 2L, 3L, 3L, 2L, 2L, 3L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 1L,
+2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 3L, 2L, 2L, 2L, 2L, 2L,
+2L, 2L, 2L, 2L, 2L, 2L, 3L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L,
+2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 3L, 3L, 4L, 2L, 3L, 3L, 2L, 1L,
+3L, 2L, 3L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L,
+2L, 3L, 2L, 2L, 2L, 2L, 3L, 2L, 2L, 3L, 2L, 2L, 3L, 3L, 2L, 3L,
+2L, 2L, 2L, 2L, 2L, 2L, 2L, 3L, 3L, 2L, 2L, 3L, 3L, 2L, 3L, 2L,
+2L, 2L, 2L, 3L, 2L, 3L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L,
+2L, 2L, 2L, 2L, 2L, 1L, 2L, 2L, 2L, 2L, 2L, 2L, 3L, 2L, 2L, 2L,
+2L, 2L, 3L, 3L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L,
+1L, 2L, 2L, 2L, 2L, 1L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 3L,
+2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L,
+2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 1L, 2L, 2L, 2L, 2L, 3L, 2L, 2L,
+2L, 2L, 3L, 2L, 2L, 2L, 2L, 2L, 2L, 1L, 2L, 2L, 2L, 2L, 2L, 2L,
+2L, 3L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L,
+2L, 2L, 2L, 2L, 3L, 3L, 1L, 2L, 2L, 2L, 2L, 2L, 3L, 3L, 2L, 2L,
+2L, 1L, 2L, 2L, 2L, 2L, 2L, 2L, 3L, 2L, 3L, 2L, 3L, 2L, 3L, 2L,
+1L, 2L, 2L, 3L, 2L, 2L, 3L, 2L, 2L, 2L, 2L, 2L, 3L, 2L, 2L, 2L,
+2L, 2L, 3L, 3L, 2L, 2L, 3L, 3L, 3L, 3L, 3L, 3L, 2L, 2L, 3L, 2L,
+2L, 2L, 2L, 2L, 3L, 3L, 2L, 2L, 2L, 3L, 3L, 2L, 2L, 2L, 2L, 2L,
+3L, 3L, 2L, 1L, 3L, 2L, 2L, 2L, 2L, 3L, 2L, 3L, 3L, 2L, 2L, 1L,
+3L, 2L, 2L, 2L, 3L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 3L, 2L,
+3L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L,
+2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L,
+2L, 2L, 2L, 2L, 2L, 2L, 2L, 3L, 2L, 2L, 2L, 3L, 2L, 2L, 2L, 2L,
+3L, 2L, 1L, 2L, 1L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 3L, 2L,
+2L, 2L, 3L, 2L, 3L, 2L, 2L, 2L, 1L, 2L, 1L, 2L, 2L, 2L, 2L, 3L,
+2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 1L, 2L, 4L, 2L, 2L, 2L,
+1L, 2L, 2L, 2L, 4L, 2L, 3L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 4L,
+3L, 2L, 2L, 2L, 1L, 2L, 2L, 3L, 2L, 2L, 2L, 3L, 3L, 3L, 2L, 2L,
+2L, 3L, 2L, 2L, 3L, 2L, 2L, 1L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L,
+2L, 2L, 2L, 3L, 2L, 3L, 2L, 3L, 2L, 2L, 2L, 1L, 2L, 2L, 1L, 2L,
+1L, 3L, 4L, 2L, 2L, 2L, 2L, 1L, 2L, 2L, 2L, 2L, 2L, 2L, 3L, 2L,
+2L, 2L, 3L, 3L, 2L, 2L, 2L, 3L, 2L, 3L, 2L, 1L, 2L, 2L, 2L, 2L,
+2L, 2L, 2L, 2L, 2L, 3L, 2L, 2L, 2L, 2L, 3L, 3L, 2L, 2L, 3L, 3L,
+2L, 2L, 2L, 2L, 2L, 2L, 3L, 2L, 2L, 2L, 2L, 3L, 2L, 1L, 2L, 2L,
+2L, 3L, 3L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 4L, 2L, 2L, 2L, 3L,
+2L, 3L, 2L, 2L, 2L, 3L, 2L, 2L, 2L, 2L, 2L, 2L, 3L, 2L, 2L, 2L,
+2L, 3L, 2L, 3L, 2L, 3L, 2L, 2L, 2L, 3L, 2L, 2L, 2L, 2L, 2L, 2L,
+2L, 3L, 2L, 2L, 3L, 2L, 1L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L,
+2L, 2L, 2L, 1L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L,
+2L, 2L, 2L, 2L, 2L, 3L, 3L, 2L, 2L, 2L, 2L, 2L, 3L, 2L, 3L, 2L,
+2L, 2L, 2L, 2L, 3L, 2L, 2L, 2L, 2L, 2L, 2L, 1L, 2L, 2L, 3L, 2L,
+2L, 2L, 2L, 3L, 3L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L,
+2L, 2L, 2L, 1L, 2L, 2L, 3L, 1L, 3L, 2L, 2L, 2L, 2L, 2L, 3L, 2L,
+2L, 4L, 2L, 2L, 2L, 2L, 2L, 3L, 2L, 2L, 3L, 2L, 3L, 2L, 2L, 2L,
+2L, 2L, 2L, 3L, 2L, 2L, 2L, 3L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L,
+3L, 2L, 2L, 2L, 3L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L,
+2L, 1L, 2L, 2L, 2L, 1L, 2L, 3L, 2L, 3L, 2L, 3L, 3L, 2L, 2L, 2L,
+3L, 2L, 2L, 2L, 4L, 2L, 2L, 3L, 2L, 2L, 2L, 2L, 2L, 2L, 3L, 3L,
+2L, 2L, 3L, 2L, 2L, 3L, 3L, 2L, 2L, 2L, 3L, 2L, 2L, 2L, 2L, 2L,
+1L, 2L, 2L, 2L, 2L, 3L, 2L, 2L, 2L, 3L, 2L, 2L, 2L, 2L, 2L, 3L,
+3L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 3L, 2L, 2L, 2L, 2L, 1L, 2L, 2L,
+2L, 1L, 3L, 3L, 2L, 2L, 2L, 2L, 2L, 2L, 1L, 3L, 2L, 2L, 2L, 2L,
+2L, 2L, 2L, 3L, 1L, 2L, 3L, 1L, 2L, 1L, 2L, 1L, 2L, 2L, 3L, 2L,
+2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 3L, 2L, 2L, 2L, 2L, 1L, 2L, 3L,
+2L, 3L, 2L, 2L, 1L, 2L, 3L, 2L, 2L, 2L, 4L, 2L, 2L, 2L, 2L, 2L,
+2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L,
+1L, 2L, 2L, 2L, 2L, 3L, 2L, 2L, 2L, 3L, 2L, 2L, 2L, 3L, 2L, 2L,
+3L, 2L, 2L, 2L, 2L, 2L, 2L, 3L, 2L, 2L, 2L, 2L, 2L, 3L, 2L, 2L,
+2L, 2L, 3L, 4L, 2L, 2L, 1L, 2L, 2L, 2L, 2L, 4L, 2L, 2L, 2L, 2L,
+2L, 2L, 2L, 2L, 2L, 2L, 1L, 2L, 2L, 2L, 2L, 2L, 2L, 1L, 2L, 2L,
+2L, 2L, 4L, 2L, 2L, 2L, 2L, 2L, 3L, 2L, 2L, 2L, 2L, 2L, 2L, 2L,
+1L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 1L, 2L, 2L, 2L, 2L, 2L, 2L, 2L,
+2L, 1L, 2L, 2L, 2L, 2L, 1L, 1L, 4L, 2L, 2L, 2L, 2L, 2L, 2L, 2L,
+2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 1L, 2L, 2L, 4L, 2L, 1L, 3L,
+2L, 2L, 1L, 2L, 2L, 2L, 4L, 2L, 4L, 2L, 2L, 2L, 2L, 2L, 3L, 2L,
+2L, 2L, 1L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L,
+2L, 2L, 3L, 2L, 2L, 2L, 2L, 2L, 1L, 2L, 2L, 2L, 1L, 2L, 2L, 2L,
+1L, 2L, 2L, 2L, 2L, 2L, 3L, 2L, 2L, 2L, 1L, 2L, 2L, 2L, 2L, 2L,
+2L, 2L, 2L, 1L, 2L, 4L, 2L, 2L, 2L, 2L, 2L, 2L, 3L, 2L, 4L, 2L,
+2L, 2L, 2L, 1L, 2L, 2L, 2L, 3L, 2L, 4L, 2L, 4L, 2L, 1L, 1L, 2L,
+2L, 2L, 1L, 2L, 2L, 2L, 3L, 1L, 2L, 2L, 3L, 2L, 2L, 2L, 4L, 2L,
+2L, 2L, 2L, 2L, 4L, 2L, 2L, 2L, 3L, 2L, 3L, 2L, 2L, 2L, 2L, 3L,
+2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 1L, 2L, 2L, 2L, 2L,
+3L, 3L, 2L, 2L, 2L, 2L, 2L, 4L, 1L, 2L, 2L, 2L, 2L, 2L, 1L, 2L,
+2L, 2L, 2L, 2L, 3L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L,
+2L, 2L, 2L, 2L, 2L, 3L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L,
+2L, 2L, 2L, 2L, 1L, 3L, 2L, 2L, 2L, 2L, 3L, 2L, 2L, 2L, 2L, 2L,
+4L, 4L, 2L, 2L, 2L, 3L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 1L, 2L,
+2L, 2L, 2L, 2L, 4L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L,
+2L, 4L, 2L, 2L, 2L, 2L, 2L, 1L, 2L, 2L, 2L, 2L, 2L, 2L, 4L, 2L,
+2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 4L, 2L, 2L, 1L, 2L, 2L, 1L, 2L,
+2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 1L, 2L, 2L, 4L, 4L, 2L,
+2L, 2L, 2L, 2L, 2L, 2L, 1L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L,
+2L, 2L, 1L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 3L, 2L, 2L, 2L, 2L, 2L,
+2L, 2L, 2L, 2L, 2L, 2L, 1L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L,
+2L, 2L, 4L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L,
+2L, 2L, 2L, 2L, 2L, 2L, 1L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 1L,
+2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 1L, 3L, 3L, 2L, 2L, 2L, 2L,
+2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L,
+2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L,
+2L, 2L, 4L, 2L, 2L, 2L, 2L, 2L, 2L, 1L, 2L, 1L, 2L, 2L, 2L, 2L,
+2L, 2L, 2L, 2L, 3L, 4L, 2L, 4L, 4L, 2L, 2L, 1L, 2L, 2L, 2L, 4L,
+2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L,
+2L, 2L, 2L, 1L, 1L, 4L, 2L, 2L, 4L, 2L, 2L, 3L, 1L, 2L, 2L, 2L,
+1L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 4L, 2L, 2L, 2L, 2L,
+4L, 2L, 2L, 2L, 2L, 2L, 1L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 3L, 2L,
+2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 3L, 2L, 2L, 2L, 2L, 2L, 2L, 2L,
+2L, 1L, 2L, 2L, 3L, 2L, 2L, 2L, 2L, 2L, 4L, 2L, 2L, 2L, 3L, 3L,
+2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L,
+2L, 1L, 1L, 2L, 1L, 2L, 2L, 2L, 1L, 2L, 2L, 2L, 2L, 2L, 2L, 2L,
+2L, 2L, 2L, 4L, 2L, 1L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L,
+2L, 1L, 2L, 2L, 2L, 4L, 2L, 2L, 2L, 2L, 4L, 2L, 2L, 2L, 2L, 2L,
+4L, 2L, 2L, 1L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 4L, 2L, 2L, 3L, 2L,
+2L, 2L, 4L, 2L, 2L, 2L, 2L, 2L, 4L, 2L, 2L, 2L, 2L, 2L, 2L, 2L,
+2L, 2L, 2L, 4L, 2L, 2L, 2L, 2L, 3L, 2L, 2L, 2L, 2L, 2L, 2L, 2L,
+1L, 2L, 2L, 2L, 2L, 2L, 1L, 2L, 2L, 2L, 2L, 4L, 1L, 1L, 2L, 2L,
+1L, 4L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 3L, 2L, 2L, 2L, 4L,
+2L, 2L, 2L, 1L, 2L, 2L, 1L, 3L, 2L, 2L, 2L, 2L, 2L, 2L, 4L, 2L,
+2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L,
+2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 4L, 4L, 2L, 2L, 2L, 2L,
+4L, 1L, 4L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 3L, 2L, 2L, 2L, 2L, 2L,
+2L, 3L, 1L, 2L, 4L, 2L, 1L, 2L, 1L, 2L, 2L, 2L, 2L, 2L, 2L, 2L,
+2L, 2L, 2L, 2L, 2L, 2L, 2L, 4L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L,
+1L, 2L, 2L, 2L, 2L, 2L, 2L, 3L, 2L, 2L, 3L, 1L, 2L, 2L, 4L, 2L,
+4L, 2L, 2L, 2L, 4L, 2L, 2L, 4L, 2L, 2L, 2L, 2L, 2L, 2L, 1L, 3L,
+2L, 2L, 2L, 2L, 2L, 2L, 2L, 4L, 2L, 4L, 2L, 4L, 2L, 2L, 2L, 2L,
+2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 4L, 2L, 4L, 2L, 2L, 4L, 2L,
+2L, 2L, 2L, 2L, 2L, 3L, 4L, 2L, 2L, 4L, 1L, 1L, 2L, 2L, 2L, 2L,
+2L, 2L, 2L, 2L, 1L, 2L, 2L, 3L, 2L, 2L, 2L, 1L, 2L, 2L, 2L, 2L,
+2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 1L, 2L, 2L, 2L, 2L, 4L, 2L,
+2L, 2L, 2L, 1L, 2L, 2L, 1L, 2L, 4L, 1L, 2L, 2L, 2L, 2L, 2L, 2L,
+2L, 2L, 2L, 2L, 2L, 3L, 2L, 2L, 2L, 2L, 2L, 2L, 1L, 1L, 2L, 2L,
+2L, 2L, 4L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 3L, 3L, 3L, 2L, 2L, 2L,
+2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L,
+2L, 1L, 1L, 3L, 2L, 2L, 2L, 1L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L,
+3L, 2L, 1L, 2L, 2L, 2L, 2L, 2L, 4L, 4L, 2L, 2L, 1L, 2L, 2L, 2L,
+2L, 4L, 2L, 2L, 2L, 2L, 2L, 2L, 4L, 2L, 2L, 2L, 2L, 2L, 2L, 2L,
+4L, 2L, 2L, 4L, 2L, 2L, 2L, 2L, 4L, 2L, 2L, 4L, 4L, 2L, 2L, 2L,
+2L, 4L, 2L, 2L, 2L, 2L, 2L, 2L, 1L, 4L, 2L, 2L, 2L, 2L, 2L, 4L,
+2L, 2L, 4L, 2L, 2L, 2L, 2L, 1L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L,
+2L, 2L, 4L, 2L, 2L, 4L, 2L, 4L, 2L, 2L, 2L, 2L, 2L, 4L, 2L, 2L,
+3L, 2L, 2L, 2L, 3L, 2L, 2L, 2L, 3L, 1L, 2L, 2L, 2L, 2L, 2L, 2L,
+2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 3L, 2L, 2L, 2L, 2L,
+3L, 2L, 3L, 2L, 3L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L,
+2L, 2L, 4L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 3L, 2L, 2L, 2L, 2L, 2L,
+2L, 2L, 3L, 2L, 3L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L,
+2L, 2L, 2L, 2L, 2L, 1L, 4L, 3L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 3L,
+2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 3L, 3L, 2L, 2L, 2L,
+2L, 2L, 2L, 2L, 2L, 3L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 3L, 2L,
+2L, 2L, 2L, 2L, 2L, 2L, 3L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L,
+1L, 2L, 2L, 4L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 3L, 2L, 2L,
+3L, 2L, 2L, 3L, 2L, 2L, 2L, 2L, 3L, 2L, 2L, 2L, 2L, 2L, 2L, 2L,
+2L, 2L, 2L, 2L, 2L, 2L, 3L, 2L, 2L, 2L, 2L, 2L, 2L, 3L, 2L, 3L,
+3L, 2L, 3L, 2L, 1L, 2L, 3L, 3L, 2L, 1L, 3L, 3L, 2L, 2L, 4L, 3L,
+2L, 2L, 2L, 2L, 2L, 2L, 1L, 2L, 2L, 2L, 2L, 2L, 3L, 2L, 2L, 2L,
+2L, 2L, 2L, 3L, 2L, 3L, 2L, 2L, 2L, 2L, 3L, 1L, 1L, 2L, 2L, 2L,
+2L, 3L, 2L, 2L, 2L, 1L, 2L, 2L, 3L, 2L, 2L, 2L, 2L, 2L, 2L, 3L,
+2L, 2L, 2L, 2L, 2L, 2L, 1L, 2L, 3L, 2L, 1L, 2L, 2L, 3L, 2L, 1L,
+2L, 2L, 2L, 2L, 2L, 2L, 3L, 3L, 2L, 3L, 1L, 2L, 2L, 2L, 2L, 2L,
+2L, 2L, 2L, 2L, 1L, 3L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 3L, 2L, 2L,
+2L, 3L, 3L, 2L, 1L, 3L, 2L, 3L, 3L, 2L, 3L, 2L, 2L, 2L, 2L, 3L,
+3L, 2L, 2L, 2L, 2L, 1L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 3L, 2L, 3L,
+2L, 2L, 2L, 2L, 3L, 1L, 2L, 3L, 2L, 2L, 2L, 3L, 2L, 2L, 2L, 2L,
+2L, 3L, 2L, 1L, 3L, 1L, 2L, 2L, 2L, 3L, 1L, 2L, 2L, 3L, 2L, 2L,
+3L, 2L, 3L, 2L, 2L, 3L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 1L, 2L,
+2L, 2L, 3L, 2L, 3L, 3L, 1L, 1L, 3L, 3L, 3L, 2L, 2L, 2L, 2L, 2L,
+1L, 3L, 2L, 4L, 2L, 2L, 3L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 1L,
+2L, 1L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 4L, 2L, 2L,
+2L, 2L, 2L, 2L, 2L, 2L, 2L, 1L, 1L, 2L, 2L, 3L, 3L, 3L, 2L, 3L,
+2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 3L, 2L, 2L, 2L, 2L,
+3L, 3L, 2L, 2L, 3L, 2L, 2L, 2L, 2L, 3L, 1L, 3L, 3L, 2L, 2L, 3L,
+2L, 1L, 2L, 3L, 2L, 2L, 3L, 3L, 2L, 2L, 3L, 3L, 2L, 2L, 2L, 2L,
+3L, 3L, 2L, 2L, 2L, 3L, 2L, 2L, 3L, 3L, 2L, 2L, 2L, 2L, 2L, 2L,
+2L, 2L, 2L, 3L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 3L, 2L, 2L, 2L,
+2L, 2L, 2L, 3L, 2L, 2L, 3L, 3L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L,
+2L, 1L, 2L, 2L, 2L, 1L, 2L, 1L, 1L, 2L, 2L, 2L, 2L, 2L, 2L, 3L,
+2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 1L, 2L, 2L, 2L,
+2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L,
+2L, 2L, 2L, 1L, 2L, 1L, 2L, 2L, 3L, 2L, 1L, 2L, 2L, 3L, 2L, 2L,
+2L, 2L, 2L, 2L, 2L, 1L, 2L, 2L, 2L, 2L, 1L, 2L, 3L, 2L, 3L, 3L,
+2L, 2L, 2L, 2L, 3L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 3L, 2L, 2L, 1L,
+2L, 2L, 1L, 2L, 2L, 2L, 2L, 2L, 2L, 3L, 2L, 2L, 2L, 2L, 2L, 2L,
+2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L,
+2L, 3L, 2L, 2L, 2L, 1L, 2L, 2L, 2L, 2L, 3L, 2L, 3L, 3L, 2L, 3L,
+3L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 1L, 2L,
+2L, 2L, 2L, 1L, 2L, 2L, 2L, 3L, 3L, 2L, 1L, 2L, 2L, 2L, 2L, 3L,
+2L, 2L, 3L, 3L, 2L, 2L, 2L, 3L, 3L, 2L, 2L, 1L, 3L, 3L, 3L, 3L,
+2L, 2L, 2L, 2L, 2L, 2L, 2L, 1L, 1L, 2L, 2L, 2L, 2L, 2L, 2L, 2L,
+2L, 2L, 2L, 2L, 3L, 2L, 3L, 3L, 3L, 2L, 3L, 2L, 2L, 2L, 2L, 2L,
+2L, 2L, 2L, 2L, 3L, 2L, 2L, 2L, 2L, 2L, 3L, 2L, 2L, 2L, 2L, 2L,
+3L, 2L, 2L, 3L, 2L, 2L, 2L, 2L, 3L, 3L, 2L, 2L, 2L, 2L, 2L, 2L,
+2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L,
+4L, 2L, 3L, 1L, 3L, 2L, 2L, 3L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 1L,
+2L, 2L, 2L, 2L, 2L, 3L, 2L, 2L, 1L, 2L, 3L, 2L, 2L, 2L, 2L, 2L,
+2L, 2L, 2L, 2L, 4L, 2L, 2L, 3L, 2L, 2L, 2L, 2L, 3L, 2L, 3L, 2L,
+2L, 3L, 2L, 3L, 2L, 2L, 2L, 1L, 2L, 3L, 2L, 2L, 2L, 2L, 2L, 2L,
+2L, 2L, 3L, 2L, 2L, 2L, 2L, 2L, 2L, 4L, 1L, 3L, 3L, 3L, 2L, 2L,
+2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L,
+2L, 2L, 1L, 2L, 3L, 2L, 2L, 4L, 2L, 2L, 1L, 2L, 2L, 2L, 2L, 2L,
+3L, 2L, 2L, 2L, 2L, 3L, 2L, 2L, 1L, 2L, 2L, 3L, 3L, 3L, 2L, 2L,
+2L, 2L, 3L, 2L, 2L, 1L, 2L, 2L, 2L, 2L, 2L, 3L, 2L, 2L, 2L, 2L,
+2L, 2L, 2L, 2L, 2L, 2L, 2L, 3L, 2L, 3L, 2L, 3L, 3L, 2L, 1L, 2L,
+2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L,
+2L, 1L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 4L, 1L, 2L, 2L,
+2L, 2L, 2L, 2L, 1L, 2L, 2L, 2L, 2L, 2L, 2L, 3L, 2L, 2L, 2L, 2L,
+2L, 2L, 2L, 2L, 3L, 3L, 3L, 2L, 2L, 2L, 2L, 3L, 2L, 2L, 2L, 2L,
+2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 3L, 2L, 2L,
+2L, 2L, 2L, 2L, 1L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 3L, 2L, 2L, 2L,
+2L, 2L, 2L, 2L, 2L, 1L, 2L, 4L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L,
+3L, 2L, 2L, 2L, 2L, 2L, 2L, 1L, 2L, 2L, 3L, 1L, 2L, 2L, 2L, 2L,
+3L, 1L, 2L, 2L, 2L, 2L, 2L, 3L, 1L, 2L, 2L, 2L, 2L, 2L, 3L, 2L,
+2L, 3L, 3L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 1L, 2L, 2L, 2L, 3L,
+1L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L,
+3L, 2L, 2L, 2L, 3L, 3L, 2L, 2L, 2L, 3L, 2L, 2L, 2L, 2L, 2L, 3L,
+2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L,
+2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 3L,
+2L, 3L, 2L, 2L, 3L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L,
+2L, 2L, 2L, 2L, 1L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 3L, 3L,
+2L, 2L, 3L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 3L, 2L,
+2L, 2L, 2L, 2L, 1L, 2L, 2L, 2L, 1L, 2L, 3L, 2L, 3L, 2L, 2L, 2L,
+2L, 2L, 3L, 1L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L,
+2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L,
+2L, 2L, 2L, 2L, 1L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L,
+1L, 2L, 2L, 2L, 2L, 2L, 3L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L,
+3L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 1L, 2L, 2L, 1L, 2L, 2L,
+3L, 2L, 3L, 2L, 2L, 2L, 3L, 3L, 3L, 2L, 2L, 2L, 2L, 2L, 2L, 3L,
+2L, 2L, 3L, 2L, 3L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 3L, 2L, 2L,
+2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L,
+2L, 2L, 1L, 2L, 2L, 3L, 2L, 3L, 3L, 2L, 2L, 2L, 2L, 2L, 2L, 2L,
+2L, 2L, 2L, 2L, 2L, 2L, 4L, 2L, 2L, 1L, 2L, 2L, 2L, 2L, 1L, 3L,
+3L, 2L, 2L, 3L, 1L, 2L, 2L, 2L, 3L, 3L, 2L, 2L, 2L, 2L, 2L, 2L,
+2L, 2L, 3L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 3L, 3L, 2L, 2L, 2L,
+2L, 2L, 3L, 3L, 3L, 2L, 2L, 2L, 2L, 2L, 1L, 2L, 2L, 3L, 2L, 2L,
+2L, 2L, 2L, 2L, 2L, 2L, 3L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L,
+3L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 3L, 1L, 2L, 2L, 2L, 2L,
+3L, 2L, 2L, 2L, 2L, 2L, 3L, 2L, 3L, 2L, 2L, 2L, 2L, 2L, 2L, 2L,
+2L, 3L, 2L, 2L, 1L, 2L, 2L, 3L, 2L, 4L, 2L, 2L, 2L, 2L, 3L, 2L,
+2L, 2L, 2L, 2L, 3L, 2L, 2L, 2L, 2L, 2L, 2L, 3L, 2L, 2L, 2L, 2L,
+2L, 3L, 2L, 2L, 2L, 2L, 3L, 2L, 2L, 3L, 2L, 2L, 1L, 2L, 3L, 2L,
+3L, 2L, 2L, 2L, 3L, 2L, 2L, 3L, 2L, 3L, 2L, 4L, 2L, 2L, 2L, 2L,
+2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 1L, 3L, 2L,
+2L, 2L, 2L, 3L, 3L, 2L, 3L, 2L, 2L, 2L, 2L, 1L, 2L, 1L, 2L, 3L,
+2L, 3L, 2L, 2L, 2L, 3L, 2L, 2L, 3L, 2L, 2L, 2L, 2L, 3L, 3L, 2L,
+2L, 2L, 3L, 2L, 2L, 2L, 2L, 3L, 2L, 2L, 2L, 2L, 3L, 2L, 2L, 2L,
+2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L,
+2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 3L, 2L, 2L, 2L, 2L, 2L,
+2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 3L, 3L, 2L, 2L, 3L, 2L, 2L, 3L,
+3L, 2L, 2L, 2L, 3L, 2L, 2L, 2L, 2L, 2L, 2L, 1L, 2L, 2L, 2L, 1L,
+1L, 2L, 1L, 3L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L,
+2L, 2L, 3L, 2L, 2L, 4L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L,
+3L, 2L, 2L, 2L, 2L, 2L, 3L, 2L, 1L, 3L, 2L, 2L, 2L, 3L, 2L, 2L,
+2L, 3L, 2L, 2L, 2L, 2L, 2L, 1L, 2L, 2L, 2L, 2L, 3L, 2L, 2L, 2L,
+2L, 3L, 2L, 2L, 3L, 1L, 2L, 2L, 3L, 3L, 2L, 2L, 2L, 2L, 2L, 2L,
+2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 1L, 2L, 2L, 2L, 2L,
+2L, 3L, 2L, 2L, 2L, 2L, 2L, 3L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L,
+1L, 2L, 1L, 3L, 1L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 1L, 2L, 2L,
+1L, 2L, 2L, 3L, 3L, 2L, 3L, 2L, 3L, 2L, 1L, 2L, 2L, 2L, 2L, 2L,
+3L, 2L, 2L, 2L, 1L, 1L, 2L, 1L, 2L, 2L, 2L, 2L, 2L, 2L, 3L, 2L,
+4L, 1L, 2L, 2L, 2L, 1L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L,
+2L, 2L, 3L, 2L, 2L, 2L, 3L, 2L, 2L, 2L, 2L, 1L, 2L, 2L, 2L, 2L,
+3L, 2L, 2L, 2L, 2L, 2L, 2L, 3L, 2L, 2L, 2L, 2L, 1L, 2L, 2L, 2L,
+2L, 2L, 3L, 2L, 2L, 3L, 2L, 2L, 1L, 2L, 3L, 2L, 2L, 2L, 2L, 2L,
+2L, 2L, 3L, 2L, 2L, 2L, 1L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L,
+3L, 2L, 2L, 2L, 2L, 2L, 3L, 1L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L,
+2L, 3L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L,
+2L, 3L, 2L, 2L, 1L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L,
+2L, 2L, 2L, 2L, 2L, 3L, 2L, 1L, 2L, 1L, 2L, 2L, 2L, 2L, 2L, 2L,
+2L, 3L, 3L, 3L, 2L, 1L, 2L, 2L, 2L, 1L, 2L, 2L, 2L, 2L, 3L, 2L,
+1L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L,
+2L, 2L, 2L, 1L, 2L, 2L, 3L, 1L, 3L, 4L, 2L, 3L, 2L, 2L, 2L, 2L,
+2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 3L, 2L, 3L,
+3L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 3L, 2L, 3L, 2L, 3L, 2L,
+3L, 3L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 3L, 2L, 2L, 2L, 2L, 2L, 2L,
+2L, 3L, 2L, 1L, 2L, 2L, 2L, 2L, 2L, 3L, 2L, 2L, 2L, 2L, 2L, 2L,
+2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 3L, 2L, 3L, 2L, 2L, 2L,
+2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 3L, 2L, 1L, 2L,
+2L, 2L, 2L, 1L, 2L, 2L, 2L, 2L, 2L, 2L, 3L, 2L, 2L, 2L, 2L, 2L,
+3L, 2L, 2L, 3L, 2L, 2L, 2L, 3L, 2L, 2L, 2L, 2L, 3L, 2L, 2L, 2L,
+2L, 2L, 2L, 2L, 3L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 3L,
+2L, 2L, 2L, 2L, 2L, 3L, 2L, 3L, 2L, 2L, 2L, 3L, 3L, 2L, 2L, 1L,
+2L, 1L, 2L, 2L, 2L, 2L, 3L, 3L, 2L, 2L, 2L, 2L, 2L, 3L, 2L, 2L,
+2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 3L, 2L, 2L, 1L, 3L, 2L,
+2L, 2L, 3L, 2L, 2L, 2L, 2L, 1L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 3L,
+2L, 2L, 3L, 3L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 3L, 2L,
+2L, 2L, 2L, 2L, 3L, 3L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L,
+2L, 2L, 2L, 2L, 2L, 2L, 3L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L,
+2L, 3L, 2L, 2L, 3L, 3L, 2L, 2L, 2L, 3L, 2L, 2L, 2L, 2L, 2L, 2L,
+4L, 1L, 2L, 3L, 2L, 2L, 2L, 2L, 2L, 2L, 3L, 2L, 2L, 2L, 3L, 3L,
+3L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 3L, 3L, 3L, 2L, 2L, 2L, 1L, 2L,
+3L, 2L, 1L, 3L, 2L, 2L, 3L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L,
+2L, 1L, 3L, 3L, 2L, 2L, 2L, 3L, 2L, 3L, 3L, 2L, 2L, 2L, 3L, 3L,
+2L, 2L, 2L, 2L, 2L, 2L, 1L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L,
+3L, 2L, 3L, 1L, 3L, 2L, 2L, 2L, 2L, 2L, 2L, 3L, 2L, 2L, 2L, 3L,
+2L, 2L, 2L, 3L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L,
+2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 3L, 2L, 3L, 2L, 2L, 1L, 2L, 2L,
+2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 3L, 2L, 2L, 2L, 3L, 3L,
+2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 1L,
+3L, 3L, 2L, 2L, 2L, 3L, 3L, 1L, 3L, 2L, 2L, 2L, 2L, 2L, 2L, 2L,
+3L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 3L, 2L, 2L, 3L, 2L,
+2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 1L, 1L, 2L, 2L, 2L, 2L, 3L, 2L,
+2L, 2L, 2L, 2L, 1L, 2L, 2L, 2L, 2L, 1L, 2L, 3L, 2L, 2L, 2L, 2L,
+2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 3L, 2L, 2L, 2L, 2L, 2L, 3L, 2L,
+3L, 3L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 3L, 2L, 2L,
+2L, 2L, 2L, 1L, 2L, 2L, 2L, 2L, 3L, 3L, 2L, 2L, 2L, 2L, 2L, 2L,
+2L, 2L, 3L, 1L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L,
+2L, 2L, 2L, 3L, 2L, 3L, 3L, 3L, 2L, 2L, 2L, 3L, 2L, 2L, 2L, 2L,
+2L, 2L, 2L, 2L, 3L, 3L, 3L, 2L, 3L, 2L, 2L, 2L, 1L, 2L, 2L, 3L,
+2L, 2L, 2L, 2L, 1L, 3L, 2L, 2L, 1L, 2L, 2L, 2L, 2L, 2L, 2L, 2L,
+2L, 2L, 2L, 2L, 2L, 3L, 2L, 2L, 2L, 2L, 3L, 2L, 3L, 2L, 2L, 2L,
+1L, 2L, 2L, 2L, 2L, 3L, 2L, 1L, 2L, 3L, 2L, 2L, 2L, 2L, 2L, 3L,
+2L, 2L, 3L, 2L, 3L, 2L, 2L, 2L, 2L, 2L, 2L, 1L, 3L, 2L, 3L, 2L,
+3L, 2L, 2L, 2L, 2L, 3L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 1L, 2L, 2L,
+2L, 1L, 2L, 2L, 3L, 3L, 2L, 3L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 1L,
+2L, 1L, 2L, 2L, 3L, 2L, 2L, 2L, 2L, 1L, 2L, 2L, 2L, 2L, 2L, 3L,
+3L, 2L, 3L, 2L, 2L, 3L, 1L, 2L, 2L, 3L, 2L, 3L, 2L, 2L, 3L, 2L,
+2L, 3L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 1L, 3L, 2L, 2L, 2L, 3L, 2L,
+3L, 3L, 3L, 2L, 3L, 2L, 3L, 2L, 2L, 2L, 3L, 3L, 3L, 3L, 2L, 2L,
+3L, 2L, 2L, 2L, 2L, 3L, 2L, 2L, 1L, 2L, 1L, 2L, 2L, 2L, 2L, 2L,
+2L, 2L, 2L, 2L, 2L, 2L, 3L, 3L, 2L, 2L, 2L, 2L, 2L, 2L, 3L, 2L,
+3L, 2L, 2L, 3L, 3L, 2L, 2L, 2L, 2L, 1L, 1L, 2L, 2L, 1L, 1L, 2L,
+3L, 1L, 2L, 3L, 2L, 1L, 2L, 2L, 2L, 3L, 2L, 2L, 1L, 2L, 2L, 3L,
+2L, 3L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 1L, 2L, 1L, 2L, 2L, 2L, 2L,
+2L, 2L, 1L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 3L, 1L, 2L, 2L, 3L, 2L,
+2L, 2L, 2L, 3L, 2L, 3L, 2L, 3L, 2L, 3L, 2L, 2L, 2L, 2L, 2L, 2L,
+2L, 2L, 2L, 3L, 2L, 2L, 1L, 2L, 1L, 2L, 2L, 1L, 2L, 2L, 2L, 2L,
+2L, 2L, 2L, 3L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 3L, 2L, 3L,
+2L, 2L, 2L, 2L, 2L, 3L, 2L, 1L, 2L, 3L, 2L, 2L, 2L, 2L, 2L, 2L,
+2L, 2L, 1L, 2L, 2L, 1L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 1L, 3L,
+2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 3L, 2L, 2L, 2L, 2L, 2L, 2L,
+2L, 3L, 2L, 2L, 2L, 3L, 2L, 2L, 3L, 2L, 2L, 2L, 3L, 1L, 2L, 2L,
+2L, 3L, 2L, 2L, 3L, 2L, 2L, 2L, 4L, 3L, 3L, 1L, 2L, 2L, 2L, 3L,
+2L, 3L, 2L, 2L, 2L, 2L, 2L, 3L, 3L, 2L, 3L, 2L, 3L, 2L, 2L, 3L,
+1L, 2L, 3L, 2L, 3L, 2L, 2L, 3L, 2L, 2L, 3L, 2L, 2L, 2L, 2L, 2L,
+2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 3L, 2L, 2L, 2L,
+2L, 3L, 2L, 2L, 3L, 2L, 2L, 2L, 2L, 2L, 2L, 3L, 2L, 2L, 2L, 2L,
+2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 3L, 2L, 2L, 2L, 2L, 2L, 3L, 2L,
+2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 3L, 2L, 2L, 2L, 3L, 3L, 3L,
+2L, 2L, 2L, 2L, 2L, 3L, 2L, 2L, 2L, 2L, 2L, 2L, 3L, 2L, 2L, 3L,
+2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 4L, 2L, 3L, 2L, 2L, 2L, 2L, 2L,
+3L, 3L, 2L, 2L, 3L, 3L, 2L, 3L, 2L, 3L, 2L, 2L, 3L, 3L, 2L, 2L,
+3L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 3L, 2L, 2L, 2L, 2L,
+1L, 2L, 2L, 2L, 2L, 3L, 2L, 3L, 2L, 3L, 3L, 2L, 2L, 1L, 2L, 2L,
+2L, 1L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L,
+2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 3L,
+2L, 2L, 2L, 2L, 2L, 2L, 2L, 3L, 3L, 2L, 2L, 3L, 2L, 1L, 3L, 2L,
+2L, 2L, 3L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L,
+2L, 2L, 2L, 1L, 2L, 1L, 2L, 2L, 2L, 3L, 3L, 1L, 2L, 1L, 2L, 2L,
+3L, 2L, 2L, 2L, 2L, 2L, 2L, 3L, 2L, 3L, 2L, 2L, 2L, 2L, 3L, 2L,
+2L, 2L, 2L, 2L, 2L, 2L, 2L, 3L, 2L, 2L, 3L, 3L, 2L, 3L, 2L, 2L,
+2L, 2L, 2L, 2L, 2L, 3L, 3L, 3L, 2L, 2L, 3L, 1L, 2L, 2L, 3L, 2L,
+3L, 2L, 3L, 2L, 3L, 2L, 3L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L,
+2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L,
+2L, 1L, 3L, 2L, 2L, 2L, 2L, 3L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L,
+2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 3L, 2L, 3L, 2L, 2L, 2L, 2L, 2L,
+2L, 2L, 2L, 2L, 1L, 2L, 2L, 2L, 3L, 2L, 2L, 1L, 2L, 2L, 2L, 3L,
+2L, 3L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 3L, 2L, 2L, 2L, 2L, 2L, 1L,
+2L, 2L, 3L, 2L, 2L, 2L, 3L, 2L, 2L, 2L, 2L, 2L, 3L, 3L, 2L, 2L,
+3L, 2L, 2L, 2L, 2L, 2L, 3L, 2L, 3L, 2L, 3L, 3L, 2L, 2L, 2L, 2L,
+1L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 3L, 3L, 2L, 2L, 2L,
+2L, 2L, 3L, 2L, 2L, 2L, 2L, 3L, 2L, 2L, 2L, 2L, 2L, 2L, 3L, 2L,
+2L, 2L, 2L, 2L, 2L, 3L, 2L, 3L, 2L, 2L, 2L, 2L, 3L, 2L, 2L, 2L
+), .Label = c("Divorced/Separated", "Married/Partnered", "Single",
+"Widowed"), class = "factor")), .Names = c("age", "ethnicity",
+"mstatus"), row.names = c(1L, 2L, 3L, 4L, 5L, 7L, 10L, 11L, 12L,
+13L, 16L, 20L, 22L, 24L, 26L, 31L, 32L, 33L, 37L, 40L, 44L, 46L,
+47L, 48L, 49L, 50L, 52L, 53L, 54L, 57L, 58L, 59L, 66L, 68L, 77L,
+78L, 80L, 81L, 85L, 86L, 87L, 88L, 90L, 94L, 96L, 97L, 98L, 100L,
+103L, 104L, 105L, 107L, 108L, 109L, 110L, 111L, 115L, 117L, 120L,
+122L, 124L, 125L, 126L, 127L, 130L, 131L, 133L, 134L, 135L, 138L,
+140L, 148L, 149L, 150L, 153L, 155L, 157L, 158L, 159L, 160L, 162L,
+163L, 164L, 168L, 169L, 170L, 171L, 177L, 178L, 179L, 186L, 188L,
+190L, 195L, 199L, 202L, 203L, 205L, 206L, 207L, 208L, 212L, 214L,
+216L, 217L, 219L, 220L, 221L, 222L, 223L, 225L, 230L, 233L, 234L,
+235L, 236L, 237L, 238L, 240L, 242L, 243L, 244L, 246L, 248L, 250L,
+253L, 257L, 259L, 260L, 262L, 263L, 264L, 265L, 266L, 268L, 269L,
+270L, 277L, 279L, 281L, 284L, 286L, 288L, 289L, 291L, 292L, 294L,
+295L, 296L, 303L, 305L, 307L, 309L, 310L, 311L, 312L, 313L, 314L,
+315L, 316L, 319L, 320L, 321L, 322L, 325L, 326L, 327L, 328L, 330L,
+331L, 333L, 334L, 336L, 337L, 338L, 340L, 341L, 346L, 347L, 349L,
+351L, 352L, 357L, 358L, 360L, 362L, 363L, 368L, 370L, 371L, 373L,
+374L, 377L, 382L, 383L, 384L, 387L, 388L, 391L, 395L, 399L, 402L,
+405L, 406L, 407L, 408L, 411L, 413L, 417L, 419L, 420L, 421L, 422L,
+424L, 425L, 427L, 436L, 444L, 447L, 448L, 456L, 458L, 459L, 460L,
+462L, 467L, 469L, 472L, 477L, 480L, 481L, 487L, 489L, 491L, 494L,
+495L, 499L, 501L, 503L, 505L, 509L, 510L, 512L, 515L, 518L, 520L,
+522L, 523L, 524L, 525L, 528L, 531L, 535L, 536L, 539L, 540L, 542L,
+543L, 544L, 545L, 552L, 553L, 554L, 556L, 557L, 558L, 559L, 560L,
+562L, 563L, 567L, 574L, 575L, 576L, 577L, 578L, 579L, 580L, 584L,
+585L, 586L, 588L, 589L, 591L, 592L, 594L, 595L, 596L, 598L, 600L,
+602L, 603L, 613L, 618L, 626L, 627L, 628L, 629L, 633L, 635L, 636L,
+637L, 638L, 639L, 640L, 641L, 643L, 646L, 647L, 648L, 651L, 652L,
+653L, 654L, 655L, 656L, 657L, 659L, 661L, 662L, 666L, 669L, 670L,
+671L, 672L, 674L, 675L, 677L, 679L, 681L, 682L, 685L, 687L, 690L,
+692L, 693L, 708L, 709L, 710L, 711L, 712L, 716L, 719L, 721L, 724L,
+733L, 739L, 742L, 745L, 746L, 748L, 749L, 750L, 751L, 752L, 753L,
+754L, 756L, 757L, 761L, 762L, 763L, 764L, 769L, 770L, 773L, 774L,
+775L, 776L, 778L, 781L, 783L, 785L, 788L, 789L, 790L, 792L, 793L,
+795L, 796L, 797L, 798L, 801L, 802L, 803L, 807L, 810L, 811L, 813L,
+814L, 815L, 818L, 820L, 823L, 825L, 826L, 828L, 829L, 831L, 832L,
+834L, 839L, 841L, 844L, 847L, 849L, 851L, 853L, 855L, 857L, 862L,
+863L, 865L, 872L, 873L, 880L, 884L, 885L, 886L, 890L, 894L, 895L,
+896L, 897L, 898L, 900L, 901L, 902L, 904L, 905L, 906L, 907L, 910L,
+912L, 916L, 918L, 919L, 920L, 924L, 933L, 934L, 935L, 936L, 937L,
+938L, 940L, 941L, 943L, 944L, 945L, 953L, 955L, 956L, 957L, 958L,
+960L, 961L, 962L, 967L, 972L, 973L, 976L, 977L, 978L, 980L, 981L,
+982L, 989L, 990L, 995L, 996L, 997L, 998L, 1003L, 1004L, 1006L,
+1007L, 1008L, 1009L, 1010L, 1011L, 1017L, 1020L, 1022L, 1024L,
+1027L, 1029L, 1030L, 1031L, 1033L, 1034L, 1036L, 1037L, 1038L,
+1040L, 1041L, 1042L, 1043L, 1044L, 1045L, 1046L, 1048L, 1049L,
+1052L, 1055L, 1056L, 1058L, 1059L, 1060L, 1061L, 1062L, 1063L,
+1064L, 1065L, 1066L, 1067L, 1068L, 1069L, 1070L, 1072L, 1073L,
+1075L, 1076L, 1077L, 1079L, 1080L, 1081L, 1083L, 1084L, 1086L,
+1087L, 1088L, 1091L, 1092L, 1093L, 1097L, 1100L, 1101L, 1104L,
+1107L, 1109L, 1112L, 1116L, 1119L, 1123L, 1124L, 1126L, 1127L,
+1128L, 1129L, 1131L, 1132L, 1133L, 1134L, 1135L, 1137L, 1138L,
+1139L, 1140L, 1141L, 1143L, 1144L, 1145L, 1147L, 1148L, 1149L,
+1151L, 1154L, 1156L, 1166L, 1170L, 1173L, 1174L, 1179L, 1182L,
+1184L, 1186L, 1191L, 1193L, 1196L, 1198L, 1199L, 1201L, 1202L,
+1203L, 1209L, 1210L, 1223L, 1224L, 1225L, 1230L, 1231L, 1232L,
+1237L, 1238L, 1239L, 1241L, 1245L, 1251L, 1253L, 1256L, 1257L,
+1259L, 1260L, 1261L, 1262L, 1266L, 1267L, 1272L, 1273L, 1275L,
+1276L, 1279L, 1281L, 1283L, 1284L, 1285L, 1286L, 1289L, 1291L,
+1292L, 1295L, 1297L, 1298L, 1299L, 1301L, 1302L, 1303L, 1308L,
+1314L, 1315L, 1317L, 1318L, 1319L, 1321L, 1323L, 1325L, 1326L,
+1327L, 1328L, 1330L, 1333L, 1340L, 1341L, 1342L, 1345L, 1346L,
+1347L, 1348L, 1350L, 1352L, 1355L, 1356L, 1358L, 1360L, 1367L,
+1369L, 1377L, 1382L, 1383L, 1384L, 1386L, 1387L, 1388L, 1389L,
+1391L, 1393L, 1394L, 1395L, 1397L, 1398L, 1401L, 1405L, 1406L,
+1409L, 1412L, 1413L, 1415L, 1418L, 1420L, 1422L, 1424L, 1429L,
+1432L, 1433L, 1436L, 1437L, 1443L, 1444L, 1450L, 1451L, 1452L,
+1456L, 1457L, 1463L, 1464L, 1465L, 1466L, 1467L, 1468L, 1469L,
+1470L, 1471L, 1472L, 1473L, 1474L, 1475L, 1476L, 1478L, 1479L,
+1480L, 1481L, 1482L, 1485L, 1488L, 1489L, 1490L, 1494L, 1495L,
+1497L, 1498L, 1499L, 1500L, 1501L, 1502L, 1504L, 1506L, 1507L,
+1509L, 1510L, 1511L, 1512L, 1513L, 1514L, 1515L, 1516L, 1518L,
+1519L, 1520L, 1522L, 1523L, 1524L, 1525L, 1526L, 1529L, 1530L,
+1534L, 1535L, 1536L, 1538L, 1539L, 1540L, 1541L, 1542L, 1543L,
+1544L, 1545L, 1547L, 1549L, 1550L, 1552L, 1558L, 1559L, 1562L,
+1566L, 1567L, 1569L, 1575L, 1576L, 1581L, 1582L, 1584L, 1587L,
+1589L, 1591L, 1593L, 1594L, 1595L, 1596L, 1597L, 1599L, 1600L,
+1601L, 1603L, 1604L, 1606L, 1607L, 1609L, 1610L, 1613L, 1614L,
+1615L, 1617L, 1618L, 1619L, 1620L, 1621L, 1622L, 1623L, 1624L,
+1626L, 1627L, 1628L, 1629L, 1630L, 1631L, 1632L, 1633L, 1634L,
+1638L, 1639L, 1640L, 1641L, 1642L, 1643L, 1644L, 1645L, 1646L,
+1647L, 1650L, 1651L, 1652L, 1653L, 1655L, 1656L, 1657L, 1658L,
+1659L, 1660L, 1661L, 1662L, 1663L, 1666L, 1667L, 1668L, 1669L,
+1670L, 1671L, 1672L, 1673L, 1674L, 1675L, 1676L, 1677L, 1678L,
+1679L, 1681L, 1682L, 1683L, 1685L, 1687L, 1688L, 1689L, 1690L,
+1691L, 1692L, 1694L, 1696L, 1697L, 1699L, 1701L, 1702L, 1704L,
+1708L, 1709L, 1711L, 1713L, 1715L, 1716L, 1718L, 1721L, 1722L,
+1723L, 1724L, 1725L, 1727L, 1728L, 1730L, 1731L, 1736L, 1737L,
+1738L, 1741L, 1742L, 1745L, 1748L, 1749L, 1751L, 1752L, 1753L,
+1755L, 1756L, 1758L, 1759L, 1761L, 1764L, 1765L, 1766L, 1767L,
+1769L, 1770L, 1771L, 1773L, 1774L, 1775L, 1776L, 1777L, 1778L,
+1779L, 1780L, 1781L, 1782L, 1783L, 1784L, 1785L, 1786L, 1787L,
+1788L, 1790L, 1791L, 1792L, 1793L, 1794L, 1796L, 1797L, 1798L,
+1800L, 1801L, 1802L, 1803L, 1804L, 1805L, 1806L, 1807L, 1808L,
+1810L, 1811L, 1813L, 1814L, 1815L, 1816L, 1818L, 1819L, 1820L,
+1822L, 1828L, 1829L, 1832L, 1834L, 1835L, 1836L, 1837L, 1839L,
+1840L, 1841L, 1843L, 1845L, 1849L, 1852L, 1855L, 1856L, 1857L,
+1858L, 1859L, 1860L, 1861L, 1862L, 1863L, 1865L, 1867L, 1870L,
+1871L, 1874L, 1880L, 1881L, 1882L, 1883L, 1884L, 1885L, 1886L,
+1888L, 1889L, 1891L, 1892L, 1893L, 1894L, 1897L, 1903L, 1904L,
+1907L, 1908L, 1909L, 1911L, 1912L, 1913L, 1915L, 1917L, 1921L,
+1925L, 1926L, 1929L, 1930L, 1931L, 1932L, 1935L, 1936L, 1937L,
+1939L, 1942L, 1943L, 1944L, 1945L, 1947L, 1950L, 1954L, 1956L,
+1959L, 1962L, 1963L, 1964L, 1966L, 1973L, 1976L, 1977L, 1978L,
+1979L, 1980L, 1981L, 1982L, 1983L, 1984L, 1985L, 1986L, 1988L,
+1990L, 1991L, 1992L, 1993L, 1995L, 1996L, 1997L, 1999L, 2000L,
+2002L, 2003L, 2004L, 2005L, 2008L, 2009L, 2011L, 2013L, 2014L,
+2016L, 2017L, 2019L, 2020L, 2021L, 2022L, 2023L, 2024L, 2026L,
+2028L, 2030L, 2031L, 2033L, 2035L, 2036L, 2037L, 2039L, 2040L,
+2041L, 2042L, 2043L, 2046L, 2049L, 2053L, 2056L, 2059L, 2060L,
+2061L, 2063L, 2065L, 2066L, 2067L, 2069L, 2070L, 2075L, 2077L,
+2081L, 2083L, 2087L, 2088L, 2089L, 2091L, 2092L, 2096L, 2097L,
+2099L, 2105L, 2107L, 2110L, 2117L, 2118L, 2119L, 2122L, 2123L,
+2125L, 2126L, 2128L, 2130L, 2131L, 2132L, 2133L, 2136L, 2137L,
+2138L, 2139L, 2142L, 2143L, 2144L, 2145L, 2146L, 2148L, 2149L,
+2150L, 2151L, 2152L, 2153L, 2156L, 2157L, 2158L, 2160L, 2161L,
+2162L, 2165L, 2166L, 2167L, 2168L, 2171L, 2172L, 2173L, 2174L,
+2176L, 2177L, 2178L, 2181L, 2184L, 2185L, 2188L, 2189L, 2190L,
+2192L, 2193L, 2195L, 2196L, 2200L, 2201L, 2204L, 2206L, 2210L,
+2212L, 2222L, 2223L, 2228L, 2230L, 2232L, 2234L, 2235L, 2236L,
+2237L, 2240L, 2242L, 2255L, 2257L, 2258L, 2259L, 2261L, 2262L,
+2269L, 2270L, 2274L, 2280L, 2283L, 2284L, 2290L, 2299L, 2301L,
+2303L, 2304L, 2305L, 2311L, 2313L, 2314L, 2316L, 2318L, 2319L,
+2322L, 2325L, 2327L, 2329L, 2330L, 2332L, 2336L, 2337L, 2339L,
+2341L, 2343L, 2349L, 2350L, 2351L, 2352L, 2353L, 2354L, 2356L,
+2358L, 2372L, 2377L, 2378L, 2379L, 2385L, 2388L, 2390L, 2391L,
+2395L, 2404L, 2406L, 2407L, 2409L, 2410L, 2411L, 2412L, 2413L,
+2416L, 2417L, 2420L, 2421L, 2422L, 2424L, 2425L, 2428L, 2429L,
+2431L, 2433L, 2434L, 2435L, 2436L, 2438L, 2439L, 2440L, 2443L,
+2445L, 2446L, 2447L, 2448L, 2449L, 2450L, 2451L, 2452L, 2453L,
+2454L, 2455L, 2461L, 2462L, 2463L, 2465L, 2466L, 2468L, 2469L,
+2470L, 2471L, 2472L, 2474L, 2475L, 2476L, 2477L, 2478L, 2479L,
+2480L, 2484L, 2486L, 2488L, 2491L, 2492L, 2493L, 2496L, 2497L,
+2498L, 2501L, 2502L, 2503L, 2504L, 2506L, 2507L, 2511L, 2514L,
+2518L, 2519L, 2520L, 2521L, 2523L, 2525L, 2527L, 2529L, 2532L,
+2533L, 2534L, 2536L, 2537L, 2538L, 2540L, 2541L, 2542L, 2543L,
+2544L, 2548L, 2549L, 2551L, 2552L, 2553L, 2554L, 2556L, 2557L,
+2558L, 2559L, 2561L, 2563L, 2566L, 2567L, 2568L, 2569L, 2572L,
+2574L, 2575L, 2577L, 2578L, 2579L, 2582L, 2584L, 2585L, 2586L,
+2589L, 2590L, 2591L, 2593L, 2594L, 2595L, 2598L, 2600L, 2601L,
+2602L, 2603L, 2604L, 2605L, 2607L, 2608L, 2609L, 2610L, 2612L,
+2614L, 2615L, 2616L, 2619L, 2620L, 2625L, 2628L, 2629L, 2632L,
+2633L, 2635L, 2636L, 2639L, 2640L, 2641L, 2645L, 2646L, 2651L,
+2655L, 2657L, 2659L, 2661L, 2664L, 2665L, 2666L, 2668L, 2669L,
+2670L, 2671L, 2677L, 2679L, 2680L, 2681L, 2682L, 2683L, 2684L,
+2686L, 2689L, 2691L, 2692L, 2695L, 2696L, 2697L, 2706L, 2712L,
+2716L, 2717L, 2719L, 2720L, 2721L, 2723L, 2724L, 2734L, 2735L,
+2736L, 2737L, 2741L, 2742L, 2743L, 2744L, 2748L, 2749L, 2750L,
+2753L, 2754L, 2755L, 2758L, 2759L, 2760L, 2761L, 2764L, 2768L,
+2770L, 2771L, 2772L, 2774L, 2777L, 2780L, 2782L, 2788L, 2790L,
+2791L, 2796L, 2797L, 2798L, 2800L, 2802L, 2803L, 2804L, 2805L,
+2810L, 2811L, 2816L, 2818L, 2819L, 2820L, 2821L, 2824L, 2825L,
+2828L, 2830L, 2832L, 2835L, 2836L, 2837L, 2842L, 2845L, 2847L,
+2848L, 2849L, 2850L, 2855L, 2856L, 2860L, 2863L, 2866L, 2876L,
+2877L, 2889L, 2891L, 2894L, 2895L, 2896L, 2898L, 2902L, 2904L,
+2905L, 2914L, 2916L, 2921L, 2922L, 2924L, 2928L, 2933L, 2934L,
+2936L, 2937L, 2939L, 2941L, 2942L, 2944L, 2945L, 2946L, 2948L,
+2950L, 2952L, 2955L, 2957L, 2961L, 2962L, 2963L, 2968L, 2969L,
+2971L, 2972L, 2975L, 2976L, 2977L, 2978L, 2979L, 2982L, 2983L,
+2985L, 2988L, 2990L, 2991L, 2992L, 2996L, 2999L, 3000L, 3001L,
+3002L, 3005L, 3008L, 3009L, 3011L, 3014L, 3015L, 3016L, 3017L,
+3022L, 3024L, 3027L, 3028L, 3030L, 3031L, 3034L, 3035L, 3038L,
+3040L, 3043L, 3046L, 3047L, 3051L, 3052L, 3058L, 3062L, 3066L,
+3072L, 3073L, 3074L, 3078L, 3082L, 3083L, 3084L, 3085L, 3088L,
+3089L, 3090L, 3092L, 3093L, 3094L, 3096L, 3097L, 3100L, 3102L,
+3104L, 3105L, 3107L, 3110L, 3111L, 3112L, 3113L, 3116L, 3121L,
+3124L, 3128L, 3131L, 3132L, 3133L, 3135L, 3136L, 3139L, 3141L,
+3145L, 3146L, 3148L, 3149L, 3151L, 3152L, 3153L, 3155L, 3157L,
+3160L, 3161L, 3162L, 3170L, 3172L, 3173L, 3174L, 3175L, 3176L,
+3177L, 3180L, 3183L, 3184L, 3185L, 3186L, 3188L, 3190L, 3198L,
+3204L, 3206L, 3209L, 3211L, 3212L, 3216L, 3218L, 3219L, 3228L,
+3230L, 3232L, 3234L, 3235L, 3236L, 3237L, 3239L, 3240L, 3244L,
+3245L, 3246L, 3247L, 3249L, 3251L, 3254L, 3257L, 3258L, 3260L,
+3261L, 3270L, 3271L, 3272L, 3274L, 3275L, 3276L, 3280L, 3284L,
+3290L, 3292L, 3294L, 3295L, 3303L, 3304L, 3309L, 3315L, 3317L,
+3318L, 3319L, 3322L, 3325L, 3326L, 3327L, 3328L, 3329L, 3331L,
+3332L, 3335L, 3337L, 3338L, 3339L, 3341L, 3342L, 3349L, 3353L,
+3355L, 3360L, 3364L, 3365L, 3366L, 3367L, 3369L, 3370L, 3376L,
+3379L, 3381L, 3382L, 3384L, 3386L, 3387L, 3393L, 3395L, 3398L,
+3399L, 3400L, 3404L, 3408L, 3410L, 3411L, 3413L, 3414L, 3417L,
+3421L, 3422L, 3423L, 3424L, 3426L, 3428L, 3430L, 3433L, 3435L,
+3437L, 3439L, 3443L, 3444L, 3446L, 3447L, 3448L, 3449L, 3450L,
+3451L, 3453L, 3454L, 3458L, 3460L, 3462L, 3463L, 3464L, 3467L,
+3468L, 3470L, 3473L, 3479L, 3481L, 3483L, 3488L, 3490L, 3491L,
+3492L, 3493L, 3494L, 3498L, 3499L, 3501L, 3504L, 3505L, 3506L,
+3508L, 3510L, 3511L, 3512L, 3513L, 3515L, 3520L, 3524L, 3525L,
+3528L, 3529L, 3530L, 3531L, 3532L, 3533L, 3536L, 3543L, 3544L,
+3545L, 3546L, 3548L, 3549L, 3551L, 3555L, 3556L, 3557L, 3558L,
+3560L, 3561L, 3562L, 3564L, 3571L, 3577L, 3579L, 3582L, 3584L,
+3585L, 3586L, 3587L, 3588L, 3589L, 3590L, 3591L, 3592L, 3593L,
+3595L, 3597L, 3605L, 3606L, 3608L, 3613L, 3614L, 3615L, 3619L,
+3620L, 3621L, 3622L, 3623L, 3625L, 3628L, 3629L, 3630L, 3634L,
+3638L, 3641L, 3643L, 3644L, 3645L, 3646L, 3647L, 3649L, 3650L,
+3651L, 3654L, 3656L, 3658L, 3659L, 3661L, 3662L, 3665L, 3666L,
+3669L, 3670L, 3671L, 3672L, 3673L, 3674L, 3677L, 3678L, 3680L,
+3681L, 3687L, 3689L, 3692L, 3695L, 3696L, 3697L, 3700L, 3702L,
+3706L, 3712L, 3713L, 3716L, 3718L, 3720L, 3722L, 3723L, 3724L,
+3727L, 3728L, 3729L, 3731L, 3732L, 3733L, 3736L, 3737L, 3738L,
+3739L, 3741L, 3742L, 3744L, 3745L, 3747L, 3749L, 3752L, 3753L,
+3755L, 3756L, 3760L, 3762L, 3763L, 3764L, 3766L, 3767L, 3768L,
+3771L, 3775L, 3776L, 3778L, 3780L, 3781L, 3782L, 3783L, 3785L,
+3788L, 3789L, 3791L, 3792L, 3794L, 3795L, 3796L, 3797L, 3800L,
+3801L, 3806L, 3807L, 3808L, 3809L, 3813L, 3817L, 3818L, 3822L,
+3824L, 3827L, 3829L, 3830L, 3831L, 3833L, 3834L, 3836L, 3837L,
+3839L, 3843L, 3848L, 3849L, 3854L, 3855L, 3857L, 3862L, 3864L,
+3867L, 3868L, 3869L, 3872L, 3874L, 3876L, 3877L, 3878L, 3879L,
+3880L, 3883L, 3884L, 3885L, 3888L, 3892L, 3893L, 3895L, 3898L,
+3901L, 3912L, 3913L, 3916L, 3918L, 3921L, 3922L, 3924L, 3925L,
+3930L, 3931L, 3936L, 3938L, 3943L, 3944L, 3945L, 3947L, 3951L,
+3952L, 3954L, 3959L, 3965L, 3966L, 3968L, 3971L, 3974L, 3977L,
+3980L, 3982L, 3983L, 3985L, 3986L, 3987L, 3988L, 3990L, 3991L,
+3995L, 3996L, 3999L, 4000L, 4003L, 4006L, 4008L, 4009L, 4011L,
+4014L, 4018L, 4019L, 4021L, 4022L, 4023L, 4024L, 4026L, 4027L,
+4028L, 4029L, 4030L, 4033L, 4034L, 4035L, 4042L, 4044L, 4049L,
+4050L, 4055L, 4057L, 4058L, 4059L, 4066L, 4069L, 4074L, 4075L,
+4076L, 4077L, 4079L, 4081L, 4082L, 4083L, 4088L, 4091L, 4093L,
+4094L, 4096L, 4098L, 4099L, 4100L, 4102L, 4104L, 4105L, 4106L,
+4109L, 4114L, 4120L, 4122L, 4123L, 4125L, 4131L, 4132L, 4137L,
+4141L, 4145L, 4146L, 4147L, 4150L, 4151L, 4152L, 4153L, 4154L,
+4157L, 4160L, 4161L, 4163L, 4164L, 4166L, 4172L, 4173L, 4174L,
+4175L, 4176L, 4178L, 4179L, 4180L, 4181L, 4184L, 4185L, 4186L,
+4188L, 4189L, 4190L, 4193L, 4194L, 4195L, 4197L, 4198L, 4200L,
+4203L, 4204L, 4205L, 4207L, 4209L, 4210L, 4211L, 4213L, 4214L,
+4217L, 4222L, 4224L, 4225L, 4229L, 4233L, 4237L, 4238L, 4240L,
+4242L, 4243L, 4246L, 4247L, 4249L, 4255L, 4256L, 4257L, 4260L,
+4261L, 4262L, 4265L, 4270L, 4272L, 4273L, 4276L, 4277L, 4282L,
+4283L, 4287L, 4290L, 4291L, 4292L, 4293L, 4294L, 4296L, 4298L,
+4301L, 4303L, 4310L, 4311L, 4313L, 4315L, 4317L, 4318L, 4322L,
+4326L, 4328L, 4329L, 4330L, 4332L, 4333L, 4336L, 4337L, 4349L,
+4350L, 4352L, 4354L, 4358L, 4362L, 4365L, 4371L, 4373L, 4374L,
+4376L, 4377L, 4378L, 4382L, 4387L, 4390L, 4391L, 4393L, 4396L,
+4399L, 4400L, 4401L, 4402L, 4403L, 4404L, 4405L, 4407L, 4410L,
+4411L, 4412L, 4413L, 4415L, 4417L, 4420L, 4421L, 4422L, 4423L,
+4425L, 4428L, 4429L, 4430L, 4432L, 4433L, 4435L, 4440L, 4444L,
+4445L, 4446L, 4447L, 4449L, 4450L, 4451L, 4452L, 4453L, 4455L,
+4460L, 4465L, 4470L, 4471L, 4475L, 4476L, 4481L, 4483L, 4484L,
+4486L, 4489L, 4495L, 4496L, 4497L, 4501L, 4502L, 4505L, 4506L,
+4507L, 4512L, 4514L, 4515L, 4517L, 4518L, 4521L, 4525L, 4526L,
+4527L, 4528L, 4529L, 4530L, 4532L, 4533L, 4536L, 4537L, 4541L,
+4542L, 4543L, 4546L, 4548L, 4550L, 4551L, 4554L, 4557L, 4560L,
+4567L, 4570L, 4573L, 4574L, 4575L, 4576L, 4581L, 4583L, 4587L,
+4588L, 4590L, 4593L, 4594L, 4595L, 4598L, 4599L, 4600L, 4603L,
+4606L, 4607L, 4612L, 4619L, 4620L, 4622L, 4623L, 4625L, 4626L,
+4630L, 4633L, 4638L, 4642L, 4644L, 4646L, 4649L, 4652L, 4656L,
+4659L, 4661L, 4663L, 4665L, 4667L, 4669L, 4670L, 4671L, 4673L,
+4674L, 4678L, 4680L, 4682L, 4687L, 4692L, 4693L, 4694L, 4696L,
+4697L, 4701L, 4702L, 4705L, 4706L, 4709L, 4710L, 4711L, 4713L,
+4714L, 4716L, 4719L, 4720L, 4721L, 4724L, 4727L, 4729L, 4734L,
+4736L, 4741L, 4743L, 4746L, 4753L, 4755L, 4756L, 4760L, 4763L,
+4764L, 4770L, 4772L, 4777L, 4779L, 4780L, 4781L, 4784L, 4787L,
+4788L, 4789L, 4791L, 4792L, 4793L, 4796L, 4797L, 4798L, 4799L,
+4800L, 4802L, 4806L, 4808L, 4809L, 4814L, 4815L, 4816L, 4817L,
+4818L, 4821L, 4824L, 4827L, 4831L, 4832L, 4833L, 4836L, 4838L,
+4839L, 4840L, 4843L, 4844L, 4846L, 4848L, 4852L, 4854L, 4855L,
+4858L, 4859L, 4862L, 4864L, 4867L, 4868L, 4871L, 4872L, 4878L,
+4880L, 4882L, 4884L, 4885L, 4886L, 4887L, 4889L, 4891L, 4892L,
+4893L, 4894L, 4895L, 4896L, 4899L, 4901L, 4902L, 4904L, 4906L,
+4907L, 4908L, 4913L, 4914L, 4915L, 4916L, 4917L, 4919L, 4920L,
+4931L, 4932L, 4934L, 4937L, 4941L, 4942L, 4944L, 4947L, 4949L,
+4952L, 4957L, 4964L, 4968L, 4970L, 4971L, 4972L, 4981L, 4982L,
+4983L, 4984L, 4987L, 4988L, 4992L, 4995L, 5000L, 5002L, 5003L,
+5009L, 5013L, 5019L, 5020L, 5021L, 5022L, 5023L, 5024L, 5025L,
+5026L, 5028L, 5029L, 5033L, 5036L, 5037L, 5038L, 5039L, 5040L,
+5041L, 5043L, 5044L, 5045L, 5046L, 5047L, 5048L, 5050L, 5051L,
+5052L, 5053L, 5054L, 5056L, 5057L, 5058L, 5059L, 5060L, 5061L,
+5062L, 5063L, 5064L, 5065L, 5066L, 5068L, 5069L, 5070L, 5071L,
+5073L, 5075L, 5076L, 5078L, 5080L, 5082L, 5083L, 5084L, 5085L,
+5086L, 5087L, 5090L, 5092L, 5094L, 5096L, 5098L, 5100L, 5102L,
+5103L, 5104L, 5107L, 5111L, 5112L, 5113L, 5114L, 5115L, 5116L,
+5118L, 5119L, 5120L, 5121L, 5122L, 5124L, 5125L, 5126L, 5129L,
+5131L, 5135L, 5136L, 5137L, 5138L, 5139L, 5140L, 5141L, 5142L,
+5143L, 5144L, 5145L, 5147L, 5148L, 5149L, 5150L, 5151L, 5153L,
+5154L, 5155L, 5156L, 5157L, 5158L, 5161L, 5162L, 5163L, 5165L,
+5166L, 5167L, 5169L, 5170L, 5172L, 5173L, 5175L, 5176L, 5177L,
+5178L, 5179L, 5180L, 5181L, 5182L, 5183L, 5184L, 5185L, 5186L,
+5187L, 5188L, 5189L, 5190L, 5191L, 5192L, 5193L, 5195L, 5196L,
+5197L, 5198L, 5199L, 5201L, 5202L, 5203L, 5205L, 5206L, 5207L,
+5208L, 5209L, 5210L, 5214L, 5215L, 5217L, 5218L, 5219L, 5221L,
+5222L, 5223L, 5224L, 5228L, 5229L, 5230L, 5231L, 5232L, 5234L,
+5235L, 5236L, 5239L, 5240L, 5241L, 5242L, 5243L, 5245L, 5246L,
+5248L, 5249L, 5250L, 5251L, 5252L, 5253L, 5254L, 5256L, 5257L,
+5258L, 5259L, 5260L, 5263L, 5264L, 5265L, 5268L, 5271L, 5272L,
+5273L, 5274L, 5275L, 5276L, 5277L, 5278L, 5281L, 5283L, 5284L,
+5286L, 5290L, 5292L, 5294L, 5295L, 5296L, 5298L, 5301L, 5302L,
+5303L, 5304L, 5305L, 5306L, 5307L, 5308L, 5309L, 5310L, 5311L,
+5312L, 5313L, 5315L, 5318L, 5319L, 5320L, 5322L, 5326L, 5327L,
+5329L, 5330L, 5332L, 5335L, 5336L, 5337L, 5338L, 5339L, 5340L,
+5341L, 5342L, 5345L, 5346L, 5347L, 5348L, 5349L, 5350L, 5351L,
+5352L, 5353L, 5355L, 5356L, 5358L, 5360L, 5363L, 5364L, 5365L,
+5366L, 5368L, 5369L, 5370L, 5371L, 5372L, 5373L, 5376L, 5378L,
+5380L, 5381L, 5382L, 5383L, 5384L, 5385L, 5386L, 5388L, 5389L,
+5393L, 5395L, 5396L, 5397L, 5398L, 5400L, 5401L, 5402L, 5403L,
+5405L, 5406L, 5407L, 5408L, 5409L, 5411L, 5415L, 5416L, 5417L,
+5418L, 5419L, 5421L, 5422L, 5423L, 5424L, 5425L, 5426L, 5428L,
+5429L, 5430L, 5431L, 5432L, 5436L, 5437L, 5438L, 5441L, 5443L,
+5444L, 5446L, 5447L, 5453L, 5454L, 5455L, 5457L, 5459L, 5460L,
+5462L, 5463L, 5465L, 5466L, 5469L, 5470L, 5471L, 5472L, 5474L,
+5476L, 5477L, 5478L, 5480L, 5481L, 5482L, 5485L, 5486L, 5487L,
+5489L, 5490L, 5492L, 5495L, 5498L, 5501L, 5502L, 5504L, 5505L,
+5506L, 5510L, 5511L, 5512L, 5517L, 5519L, 5520L, 5521L, 5522L,
+5524L, 5530L, 5531L, 5532L, 5536L, 5538L, 5543L, 5545L, 5547L,
+5548L, 5549L, 5550L, 5551L, 5555L, 5558L, 5559L, 5561L, 5562L,
+5563L, 5567L, 5569L, 5571L, 5573L, 5576L, 5577L, 5578L, 5579L,
+5583L, 5587L, 5588L, 5589L, 5590L, 5591L, 5593L, 5596L, 5597L,
+5598L, 5599L, 5600L, 5601L, 5602L, 5605L, 5606L, 5608L, 5609L,
+5610L, 5611L, 5612L, 5613L, 5614L, 5615L, 5616L, 5617L, 5621L,
+5622L, 5623L, 5624L, 5625L, 5626L, 5627L, 5628L, 5630L, 5632L,
+5633L, 5634L, 5635L, 5636L, 5637L, 5638L, 5639L, 5640L, 5641L,
+5643L, 5644L, 5645L, 5646L, 5647L, 5648L, 5649L, 5650L, 5651L,
+5652L, 5654L, 5655L, 5656L, 5657L, 5659L, 5660L, 5663L, 5665L,
+5666L, 5667L, 5668L, 5669L, 5670L, 5671L, 5672L, 5673L, 5674L,
+5675L, 5677L, 5678L, 5679L, 5680L, 5681L, 5684L, 5685L, 5686L,
+5687L, 5689L, 5690L, 5691L, 5692L, 5694L, 5696L, 5697L, 5703L,
+5704L, 5705L, 5706L, 5708L, 5709L, 5711L, 5712L, 5713L, 5715L,
+5716L, 5718L, 5719L, 5726L, 5727L, 5728L, 5729L, 5730L, 5733L,
+5735L, 5739L, 5740L, 5744L, 5746L, 5748L, 5750L, 5753L, 5754L,
+5757L, 5760L, 5761L, 5762L, 5768L, 5769L, 5770L, 5771L, 5772L,
+5773L, 5774L, 5775L, 5776L, 5777L, 5778L, 5779L, 5780L, 5782L,
+5784L, 5785L, 5787L, 5788L, 5789L, 5790L, 5792L, 5793L, 5795L,
+5796L, 5799L, 5800L, 5801L, 5802L, 5804L, 5805L, 5807L, 5808L,
+5809L, 5810L, 5811L, 5814L, 5815L, 5819L, 5820L, 5821L, 5823L,
+5824L, 5825L, 5826L, 5829L, 5830L, 5832L, 5833L, 5834L, 5836L,
+5837L, 5838L, 5842L, 5844L, 5845L, 5846L, 5847L, 5848L, 5849L,
+5850L, 5852L, 5853L, 5854L, 5855L, 5857L, 5858L, 5859L, 5860L,
+5861L, 5862L, 5865L, 5867L, 5868L, 5869L, 5870L, 5872L, 5873L,
+5874L, 5875L, 5876L, 5877L, 5878L, 5879L, 5880L, 5881L, 5882L,
+5883L, 5885L, 5886L, 5887L, 5888L, 5889L, 5891L, 5892L, 5893L,
+5894L, 5895L, 5896L, 5897L, 5898L, 5899L, 5900L, 5903L, 5905L,
+5906L, 5907L, 5908L, 5909L, 5910L, 5912L, 5915L, 5916L, 5917L,
+5919L, 5920L, 5923L, 5924L, 5925L, 5926L, 5927L, 5928L, 5929L,
+5931L, 5933L, 5934L, 5936L, 5939L, 5941L, 5944L, 5945L, 5946L,
+5948L, 5949L, 5950L, 5951L, 5953L, 5954L, 5955L, 5958L, 5960L,
+5961L, 5962L, 5963L, 5964L, 5968L, 5969L, 5971L, 5972L, 5973L,
+5974L, 5975L, 5976L, 5977L, 5978L, 5979L, 5980L, 5983L, 5985L,
+5986L, 5987L, 5988L, 5990L, 5992L, 5994L, 5996L, 5998L, 5999L,
+6000L, 6001L, 6002L, 6004L, 6005L, 6006L, 6007L, 6008L, 6010L,
+6011L, 6012L, 6013L, 6015L, 6016L, 6017L, 6019L, 6022L, 6023L,
+6024L, 6026L, 6027L, 6029L, 6030L, 6031L, 6032L, 6034L, 6035L,
+6036L, 6037L, 6038L, 6039L, 6041L, 6043L, 6045L, 6047L, 6050L,
+6051L, 6053L, 6055L, 6056L, 6057L, 6058L, 6060L, 6062L, 6064L,
+6065L, 6066L, 6067L, 6069L, 6071L, 6072L, 6073L, 6074L, 6075L,
+6078L, 6080L, 6083L, 6084L, 6086L, 6087L, 6089L, 6090L, 6091L,
+6095L, 6102L, 6106L, 6107L, 6108L, 6109L, 6110L, 6111L, 6112L,
+6115L, 6121L, 6122L, 6123L, 6124L, 6127L, 6129L, 6131L, 6133L,
+6138L, 6143L, 6144L, 6145L, 6146L, 6147L, 6148L, 6149L, 6150L,
+6152L, 6153L, 6154L, 6155L, 6156L, 6157L, 6159L, 6161L, 6163L,
+6164L, 6165L, 6166L, 6168L, 6172L, 6177L, 6178L, 6180L, 6183L,
+6185L, 6187L, 6190L, 6191L, 6193L, 6205L, 6206L, 6207L, 6208L,
+6214L, 6216L, 6217L, 6221L, 6223L, 6225L, 6229L, 6232L, 6234L,
+6235L, 6238L, 6240L, 6242L, 6243L, 6244L, 6245L, 6246L, 6247L,
+6248L, 6249L, 6250L, 6251L, 6253L, 6256L, 6258L, 6259L, 6268L,
+6276L, 6277L, 6278L, 6280L, 6282L, 6284L, 6285L, 6287L, 6290L,
+6292L, 6293L, 6294L, 6295L, 6300L, 6302L, 6303L, 6304L, 6305L,
+6306L, 6307L, 6308L, 6311L, 6312L, 6313L, 6314L, 6315L, 6319L,
+6320L, 6322L, 6323L, 6324L, 6325L, 6326L, 6329L, 6330L, 6331L,
+6332L, 6333L, 6334L, 6335L, 6336L, 6337L, 6338L, 6339L, 6340L,
+6343L, 6345L, 6346L, 6347L, 6348L, 6350L, 6352L, 6353L, 6354L,
+6356L, 6357L, 6358L, 6363L, 6364L, 6367L, 6368L, 6369L, 6371L,
+6372L, 6373L, 6375L, 6376L, 6377L, 6378L, 6379L, 6380L, 6381L,
+6384L, 6385L, 6386L, 6387L, 6389L, 6392L, 6393L, 6396L, 6397L,
+6398L, 6399L, 6401L, 6402L, 6404L, 6405L, 6407L, 6408L, 6411L,
+6412L, 6413L, 6415L, 6416L, 6417L, 6418L, 6419L, 6421L, 6424L,
+6426L, 6431L, 6432L, 6434L, 6436L, 6437L, 6438L, 6441L, 6442L,
+6443L, 6444L, 6445L, 6446L, 6447L, 6451L, 6453L, 6454L, 6455L,
+6456L, 6457L, 6458L, 6461L, 6465L, 6466L, 6467L, 6468L, 6469L,
+6470L, 6471L, 6472L, 6473L, 6476L, 6477L, 6478L, 6479L, 6480L,
+6482L, 6486L, 6487L, 6488L, 6489L, 6492L, 6495L, 6498L, 6499L,
+6500L, 6501L, 6503L, 6504L, 6505L, 6506L, 6508L, 6509L, 6510L,
+6514L, 6519L, 6521L, 6522L, 6523L, 6524L, 6525L, 6526L, 6527L,
+6528L, 6529L, 6530L, 6531L, 6532L, 6534L, 6535L, 6536L, 6537L,
+6539L, 6540L, 6541L, 6547L, 6548L, 6550L, 6551L, 6552L, 6554L,
+6555L, 6556L, 6557L, 6558L, 6559L, 6560L, 6561L, 6563L, 6564L,
+6565L, 6566L, 6567L, 6568L, 6569L, 6573L, 6577L, 6578L, 6579L,
+6580L, 6582L, 6584L, 6585L, 6588L, 6590L, 6591L, 6592L, 6593L,
+6597L, 6598L, 6611L, 6613L, 6619L, 6624L, 6634L, 6642L, 6644L,
+6645L, 6653L, 6655L, 6657L, 6669L, 6670L, 6671L, 6673L, 6674L,
+6678L, 6680L, 6687L, 6696L, 6701L, 6703L, 6704L, 6706L, 6707L,
+6709L, 6710L, 6711L, 6713L, 6714L, 6715L, 6716L, 6720L, 6721L,
+6722L, 6724L, 6726L, 6728L, 6729L, 6730L, 6731L, 6732L, 6733L,
+6734L, 6735L, 6737L, 6738L, 6740L, 6742L, 6743L, 6746L, 6747L,
+6748L, 6749L, 6750L, 6751L, 6752L, 6753L, 6755L, 6756L, 6757L,
+6759L, 6760L, 6761L, 6763L, 6766L, 6768L, 6769L, 6771L, 6772L,
+6775L, 6776L, 6778L, 6779L, 6781L, 6782L, 6783L, 6785L, 6786L,
+6787L, 6788L, 6791L, 6792L, 6794L, 6795L, 6799L, 6800L, 6801L,
+6803L, 6804L, 6805L, 6806L, 6807L, 6809L, 6811L, 6812L, 6813L,
+6815L, 6816L, 6818L, 6825L, 6826L, 6830L, 6832L, 6833L, 6834L,
+6835L, 6836L, 6838L, 6839L, 6840L, 6841L, 6842L, 6844L, 6846L,
+6849L, 6850L, 6851L, 6852L, 6853L, 6855L, 6856L, 6857L, 6860L,
+6861L, 6863L, 6867L, 6873L, 6876L, 6878L, 6879L, 6880L, 6882L,
+6885L, 6888L, 6897L, 6898L, 6902L, 6903L, 6904L, 6905L, 6906L,
+6909L, 6911L, 6912L, 6913L, 6916L, 6920L, 6922L, 6924L, 6925L,
+6927L, 6930L, 6933L, 6934L, 6935L, 6936L, 6937L, 6947L, 6950L,
+6951L, 6952L, 6953L, 6955L, 6956L, 6958L, 6960L, 6962L, 6965L,
+6968L, 6969L, 6970L, 6972L, 6973L, 6975L, 6976L, 6977L, 6979L,
+6981L, 6982L, 6984L, 6985L, 6988L, 6991L, 6992L, 6993L, 6994L,
+6995L, 7000L, 7001L, 7002L, 7003L, 7004L, 7005L, 7008L, 7009L,
+7013L, 7014L, 7015L, 7016L, 7017L, 7018L, 7019L, 7020L, 7021L,
+7022L, 7025L, 7026L, 7028L, 7029L, 7031L, 7033L, 7034L, 7035L,
+7036L, 7038L, 7039L, 7040L, 7041L, 7042L, 7043L, 7044L, 7045L,
+7048L, 7049L, 7051L, 7052L, 7053L, 7054L, 7055L, 7056L, 7057L,
+7059L, 7061L, 7062L, 7064L, 7066L, 7067L, 7069L, 7070L, 7071L,
+7072L, 7073L, 7074L, 7075L, 7076L, 7077L, 7079L, 7080L, 7081L,
+7082L, 7083L, 7085L, 7086L, 7087L, 7090L, 7091L, 7092L, 7093L,
+7094L, 7095L, 7097L, 7101L, 7102L, 7103L, 7104L, 7109L, 7110L,
+7111L, 7113L, 7116L, 7117L, 7119L, 7120L, 7121L, 7123L, 7124L,
+7125L, 7128L, 7129L, 7134L, 7136L, 7137L, 7139L, 7140L, 7141L,
+7142L, 7143L, 7144L, 7145L, 7147L, 7149L, 7151L, 7154L, 7155L,
+7156L, 7157L, 7158L, 7159L, 7163L, 7169L, 7171L, 7172L, 7175L,
+7180L, 7182L, 7183L, 7187L, 7188L, 7189L, 7192L, 7197L, 7198L,
+7199L, 7203L, 7204L, 7206L, 7209L, 7210L, 7211L, 7212L, 7213L,
+7214L, 7218L, 7220L, 7224L, 7225L, 7226L, 7229L, 7230L, 7231L,
+7232L, 7233L, 7234L, 7237L, 7238L, 7239L, 7240L, 7241L, 7244L,
+7245L, 7246L, 7247L, 7249L, 7250L, 7252L, 7256L, 7258L, 7259L,
+7260L, 7261L, 7262L, 7263L, 7264L, 7265L, 7266L, 7270L, 7271L,
+7272L, 7273L, 7274L, 7275L, 7276L, 7277L, 7278L, 7280L, 7282L,
+7283L, 7285L, 7286L, 7287L, 7288L, 7289L, 7290L, 7291L, 7298L,
+7299L, 7300L, 7301L, 7302L, 7303L, 7304L, 7306L, 7307L, 7308L,
+7309L, 7310L, 7311L, 7312L, 7313L, 7314L, 7315L, 7317L, 7318L,
+7320L, 7321L, 7322L, 7328L, 7330L, 7331L, 7332L, 7333L, 7334L,
+7335L, 7338L, 7339L, 7341L, 7350L, 7351L, 7353L, 7355L, 7358L,
+7359L, 7360L, 7366L, 7367L, 7368L, 7370L, 7371L, 7372L, 7373L,
+7374L, 7375L, 7376L, 7377L, 7379L, 7380L, 7381L, 7382L, 7384L,
+7386L, 7387L, 7389L, 7390L, 7395L, 7396L, 7397L, 7398L, 7399L,
+7400L, 7401L, 7402L, 7403L, 7404L, 7405L, 7406L, 7407L, 7408L,
+7409L, 7410L, 7411L, 7412L, 7413L, 7414L, 7417L, 7418L, 7422L,
+7423L, 7424L, 7426L, 7428L, 7429L, 7430L, 7431L, 7434L, 7436L,
+7437L, 7438L, 7439L, 7440L, 7441L, 7442L, 7443L, 7451L, 7452L,
+7453L, 7455L, 7456L, 7461L, 7462L, 7463L, 7464L, 7465L, 7466L,
+7467L, 7468L, 7471L, 7472L, 7474L, 7477L, 7479L, 7482L, 7483L,
+7484L, 7487L, 7492L, 7493L, 7494L, 7496L, 7500L, 7501L, 7509L,
+7511L, 7516L, 7518L, 7525L, 7530L, 7534L, 7536L, 7538L, 7541L,
+7542L, 7543L, 7546L, 7547L, 7578L, 7581L, 7582L, 7583L, 7584L,
+7585L, 7587L, 7589L, 7590L, 7591L, 7592L, 7593L, 7595L, 7596L,
+7597L, 7598L, 7599L, 7601L, 7602L, 7603L, 7604L, 7605L, 7607L,
+7611L, 7612L, 7613L, 7614L, 7615L, 7619L, 7620L, 7621L, 7623L,
+7624L, 7626L, 7627L, 7628L, 7632L, 7633L, 7634L, 7635L, 7636L,
+7637L, 7639L, 7640L, 7641L, 7642L, 7643L, 7644L, 7647L, 7648L,
+7649L, 7650L, 7651L, 7652L, 7653L, 7655L, 7656L, 7657L, 7661L,
+7662L, 7664L, 7666L, 7667L, 7668L, 7669L, 7670L, 7671L, 7672L,
+7673L, 7674L, 7676L, 7677L, 7678L, 7679L, 7680L, 7682L, 7683L,
+7684L, 7685L, 7686L, 7688L, 7689L, 7690L, 7693L, 7694L, 7695L,
+7696L, 7697L, 7699L, 7701L, 7702L, 7706L, 7708L, 7709L, 7710L,
+7711L, 7712L, 7713L, 7714L, 7716L, 7717L, 7718L, 7719L, 7720L,
+7724L, 7725L, 7727L, 7728L, 7730L, 7732L, 7735L, 7736L, 7737L,
+7738L, 7739L, 7740L, 7741L, 7742L, 7743L, 7745L, 7747L, 7748L,
+7751L, 7752L, 7753L, 7754L, 7755L, 7758L, 7759L, 7762L, 7764L,
+7765L, 7768L, 7769L, 7772L, 7775L, 7776L, 7777L, 7779L, 7784L,
+7785L, 7786L, 7788L, 7789L, 7790L, 7791L, 7792L, 7793L, 7797L,
+7798L, 7799L, 7801L, 7802L, 7803L, 7804L, 7805L, 7807L, 7808L,
+7809L, 7810L, 7811L, 7812L, 7813L, 7814L, 7815L, 7816L, 7818L,
+7819L, 7820L, 7824L, 7825L, 7826L, 7827L, 7829L, 7831L, 7832L,
+7833L, 7837L, 7838L, 7839L, 7841L, 7842L, 7843L, 7844L, 7847L,
+7848L, 7849L, 7850L, 7852L, 7853L, 7854L, 7855L, 7856L, 7858L,
+7859L, 7860L, 7861L, 7862L, 7863L, 7865L, 7866L, 7867L, 7868L,
+7870L, 7871L, 7872L, 7873L, 7874L, 7876L, 7879L, 7882L, 7883L,
+7885L, 7886L, 7887L, 7888L, 7889L, 7890L, 7892L, 7893L, 7894L,
+7895L, 7897L, 7898L, 7899L, 7900L, 7901L, 7902L, 7903L, 7904L,
+7906L, 7907L, 7908L, 7909L, 7910L, 7911L, 7912L, 7913L, 7914L,
+7915L, 7916L, 7917L, 7918L, 7919L, 7921L, 7922L, 7923L, 7925L,
+7927L, 7928L, 7930L, 7931L, 7934L, 7935L, 7938L, 7943L, 7945L,
+7946L, 7947L, 7948L, 7949L, 7954L, 7955L, 7956L, 7957L, 7958L,
+7959L, 7960L, 7961L, 7963L, 7964L, 7965L, 7966L, 7967L, 7968L,
+7969L, 7972L, 7973L, 7975L, 7976L, 7977L, 7979L, 7984L, 7987L,
+8004L, 8007L, 8011L, 8012L, 8013L, 8014L, 8015L, 8017L, 8018L,
+8019L, 8026L, 8027L, 8029L, 8030L, 8032L, 8033L, 8034L, 8035L,
+8036L, 8038L, 8039L, 8040L, 8042L, 8043L, 8044L, 8046L, 8048L,
+8049L, 8050L, 8051L, 8055L, 8065L, 8067L, 8068L, 8070L, 8073L,
+8074L, 8076L, 8078L, 8079L, 8080L, 8081L, 8082L, 8083L, 8084L,
+8086L, 8088L, 8089L, 8090L, 8093L, 8095L, 8096L, 8098L, 8099L,
+8102L, 8104L, 8105L, 8106L, 8107L, 8108L, 8109L, 8110L, 8112L,
+8114L, 8116L, 8117L, 8118L, 8119L, 8121L, 8124L, 8126L, 8127L,
+8128L, 8129L, 8130L, 8131L, 8132L, 8137L, 8138L, 8140L, 8141L,
+8142L, 8143L, 8144L, 8145L, 8148L, 8151L, 8152L, 8153L, 8154L,
+8155L, 8156L, 8157L, 8158L, 8159L, 8164L, 8166L, 8168L, 8169L,
+8170L, 8171L, 8174L, 8176L, 8177L, 8179L, 8180L, 8182L, 8183L,
+8185L, 8187L, 8188L, 8189L, 8190L, 8191L, 8192L, 8193L, 8194L,
+8195L, 8196L, 8197L, 8198L, 8199L, 8200L, 8201L, 8203L, 8204L,
+8206L, 8208L, 8209L, 8210L, 8211L, 8212L, 8213L, 8214L, 8215L,
+8217L, 8218L, 8219L, 8220L, 8221L, 8222L, 8225L, 8226L, 8227L,
+8228L, 8229L, 8231L, 8232L, 8233L, 8234L, 8236L, 8237L, 8239L,
+8240L, 8241L, 8242L, 8243L, 8244L, 8248L, 8250L, 8254L, 8255L,
+8256L, 8257L, 8258L, 8259L, 8260L, 8262L, 8266L, 8269L, 8270L,
+8272L, 8273L, 8274L, 8275L, 8276L, 8277L, 8279L, 8280L, 8281L,
+8282L, 8283L, 8284L, 8285L, 8286L, 8287L, 8288L, 8289L, 8290L,
+8291L, 8292L, 8293L, 8294L, 8295L, 8296L, 8297L, 8298L, 8299L,
+8301L, 8302L, 8303L, 8304L, 8305L, 8306L, 8307L, 8308L, 8309L,
+8310L, 8312L, 8313L, 8314L, 8315L, 8316L, 8317L, 8318L, 8319L,
+8320L, 8321L, 8325L, 8327L, 8329L, 8330L, 8332L, 8333L, 8334L,
+8335L, 8336L, 8338L, 8339L, 8340L, 8341L, 8342L, 8343L, 8344L,
+8345L, 8346L, 8347L, 8348L, 8349L, 8350L, 8353L, 8354L, 8355L,
+8356L, 8357L, 8361L, 8362L, 8363L, 8364L, 8366L, 8367L, 8368L,
+8369L, 8371L, 8373L, 8374L, 8375L, 8377L, 8378L, 8379L, 8380L,
+8381L, 8383L, 8385L, 8386L, 8387L, 8390L, 8391L, 8392L, 8393L,
+8394L, 8395L, 8398L, 8399L, 8400L, 8401L, 8402L, 8403L, 8404L,
+8406L, 8407L, 8408L, 8409L, 8410L, 8411L, 8412L, 8413L, 8414L,
+8415L, 8416L, 8417L, 8420L, 8421L, 8422L, 8426L, 8427L, 8429L,
+8430L, 8431L, 8432L, 8433L, 8435L, 8437L, 8439L, 8440L, 8442L,
+8444L, 8445L, 8447L, 8449L, 8450L, 8451L, 8453L, 8454L, 8455L,
+8457L, 8458L, 8459L, 8460L, 8461L, 8463L, 8465L, 8466L, 8468L,
+8470L, 8471L, 8473L, 8474L, 8475L, 8479L, 8480L, 8482L, 8484L,
+8488L, 8490L, 8492L, 8493L, 8494L, 8495L, 8498L, 8499L, 8500L,
+8503L, 8504L, 8505L, 8506L, 8507L, 8508L, 8510L, 8511L, 8513L,
+8514L, 8515L, 8516L, 8517L, 8519L, 8521L, 8522L, 8523L, 8524L,
+8525L, 8527L, 8528L, 8529L, 8530L, 8531L, 8532L, 8533L, 8534L,
+8535L, 8536L, 8537L, 8538L, 8539L, 8540L, 8541L, 8542L, 8543L,
+8544L, 8545L, 8546L, 8549L, 8550L, 8551L, 8552L, 8555L, 8556L,
+8557L, 8558L, 8559L, 8560L, 8563L, 8564L, 8565L, 8566L, 8568L,
+8569L, 8571L, 8572L, 8573L, 8574L, 8576L, 8579L, 8580L, 8581L,
+8582L, 8583L, 8585L, 8586L, 8587L, 8588L, 8590L, 8591L, 8593L,
+8594L, 8595L, 8596L, 8599L, 8600L, 8601L, 8603L, 8610L, 8611L,
+8612L, 8613L, 8614L, 8615L, 8616L, 8617L, 8618L, 8619L, 8620L,
+8621L, 8622L, 8623L, 8625L, 8627L, 8629L, 8630L, 8631L, 8636L,
+8637L, 8640L, 8642L, 8643L, 8644L, 8645L, 8646L, 8647L, 8648L,
+8649L, 8652L, 8655L, 8656L, 8657L, 8658L, 8659L, 8661L, 8662L,
+8663L, 8664L, 8666L, 8668L, 8669L, 8671L, 8672L, 8673L, 8674L,
+8675L, 8676L, 8677L, 8678L, 8682L, 8683L, 8684L, 8685L, 8686L,
+8687L, 8688L, 8690L, 8691L, 8693L, 8694L, 8695L, 8696L, 8699L,
+8702L, 8703L, 8704L, 8705L, 8706L, 8707L, 8708L, 8709L, 8710L,
+8712L, 8713L, 8714L, 8715L, 8716L, 8719L, 8721L, 8723L, 8724L,
+8725L, 8726L, 8728L, 8730L, 8731L, 8732L, 8733L, 8734L, 8737L,
+8738L, 8739L, 8741L, 8746L, 8747L, 8751L, 8752L, 8753L, 8754L,
+8755L, 8759L, 8761L, 8763L, 8766L, 8768L, 8769L, 8770L, 8778L,
+8779L, 8780L, 8781L, 8783L, 8784L, 8790L, 8792L, 8793L, 8794L,
+8795L, 8797L, 8802L, 8803L, 8805L, 8806L, 8812L, 8813L, 8814L,
+8815L, 8816L, 8817L, 8819L, 8821L, 8826L, 8827L, 8833L, 8834L,
+8835L, 8837L, 8838L, 8840L, 8841L, 8842L, 8845L, 8846L, 8847L,
+8848L, 8850L, 8851L, 8852L, 8854L, 8856L, 8859L, 8860L, 8862L,
+8863L, 8864L, 8866L, 8868L, 8870L, 8871L, 8872L, 8873L, 8874L,
+8876L, 8877L, 8879L, 8881L, 8882L, 8883L, 8884L, 8885L, 8886L,
+8887L, 8888L, 8889L, 8890L, 8891L, 8892L, 8893L, 8895L, 8896L,
+8899L, 8901L, 8905L, 8907L, 8908L, 8910L, 8911L, 8912L, 8914L,
+8915L, 8916L, 8918L, 8921L, 8922L, 8924L, 8925L, 8926L, 8927L,
+8928L, 8929L, 8931L, 8932L, 8934L, 8937L, 8938L, 8939L, 8940L,
+8941L, 8942L, 8943L, 8944L, 8945L, 8946L, 8947L, 8948L, 8949L,
+8950L, 8951L, 8952L, 8953L, 8954L, 8956L, 8957L, 8958L, 8959L,
+8960L, 8961L, 8962L, 8963L, 8964L, 8965L, 8966L, 8967L, 8968L,
+8969L, 8971L, 8972L, 8974L, 8975L, 8976L, 8977L, 8980L, 8981L,
+8982L, 8983L, 8984L, 8985L, 8988L, 8989L, 8990L, 8991L, 8993L,
+9000L, 9001L, 9003L, 9004L, 9006L, 9007L, 9008L, 9009L, 9010L,
+9011L, 9012L, 9013L, 9015L, 9016L, 9017L, 9018L, 9021L, 9023L,
+9025L, 9027L, 9030L, 9031L, 9032L, 9033L, 9034L, 9035L, 9036L,
+9037L, 9038L, 9039L, 9040L, 9041L, 9042L, 9043L, 9047L, 9051L,
+9052L, 9053L, 9055L, 9056L, 9059L, 9063L, 9064L, 9067L, 9069L,
+9070L, 9071L, 9072L, 9073L, 9074L, 9075L, 9076L, 9078L, 9079L,
+9080L, 9081L, 9083L, 9085L, 9086L, 9089L, 9090L, 9091L, 9094L,
+9097L, 9098L, 9099L, 9103L, 9104L, 9105L, 9106L, 9107L, 9108L,
+9109L, 9110L, 9111L, 9113L, 9117L, 9119L, 9122L, 9123L, 9125L,
+9126L, 9128L, 9129L, 9130L, 9133L, 9134L, 9135L, 9136L, 9138L,
+9139L, 9140L, 9142L, 9143L, 9144L, 9145L, 9148L, 9149L, 9150L,
+9151L, 9154L, 9155L, 9156L, 9157L, 9158L, 9159L, 9160L, 9161L,
+9162L, 9163L, 9164L, 9166L, 9167L, 9170L, 9171L, 9172L, 9173L,
+9174L, 9175L, 9176L, 9177L, 9178L, 9179L, 9180L, 9182L, 9184L,
+9185L, 9186L, 9187L, 9189L, 9190L, 9191L, 9192L, 9193L, 9197L,
+9200L, 9202L, 9203L, 9204L, 9205L, 9206L, 9207L, 9208L, 9209L,
+9210L, 9211L, 9212L, 9213L, 9214L, 9216L, 9220L, 9221L, 9223L,
+9225L, 9228L, 9229L, 9231L, 9232L, 9236L, 9237L, 9238L, 9239L,
+9240L, 9243L, 9246L, 9248L, 9249L, 9250L, 9251L, 9252L, 9253L,
+9254L, 9255L, 9256L, 9257L, 9258L, 9259L, 9260L, 9261L, 9262L,
+9263L, 9264L, 9265L, 9267L, 9268L, 9270L, 9271L, 9272L, 9273L,
+9274L, 9275L, 9276L, 9278L, 9280L, 9281L, 9282L, 9283L, 9284L,
+9286L, 9289L, 9290L, 9293L, 9295L, 9296L, 9297L, 9299L, 9300L,
+9302L, 9304L, 9305L, 9307L, 9308L, 9309L, 9310L, 9311L, 9312L,
+9313L, 9314L, 9315L, 9319L, 9321L, 9322L, 9323L, 9324L, 9325L,
+9329L, 9332L, 9335L, 9336L, 9339L, 9340L, 9344L, 9345L, 9346L,
+9347L, 9348L, 9350L, 9351L, 9352L, 9353L, 9354L, 9357L, 9359L,
+9361L, 9366L, 9367L, 9369L, 9370L, 9371L, 9372L, 9373L, 9375L,
+9376L, 9377L, 9378L, 9379L, 9380L, 9381L, 9382L, 9383L, 9384L,
+9385L, 9388L, 9390L, 9392L, 9393L, 9394L, 9395L, 9397L, 9398L,
+9399L, 9400L, 9401L, 9402L, 9403L, 9404L, 9405L, 9407L, 9409L,
+9410L, 9415L, 9416L, 9417L, 9421L, 9422L, 9423L, 9424L, 9425L,
+9426L, 9427L, 9428L, 9429L, 9433L, 9434L, 9435L, 9437L, 9438L,
+9439L, 9440L, 9441L, 9442L, 9443L, 9444L, 9445L, 9446L, 9447L,
+9448L, 9449L, 9450L, 9451L, 9452L, 9453L, 9454L, 9455L, 9456L,
+9457L, 9459L, 9460L, 9461L, 9463L, 9464L, 9465L, 9466L, 9467L,
+9468L, 9469L, 9471L, 9472L, 9473L, 9474L, 9475L, 9477L, 9478L,
+9479L, 9480L, 9483L, 9484L, 9485L, 9486L, 9487L, 9488L, 9490L,
+9491L, 9492L, 9493L, 9496L, 9500L, 9502L, 9504L, 9505L, 9506L,
+9507L, 9508L, 9509L, 9510L, 9511L, 9512L, 9513L, 9514L, 9515L,
+9516L, 9517L, 9518L, 9519L, 9520L, 9521L, 9522L, 9523L, 9524L,
+9525L, 9526L, 9528L, 9529L, 9531L, 9532L, 9533L, 9534L, 9535L,
+9537L, 9538L, 9546L, 9547L, 9548L, 9551L, 9553L, 9555L, 9557L,
+9559L, 9560L, 9561L, 9562L, 9566L, 9567L, 9568L, 9569L, 9570L,
+9572L, 9573L, 9574L, 9575L, 9576L, 9577L, 9578L, 9579L, 9580L,
+9581L, 9583L, 9584L, 9585L, 9586L, 9587L, 9588L, 9589L, 9590L,
+9591L, 9592L, 9593L, 9594L, 9595L, 9596L, 9597L, 9598L, 9599L,
+9600L, 9601L, 9602L, 9603L, 9604L, 9606L, 9607L, 9608L, 9609L,
+9610L, 9611L, 9612L, 9613L, 9614L, 9616L, 9617L, 9619L, 9620L,
+9621L, 9622L, 9623L, 9624L, 9625L, 9626L, 9627L, 9628L, 9629L,
+9631L, 9632L, 9633L, 9634L, 9635L, 9636L, 9638L, 9639L, 9640L,
+9641L, 9642L, 9643L, 9644L, 9645L, 9646L, 9647L, 9648L, 9650L,
+9652L, 9653L, 9654L, 9655L, 9656L, 9657L, 9658L, 9659L, 9664L,
+9666L, 9667L, 9668L, 9669L, 9670L, 9671L, 9673L, 9674L, 9675L,
+9676L, 9677L, 9678L, 9679L, 9680L, 9681L, 9682L, 9683L, 9684L,
+9685L, 9688L, 9690L, 9691L, 9692L, 9693L, 9694L, 9695L, 9697L,
+9699L, 9700L, 9702L, 9703L, 9705L, 9706L, 9707L, 9708L, 9709L,
+9710L, 9711L, 9712L, 9713L, 9715L, 9716L, 9717L, 9718L, 9719L,
+9720L, 9721L, 9722L, 9723L, 9724L, 9725L, 9726L, 9727L, 9728L,
+9729L, 9731L, 9733L, 9735L, 9737L, 9738L, 9739L, 9740L, 9741L,
+9742L, 9743L, 9744L, 9745L, 9746L, 9747L, 9748L, 9749L, 9750L,
+9751L, 9756L, 9757L, 9758L, 9759L, 9760L, 9761L, 9762L, 9763L,
+9764L, 9765L, 9766L, 9768L, 9769L, 9771L, 9772L, 9776L, 9777L,
+9778L, 9779L, 9781L, 9782L, 9783L, 9786L, 9787L, 9790L, 9791L,
+9792L, 9795L, 9796L, 9798L, 9799L, 9800L, 9801L, 9804L, 9805L,
+9806L, 9808L, 9810L, 9813L, 9814L, 9817L, 9818L, 9819L, 9820L,
+9821L, 9822L, 9824L, 9825L, 9827L, 9829L, 9832L, 9833L, 9835L,
+9836L, 9839L, 9840L, 9842L, 9843L, 9844L, 9845L, 9846L, 9847L,
+9848L, 9849L, 9850L, 9851L, 9852L, 9853L, 9854L, 9857L, 9858L,
+9859L, 9860L, 9862L, 9863L, 9864L, 9866L, 9867L, 9868L, 9869L,
+9871L, 9872L, 9877L, 9878L, 9879L, 9880L, 9883L, 9884L, 9886L,
+9889L, 9890L, 9893L, 9894L, 9895L, 9896L, 9897L, 9898L, 9901L,
+9902L, 9903L, 9904L, 9906L, 9907L, 9909L, 9910L, 9911L, 9912L,
+9913L, 9914L, 9915L, 9916L, 9917L, 9920L, 9921L, 9925L, 9926L,
+9927L, 9928L, 9930L, 9931L, 9933L, 9936L, 9937L, 9938L, 9939L,
+9942L, 9943L, 9944L, 9945L, 9949L, 9951L, 9952L, 9953L, 9954L,
+9958L, 9960L, 9961L, 9962L, 9963L, 9965L, 9966L, 9967L, 9969L,
+9970L, 9971L, 9972L, 9973L, 9977L, 9980L, 9981L, 9982L, 9983L,
+9984L, 9985L, 9986L, 9987L, 9988L, 9989L, 9991L, 9992L, 9993L,
+9995L, 9996L, 9997L, 9999L, 10000L, 10002L, 10004L, 10005L, 10006L,
+10007L, 10008L, 10009L, 10011L, 10012L, 10013L, 10014L, 10015L,
+10016L, 10017L, 10018L, 10022L, 10023L, 10024L, 10025L, 10026L,
+10027L, 10028L, 10033L, 10034L, 10037L, 10038L, 10039L, 10041L,
+10043L, 10044L, 10045L, 10046L, 10047L, 10049L, 10050L, 10051L,
+10052L, 10053L, 10054L, 10057L, 10058L, 10059L, 10060L, 10061L,
+10062L, 10063L, 10064L, 10065L, 10066L, 10067L, 10068L, 10071L,
+10072L, 10073L, 10077L, 10078L, 10079L, 10080L, 10081L, 10083L,
+10084L, 10085L, 10086L, 10087L, 10088L, 10089L, 10090L, 10091L,
+10092L, 10093L, 10094L, 10096L, 10097L, 10098L, 10099L, 10100L,
+10101L, 10102L, 10103L, 10104L, 10105L, 10106L, 10109L, 10110L,
+10111L, 10112L, 10113L, 10114L, 10115L, 10116L, 10117L, 10118L,
+10119L, 10120L, 10122L, 10123L, 10126L, 10128L, 10129L, 10130L,
+10131L, 10132L, 10133L, 10134L, 10136L, 10137L, 10138L, 10141L,
+10142L, 10143L, 10144L, 10145L, 10146L, 10147L, 10148L, 10151L,
+10152L, 10155L, 10156L, 10158L, 10160L, 10162L, 10164L, 10166L,
+10170L, 10171L, 10172L, 10173L, 10174L, 10175L, 10176L, 10177L,
+10179L, 10180L, 10181L, 10182L, 10183L, 10184L, 10185L, 10187L,
+10188L, 10189L, 10190L, 10191L, 10192L, 10193L, 10196L, 10197L,
+10198L, 10200L, 10201L, 10202L, 10203L, 10204L, 10205L, 10206L,
+10207L, 10208L, 10209L, 10210L, 10211L, 10212L, 10213L, 10214L,
+10215L, 10216L, 10217L, 10218L, 10219L, 10220L, 10221L, 10223L,
+10224L, 10225L, 10226L, 10227L, 10228L, 10230L, 10231L, 10232L,
+10233L, 10234L, 10235L, 10240L, 10241L, 10243L, 10244L, 10245L,
+10247L, 10248L, 10250L, 10251L, 10257L, 10258L, 10259L, 10260L,
+10261L, 10262L, 10263L, 10265L, 10266L, 10267L, 10268L, 10269L,
+10270L, 10271L, 10272L, 10274L, 10276L, 10277L, 10278L, 10279L,
+10280L, 10281L, 10282L, 10284L, 10285L, 10286L, 10287L, 10288L,
+10289L, 10291L, 10292L, 10294L, 10295L, 10296L, 10297L, 10298L,
+10299L, 10300L, 10301L, 10302L, 10303L, 10304L, 10305L, 10307L,
+10308L, 10309L, 10310L, 10311L, 10312L, 10313L, 10315L, 10316L,
+10317L, 10318L, 10320L, 10321L, 10322L, 10323L, 10324L, 10325L,
+10326L, 10328L, 10330L, 10331L, 10332L, 10333L, 10334L, 10335L,
+10336L, 10337L, 10338L, 10339L, 10340L, 10341L, 10342L, 10343L,
+10344L, 10346L, 10347L, 10348L, 10349L, 10350L, 10351L, 10352L,
+10353L, 10354L, 10355L, 10356L, 10358L, 10359L, 10361L, 10362L,
+10363L, 10364L, 10365L, 10366L, 10367L, 10368L, 10369L, 10370L,
+10371L, 10372L, 10373L, 10374L, 10375L, 10376L, 10380L, 10382L,
+10383L, 10386L, 10387L, 10388L, 10389L, 10390L, 10391L, 10392L,
+10393L, 10394L, 10395L, 10397L, 10398L, 10399L, 10400L, 10401L,
+10403L, 10404L, 10406L, 10407L, 10409L, 10411L, 10412L, 10413L,
+10414L, 10415L, 10416L, 10419L, 10420L, 10423L, 10425L, 10426L,
+10430L, 10432L, 10433L, 10434L, 10435L, 10436L, 10437L, 10438L,
+10439L, 10442L, 10443L, 10444L, 10445L, 10446L, 10448L, 10449L,
+10450L, 10451L, 10452L, 10453L, 10456L, 10457L, 10459L, 10460L,
+10462L, 10463L, 10464L, 10465L, 10468L, 10469L, 10470L, 10471L,
+10472L, 10474L, 10476L, 10477L, 10478L, 10479L, 10480L, 10481L,
+10482L, 10483L, 10484L, 10487L, 10488L, 10490L, 10491L, 10492L,
+10493L, 10494L, 10495L, 10497L, 10498L, 10500L, 10501L, 10502L,
+10503L, 10504L, 10506L, 10508L, 10509L, 10511L, 10513L, 10514L,
+10515L, 10517L, 10518L, 10519L, 10521L, 10523L, 10525L, 10527L,
+10528L, 10529L), class = "data.frame")
diff --git a/inst/CITATION b/inst/CITATION
new file mode 100644
index 0000000..0c5220d
--- /dev/null
+++ b/inst/CITATION
@@ -0,0 +1,62 @@
+citHeader("To cite VGAM in publications please use:")
+
+## R >= 2.8.0 passes package metadata to citation().
+if(!exists("meta") || is.null(meta)) meta <- packageDescription("VGAM")
+year <- sub("-.*", "", meta$Date)
+note <- sprintf("R package version %s", meta$Version)
+
+
+citEntry(entry = "Article",
+ title = "Vector Generalized Additive Models",
+ author = personList(as.person("Thomas W. Yee"),
+ as.person("C. J. Wild")),
+ journal = "Journal of Royal Statistical Society, Series B",
+ year = "1996",
+ volume = "58",
+ number = "3",
+ pages = "481--493",
+
+ textVersion =
+ paste("Thomas W. Yee and C. J. Wild (1996).",
+ "Vector Generalized Additive Models.",
+ "Journal of Royal Statistical Society, Series B, 58(3), 481-493.")
+)
+
+citEntry(entry = "Article",
+ title = "The {VGAM} Package for Categorical Data Analysis",
+ author = personList(as.person("Thomas W. Yee")),
+ journal = "Journal of Statistical Software",
+ year = "2010",
+ volume = "32",
+ number = "10",
+ pages = "1--34",
+ url = "http://www.jstatsoft.org/v32/i10/",
+
+ textVersion =
+ paste("Thomas W. Yee (2010).",
+ "The VGAM Package for Categorical Data Analysis.",
+ "Journal of Statistical Software, 32(10), 1-34.",
+ "URL http://www.jstatsoft.org/v32/i10/."),
+ header = "and/or"
+)
+
+
+citEntry(entry = "Manual",
+ title = "{VGAM}: Vector Generalized Linear and Additive Models",
+ author = personList(as.person("Thomas W. Yee")),
+ year = year,
+ note = note,
+ url = "http://CRAN.R-project.org/package=VGAM",
+
+ textVersion =
+ paste("Thomas W. Yee",
+ sprintf("(%s).", year),
+ "VGAM: Vector Generalized Linear and Additive Models.",
+ paste(note, ".", sep = ""),
+ "URL http://CRAN.R-project.org/package=VGAM"),
+ header = "and/or"
+)
+
+
+
+
diff --git a/inst/doc/categoricalVGAM.Rnw b/inst/doc/categoricalVGAM.Rnw
new file mode 100644
index 0000000..84df1f5
--- /dev/null
+++ b/inst/doc/categoricalVGAM.Rnw
@@ -0,0 +1,2559 @@
+\documentclass[article,shortnames,nojss]{jss}
+\usepackage{thumbpdf}
+%% need no \usepackage{Sweave.sty}
+
+\SweaveOpts{engine=R,eps=FALSE}
+%\VignetteIndexEntry{The VGAM Package for Categorical Data Analysis}
+%\VignetteDepends{VGAM}
+%\VignetteKeywords{categorical data analysis, Fisher scoring, iteratively reweighted least squares, multinomial distribution, nominal and ordinal polytomous responses, smoothing, vector generalized linear and additive models, VGAM R package}
+%\VignettePackage{VGAM}
+
+%% new commands
+\newcommand{\sVLM}{\mbox{\scriptsize VLM}}
+\newcommand{\sformtwo}{\mbox{\scriptsize F2}}
+\newcommand{\pr}{\mbox{$P$}}
+\newcommand{\logit}{\mbox{\rm logit}}
+\newcommand{\bzero}{{\bf 0}}
+\newcommand{\bone}{{\bf 1}}
+\newcommand{\bid}{\mbox{\boldmath $d$}}
+\newcommand{\bie}{\mbox{\boldmath $e$}}
+\newcommand{\bif}{\mbox{\boldmath $f$}}
+\newcommand{\bix}{\mbox{\boldmath $x$}}
+\newcommand{\biy}{\mbox{\boldmath $y$}}
+\newcommand{\biz}{\mbox{\boldmath $z$}}
+\newcommand{\biY}{\mbox{\boldmath $Y$}}
+\newcommand{\bA}{\mbox{\rm \bf A}}
+\newcommand{\bB}{\mbox{\rm \bf B}}
+\newcommand{\bC}{\mbox{\rm \bf C}}
+\newcommand{\bH}{\mbox{\rm \bf H}}
+\newcommand{\bI}{\mbox{\rm \bf I}}
+\newcommand{\bX}{\mbox{\rm \bf X}}
+\newcommand{\bW}{\mbox{\rm \bf W}}
+\newcommand{\bY}{\mbox{\rm \bf Y}}
+\newcommand{\bbeta}{\mbox{\boldmath $\beta$}}
+\newcommand{\boldeta}{\mbox{\boldmath $\eta$}}
+\newcommand{\bmu}{\mbox{\boldmath $\mu$}}
+\newcommand{\bnu}{\mbox{\boldmath $\nu$}}
+\newcommand{\diag}{ \mbox{\rm diag} }
+\newcommand{\Var}{ \mbox{\rm Var} }
+\newcommand{\R}{{\textsf{R}}}
+\newcommand{\VGAM}{\pkg{VGAM}}
+
+
+\author{Thomas W.~Yee\\University of Auckland}
+\Plainauthor{Thomas W. Yee}
+
+\title{The \pkg{VGAM} Package for Categorical Data Analysis}
+\Plaintitle{The VGAM Package for Categorical Data Analysis}
+
+\Abstract{
+ Classical categorical regression models such as the multinomial logit and
+ proportional odds models are shown to be readily handled by the vector
+ generalized linear and additive model (VGLM/VGAM) framework. Additionally,
+ there are natural extensions, such as reduced-rank VGLMs for
+ dimension reduction, and allowing covariates that have values
+ specific to each linear/additive predictor,
+ e.g., for consumer choice modeling. This article describes some of the
+ framework behind the \pkg{VGAM} \R{}~package, its usage and implementation
+ details.
+}
+\Keywords{categorical data analysis, Fisher scoring,
+ iteratively reweighted least squares,
+ multinomial distribution, nominal and ordinal polytomous responses,
+ smoothing, vector generalized linear and additive models,
+ \VGAM{} \R{} package}
+\Plainkeywords{categorical data analysis, Fisher scoring,
+ iteratively reweighted least squares, multinomial distribution,
+ nominal and ordinal polytomous responses, smoothing,
+ vector generalized linear and additive models, VGAM R package}
+
+\Address{
+ Thomas W. Yee \\
+ Department of Statistics \\
+ University of Auckland, Private Bag 92019 \\
+ Auckland Mail Centre \\
+ Auckland 1142, New Zealand \\
+ E-mail: \email{t.yee at auckland.ac.nz}\\
+ URL: \url{http://www.stat.auckland.ac.nz/~yee/}
+}
+
+
+\begin{document}
+
+
+<<echo=FALSE, results=hide>>=
+library("VGAM")
+ps.options(pointsize = 12)
+options(width = 72, digits = 4)
+options(SweaveHooks = list(fig = function() par(las = 1)))
+options(prompt = "R> ", continue = "+")
+@
+
+
+% ----------------------------------------------------------------------
+\section{Introduction}
+\label{sec:jsscat.intoduction}
+
+
+This is a \pkg{VGAM} vignette for categorical data analysis (CDA)
+based on~\cite{Yee:2010}.
+Any subsequent features (especially non-backward compatible ones)
+will appear here.
+
+The subject of CDA is concerned with
+analyses where the response is categorical regardless of whether
+the explanatory variables are continuous or categorical. It is a
+very frequent form of data. Over the years several CDA regression
+models for polytomous responses have become popular, e.g., those
+in Table~\ref{tab:cat.quantities}. Not surprisingly, the models
+are interrelated: their foundation is the multinomial distribution
+and consequently they share similar and overlapping properties which
+modellers should know and exploit. Unfortunately, software has been
+slow to reflect their commonality and this makes analyses unnecessarily
+difficult for the practitioner on several fronts, e.g., using different
+functions/procedures to fit different models which does not aid the
+understanding of their connections.
+
+
+This historical misfortune can be seen by considering \R{}~functions
+for~CDA. From the Comprehensive \proglang{R} Archive Network
+(CRAN, \url{http://CRAN.R-project.org/}) there is~\texttt{polr()}
+\citep[in \pkg{MASS};][]{Venables+Ripley:2002} for a proportional odds
+model and~\texttt{multinom()}
+\citep[in~\pkg{nnet};][]{Venables+Ripley:2002} for the multinomial
+logit model. However, both of these can be considered `one-off'
+modeling functions rather than providing a unified offering for CDA.
+The function \texttt{lrm()} \citep[in \pkg{rms};][]{Harrell:2009}
+has greater functionality: it can fit the proportional odds model
+(and the forward continuation ratio model upon preprocessing). Neither
+\texttt{polr()} or \texttt{lrm()} appear able to fit the nonproportional
+odds model. There are non-CRAN packages too, such as the modeling
+function~\texttt{nordr()} \citep[in \pkg{gnlm};][]{gnlm:2007}, which can fit
+the proportional odds, continuation ratio and adjacent categories models;
+however it calls \texttt{nlm()} and the user must supply starting values.
+In general these \R{} \citep{R} modeling functions are not modular
+and often require preprocessing and sometimes are not self-starting.
+The implementations can be perceived as a smattering and piecemeal
+in nature. Consequently if the practitioner wishes to fit the models
+of Table~\ref{tab:cat.quantities} then there is a need to master several
+modeling functions from several packages each having different syntaxes
+etc. This is a hindrance to efficient CDA.
+
+
+
+\begin{table}[tt]
+\centering
+\begin{tabular}{|c|c|l|}
+\hline
+Quantity & Notation &
+%Range of~$j$ &
+\VGAM{} family function \\
+\hline
+%
+$\pr(Y=j+1) / \pr(Y=j)$ &$\zeta_{j}$ &
+%$1,\ldots,M$ &
+\texttt{acat()} \\
+%
+$\pr(Y=j) / \pr(Y=j+1)$ &$\zeta_{j}^{R}$ &
+%$2,\ldots,M+1$ &
+\texttt{acat(reverse = TRUE)} \\
+%
+$\pr(Y>j|Y \geq j)$ &$\delta_{j}^*$ &
+%$1,\ldots,M$ &
+\texttt{cratio()} \\
+%
+$\pr(Y<j|Y \leq j)$ &$\delta_{j}^{*R}$ &
+%$2,\ldots,M+1$ &
+\texttt{cratio(reverse = TRUE)} \\
+%
+$\pr(Y\leq j)$ &$\gamma_{j}$ &
+%$1,\ldots,M$ &
+\texttt{cumulative()} \\
+%
+$\pr(Y\geq j)$ &$\gamma_{j}^R$&
+%$2,\ldots,M+1$ &
+\texttt{cumulative(reverse = TRUE)} \\
+%
+$\log\{\pr(Y=j)/\pr(Y=M+1)\}$ & &
+%$1,\ldots,M$ &
+\texttt{multinomial()} \\
+%
+$\pr(Y=j|Y \geq j)$ &$\delta_{j}$ &
+%$1,\ldots,M$ &
+\texttt{sratio()} \\
+%
+$\pr(Y=j|Y \leq j)$ &$\delta_{j}^R$ &
+%$2,\ldots,M+1$ &
+\texttt{sratio(reverse = TRUE)} \\
+%
+\hline
+\end{tabular}
+\caption{
+Quantities defined in \VGAM{} for a
+categorical response~$Y$ taking values $1,\ldots,M+1$.
+Covariates \bix{} have been omitted for clarity.
+The LHS quantities are~$\eta_{j}$
+or~$\eta_{j-1}$ for~$j=1,\ldots,M$ (not reversed)
+and~$j=2,\ldots,M+1$ (if reversed), respectively.
+All models are estimated by minimizing the deviance.
+All except for \texttt{multinomial()} are suited to ordinal~$Y$.
+\label{tab:cat.quantities}
+}
+\end{table}
+
+
+
+
+\proglang{SAS} \citep{SAS} does not fare much better than~\R. Indeed,
+it could be considered as having an \textit{excess} of options which
+bewilders the non-expert user; there is little coherent overriding
+structure. Its \code{proc logistic} handles the multinomial logit
+and proportional odds models, as well as exact logistic regression
+\citep[see][which is for Version~8 of \proglang{SAS}]{stok:davi:koch:2000}.
+The fact that the proportional odds model may be fitted by \code{proc
+logistic}, \code{proc genmod} and \code{proc probit} arguably leads
+to possible confusion rather than the making of connections, e.g.,
+\code{genmod} is primarily for GLMs and the proportional odds model is not
+a GLM in the classical \cite{neld:wedd:1972} sense. Also, \code{proc
+phreg} fits the multinomial logit model, and \code{proc catmod} with
+its WLS implementation adds to further potential confusion.
+
+
+This article attempts to show how these deficiencies can be addressed
+by considering the vector generalized linear and additive model
+(VGLM/VGAM) framework, as implemented by the author's~\pkg{VGAM}
+package for~\R{}. The main purpose of this paper is to demonstrate
+how the framework is very well suited to many `classical' regression
+models for categorical responses, and to describe the implementation and
+usage of~\pkg{VGAM} for such. To this end an outline of this article
+is as follows. Section~\ref{sec:jsscat.VGLMVGAMoverview} summarizes
+the basic VGLM/VGAM framework. Section~\ref{sec:jsscat.vgamff}
+centers on functions for CDA in~\VGAM. Given an adequate framework,
+some natural extensions of Section~\ref{sec:jsscat.VGLMVGAMoverview} are
+described in Section~\ref{sec:jsscat.othermodels}. Users of \pkg{VGAM}
+can benefit from Section~\ref{sec:jsscat.userTopics} which shows how
+the software reflects their common theory. Some examples are given in
+Section~\ref{sec:jsscat.eg}. Section~\ref{sec:jsscat.implementDetails}
+contains selected topics in statistial computing that are
+more relevant to programmers interested in the underlying code.
+Section~\ref{sec:jsscat.extnUtil} discusses several utilities and
+extensions needed for advanced CDA modeling, and the article concludes
+with a discussion. This document was run using \pkg{VGAM}~0.7-10
+\citep{yee:VGAM:2010} under \R~2.10.0.
+
+
+Some general references for categorical data providing
+background to this article include
+\cite{agre:2002},
+\cite{fahr:tutz:2001},
+\cite{leon:2000},
+\cite{lloy:1999},
+\cite{long:1997},
+\cite{mccu:neld:1989} and
+\cite{simo:2003}.
+An overview of models for ordinal responses is~\cite{liu:agre:2005},
+and a manual for fitting common models found in~\cite{agre:2002}
+to polytomous responses with various software is~\cite{thom:2009}.
+A package for visualizing categorical data in~\R{} is~\pkg{vcd}
+\citep{Meyer+Zeileis+Hornik:2006,Meyer+Zeileis+Hornik:2009}.
+
+
+
+
+
+
+% ----------------------------------------------------------------------
+\section{VGLM/VGAM overview}
+\label{sec:jsscat.VGLMVGAMoverview}
+
+
+This section summarizes the VGLM/VGAM framework with a particular emphasis
+toward categorical models since the classes encapsulates many multivariate
+response models in, e.g., survival analysis, extreme value analysis,
+quantile and expectile regression, time series, bioassay data, nonlinear
+least-squares models, and scores of standard and nonstandard univariate
+and continuous distributions. The framework is partially summarized by
+Table~\ref{tab:rrvglam.jss.subset}. More general details about VGLMs
+and VGAMs can be found in \cite{yee:hast:2003} and \cite{yee:wild:1996}
+respectively. An informal and practical article connecting the general
+framework with the software is~\cite{Rnews:Yee:2008}.
+
+
+
+\subsection{VGLMs}
+\label{sec:wffc.appendixa.vglms}
+
+Suppose the observed response \biy{} is a $q$-dimensional vector.
+VGLMs are defined as a model for which the conditional distribution
+of $\biY$ given explanatory $\bix$ is of the form
+\begin{eqnarray}
+f(\biy | \bix ; \bB, \phi) ~=~ h(\biy, \eta_1,\ldots, \eta_M, \phi)
+\label{gammod}
+\end{eqnarray}
+for some known function $h(\cdot)$, where $\bB = (\bbeta_1 \,
+\bbeta_2 \, \cdots \, \bbeta_M)$ is a $p \times M$ matrix of
+unknown regression coefficients,
+and the~$j$th linear predictor is
+\begin{equation}
+\eta_j ~=~ \eta_j(\bix) ~=~ \bbeta_j^{\top} \bix ~=~
+\sum_{k=1}^p \beta_{(j)k} \, x_k , ~~~~ j=1,\ldots,M.
+\label{gammod2}
+\end{equation}
+Here $\bix=(x_1,\ldots,x_p)^{\top}$ with $x_1 = 1$ if there is an intercept.
+Note that~(\ref{gammod2}) means that \textit{all} the parameters may be
+potentially modelled as functions of~\bix. It can be seen that VGLMs are
+like GLMs but allow for multiple linear predictors, and they encompass
+models outside the small confines of the exponential family.
+In~(\ref{gammod}) the quantity~$\phi$ is an optional scaling parameter
+which is included for backward compatibility with common adjustments
+to overdispersion, e.g., with respect to GLMs.
+
+
+In general there is no relationship between~$q$ and~$M$: it
+depends specifically on the model or distribution to be fitted.
+However, for the `classical' categorical regression models of
+Table~\ref{tab:cat.quantities} we have~$M=q-1$ since~$q$ is the number
+of levels the multi-category response~$Y$ has.
+
+
+
+
+
+The $\eta_j$ of VGLMs may be applied directly to parameters of a
+distribution rather than just to a mean for GLMs. A simple example is
+a univariate distribution with a location parameter~$\xi$ and a scale
+parameter~$\sigma > 0$, where we may take~$\eta_1 = \xi$ and~$\eta_2 =
+\log\,\sigma$. In general, $\eta_{j}=g_{j}(\theta_{j})$ for some parameter
+link function~$g_{j}$ and parameter~$\theta_{j}$.
+For example, the adjacent categories models in
+Table~\ref{tab:cat.quantities} are ratios of two probabilities, therefore
+a log link of~$\zeta_{j}^{R}$ or~$\zeta_{j}$ is the default.
+In \VGAM{}, there are currently over a dozen links to choose from, of
+which any can be assigned to any parameter, ensuring maximum flexibility.
+Table~\ref{tab:jsscat.links} lists some of them.
+
+
+
+\begin{table}[tt]
+\centering
+%\ ~~~~ \par
+\begin{tabular}{|l|l|l|l|}
+\hline
+\ \ ~~~~~~~~~~~~ $\boldeta$ &
+Model & Modeling & Reference \\
+ & & function & \\
+%-------------------------------------------------------------
+\hline
+\hline
+%-------------------------------------------------------------
+ &&&\\[-1.1ex]
+$\bB_1^{\top} \bix_{1} + \bB_2^{\top} \bix_{2}\ ( = \bB^{\top} \bix)$ &
+VGLM & \texttt{vglm()}
+&
+\cite{yee:hast:2003} \\[1.6ex]
+%Yee \& Hastie~(2003) \\[1.6ex]
+%-------------------------------------------------------------
+\hline
+ &&&\\[-1.1ex]
+$\bB_1^{\top} \bix_{1} +
+ \sum\limits_{k=p_1+1}^{p_1+p_2} \bH_k \, \bif_{k}^{*}(x_k)$ &
+%\sum\limits_{k=1}^{p_2} \bH_k \, \bif_k(x_k)$ &
+VGAM & \texttt{vgam()}
+&
+\cite{yee:wild:1996} \\[2.2ex]
+%Yee \& Wild~(1996) \\[2.2ex]
+%-------------------------------------------------------------
+\hline
+ &&&\\[-1.1ex]
+$\bB_1^{\top} \bix_{1} + \bA \, \bnu$ &
+RR-VGLM & \texttt{rrvglm()}
+&
+\cite{yee:hast:2003} \\[1.8ex]
+%Yee \& Hastie~(2003) \\[1.8ex]
+%-------------------------------------------------------------
+\hline
+ &&&\\[-1.1ex]
+See \cite{yee:hast:2003} &
+Goodman's~RC & \texttt{grc()}
+&
+%\cite{yee:hast:2003} \\[1.8ex]
+\cite{good:1981} \\[1.8ex]
+%-------------------------------------------------------------
+\hline
+\end{tabular}
+\caption{
+Some of
+the package \VGAM{} and
+its framework.
+The vector of latent variables $\bnu = \bC^{\top} \bix_2$
+where
+$\bix^{\top} = (\bix_1^{\top}, \bix_2^{\top})$.
+\label{tab:rrvglam.jss.subset}
+}
+%\medskip
+\end{table}
+
+
+
+
+
+
+VGLMs are estimated using iteratively reweighted least squares~(IRLS)
+which is particularly suitable for categorical models
+\citep{gree:1984}.
+All models in this article have a log-likelihood
+\begin{equation}
+\ell ~=~ \sum_{i=1}^n \, w_i \, \ell_i
+\label{eq:log-likelihood.VGAM}
+\end{equation}
+where the~$w_i$ are known positive prior weights.
+Let~$\bix_i$ denote the explanatory vector for the~$i$th observation,
+for $i=1,\dots,n$.
+Then one can write
+\begin{eqnarray}
+\boldeta_i &=& \boldeta(\bix_i) ~=~
+\left(
+\begin{array}{c}
+\eta_1(\bix_i) \\
+\vdots \\
+\eta_M(\bix_i)
+\end{array} \right) ~=~
+\bB^{\top} \bix_i ~=~
+\left(
+\begin{array}{c}
+\bbeta_1^{\top} \bix_i \\
+\vdots \\
+\bbeta_M^{\top} \bix_i
+\end{array} \right)
+\nonumber
+\\
+&=&
+\left(
+\begin{array}{cccc}
+\beta_{(1)1} & \cdots & \beta_{(1)p} \\
+\vdots \\
+\beta_{(M)1} & \cdots & \beta_{(M)p} \\
+\end{array} \right)
+\bix_i ~=~
+\left(
+\bbeta_{(1)} \; \cdots \; \bbeta_{(p)}
+\right)
+\bix_i .
+\label{eq:lin.pred}
+\end{eqnarray}
+In IRLS,
+an adjusted dependent vector $\biz_i = \boldeta_i + \bW_i^{-1} \bid_i$
+is regressed upon a large (VLM) model matrix, with
+$\bid_i = w_i \, \partial \ell_i / \partial \boldeta_i$.
+The working weights $\bW_i$ here are
+$w_i \Var(\partial \ell_i / \partial \boldeta_i)$
+(which, under regularity conditions, is equal to
+$-w_i \, E[ \partial^2 \ell_i / (\partial \boldeta_i \,
+\partial \boldeta_i^{\top})]$),
+giving rise to the Fisher~scoring algorithm.
+
+
+Let $\bX=(\bix_1,\ldots,\bix_n)^{\top}$ be the usual $n \times p$
+(LM) model matrix
+obtained from the \texttt{formula} argument of \texttt{vglm()}.
+Given $\biz_i$, $\bW_i$ and~$\bX{}$ at the current IRLS iteration,
+a weighted multivariate regression is performed.
+To do this, a \textit{vector linear model} (VLM) model matrix
+$\bX_{\sVLM}$ is formed from~$\bX{}$ and~$\bH_k$
+(see Section~\ref{sec:wffc.appendixa.vgams}).
+This is has $nM$~rows, and if there are no constraints then $Mp$~columns.
+Then $\left(\biz_1^{\top},\ldots,\biz_n^{\top}\right)^{\top}$ is regressed
+upon $\bX_{\sVLM}$
+with variance-covariance matrix $\diag(\bW_1^{-1},\ldots,\bW_n^{-1})$.
+This system of linear equations is converted to one large
+WLS fit by premultiplication of the output of
+a Cholesky decomposition of the~$\bW_i$.
+
+
+Fisher~scoring usually has good numerical stability
+because the~$\bW_i$ are positive-definite over a larger
+region of parameter space than Newton-Raphson.
+For the categorical models in this article the expected
+information matrices are simpler than the observed
+information matrices, and are easily derived,
+therefore all the families in Table~\ref{tab:cat.quantities}
+implement Fisher~scoring.
+
+
+
+\subsection{VGAMs and constraint matrices}
+\label{sec:wffc.appendixa.vgams}
+
+
+VGAMs provide additive-model extensions to VGLMs, that is,
+(\ref{gammod2})~is generalized to
+\begin{equation}
+\eta_j(\bix) ~=~ \beta_{(j)1} +
+\sum_{k=2}^p \; f_{(j)k}(x_k), ~~~~ j = 1,\ldots, M,
+\label{addmod}
+\end{equation}
+a sum of smooth functions of the individual covariates, just as
+with ordinary GAMs \citep{hast:tibs:1990}. The $\bif_k =
+(f_{(1)k}(x_k),\ldots,f_{(M)k}(x_k))^{\top}$ are centered for uniqueness,
+and are estimated simultaneously using \textit{vector smoothers}.
+VGAMs are thus a visual data-driven method that is well suited to
+exploring data, and they retain the simplicity of interpretation that
+GAMs possess.
+
+
+
+An important concept, especially for CDA, is the idea of
+`constraints-on-the functions'.
+In practice we often wish to constrain the effect of a covariate to
+be the same for some of the~$\eta_j$ and to have no effect for others.
+We shall see below that this constraints idea is important
+for several categorical models because of a popular parallelism assumption.
+As a specific example, for VGAMs we may wish to take
+\begin{eqnarray*}
+\eta_1 & = & \beta_{(1)1} + f_{(1)2}(x_2) + f_{(1)3}(x_3), \\
+\eta_2 & = & \beta_{(2)1} + f_{(1)2}(x_2),
+\end{eqnarray*}
+so that $f_{(1)2} \equiv f_{(2)2}$ and $f_{(2)3} \equiv 0$.
+For VGAMs, we can represent these models using
+\begin{eqnarray}
+\boldeta(\bix) & = & \bbeta_{(1)} + \sum_{k=2}^p \, \bif_k(x_k)
+\ =\ \bH_1 \, \bbeta_{(1)}^* + \sum_{k=2}^p \, \bH_k \, \bif_k^*(x_k)
+\label{eqn:constraints.VGAM}
+\end{eqnarray}
+where $\bH_1,\bH_2,\ldots,\bH_p$ are known full-column rank
+\textit{constraint matrices}, $\bif_k^*$ is a vector containing a
+possibly reduced set of component functions and $\bbeta_{(1)}^*$ is a
+vector of unknown intercepts. With no constraints at all, $\bH_1 =
+\bH_2 = \cdots = \bH_p = \bI_M$ and $\bbeta_{(1)}^* = \bbeta_{(1)}$.
+Like the $\bif_k$, the~$\bif_k^*$ are centered for uniqueness.
+For VGLMs, the~$\bif_k$ are linear so that
+\begin{eqnarray}
+{\bB}^{\top} &=&
+\left(
+\bH_1 \bbeta_{(1)}^*
+ \;
+\Bigg|
+ \;
+\bH_2 \bbeta_{(2)}^*
+ \;
+\Bigg|
+ \;
+\cdots
+ \;
+\Bigg|
+ \;
+\bH_p \bbeta_{(p)}^*
+\right)
+\label{eqn:lin.coefs4}
+\end{eqnarray}
+for some vectors
+$\bbeta_{(1)}^*,\ldots,\bbeta_{(p)}^*$.
+
+
+The
+$\bX_{\sVLM}$ matrix is constructed from \bX{} and the $\bH_k$ using
+Kronecker product operations.
+For example, with trivial constraints,
+$\bX_{\sVLM} = \bX \otimes \bI_M$.
+More generally,
+\begin{eqnarray}
+\bX_{\sVLM} &=&
+\left(
+\left( \bX \, \bie_{1} \right) \otimes \bH_1
+ \;
+\Bigg|
+ \;
+\left( \bX \, \bie_{2} \right) \otimes \bH_2
+ \;
+\Bigg|
+ \;
+\cdots
+ \;
+\Bigg|
+ \;
+\left( \bX \, \bie_{p} \right) \otimes \bH_p
+\right)
+\label{eqn:X_vlm_Hk}
+\end{eqnarray}
+($\bie_{k}$ is a vector of zeros except for a one in the $k$th~position)
+so that
+$\bX_{\sVLM}$ is $(nM) \times p^*$ where
+$p^* = \sum_{k=1}^{p} \mbox{\textrm{ncol}}(\bH_k)$ is the total number
+of columns of all the constraint matrices.
+Note that $\bX_{\sVLM}$ and \bX{} can be obtained by
+\texttt{model.matrix(vglmObject, type = "vlm")}
+and
+\texttt{model.matrix(vglmObject, type = "lm")}
+respectively.
+Equation~\ref{eqn:lin.coefs4} focusses on the rows of~\bB{} whereas
+\ref{eq:lin.pred}~is on the columns.
+
+
+VGAMs are estimated by applying a modified vector backfitting algorithm
+\citep[cf.][]{buja:hast:tibs:1989} to the $\biz_i$.
+
+
+
+\subsection{Vector splines and penalized likelihood}
+\label{sec:ex.vspline}
+
+If~(\ref{eqn:constraints.VGAM}) is estimated using a vector spline (a
+natural extension of the cubic smoothing spline to vector responses)
+then it can be shown that the resulting solution maximizes a penalized
+likelihood; some details are sketched in~\cite{yee:step:2007}. In fact,
+knot selection for vector spline follows the same idea as O-splines
+\citep[see][]{wand:orme:2008} in order to lower the computational cost.
+
+
+The usage of \texttt{vgam()} with smoothing is very similar
+to~\texttt{gam()} \citep{gam:pack:2009}, e.g.,
+to fit a nonparametric proportional odds model
+\citep[cf.~p.179 of][]{mccu:neld:1989}
+to the pneumoconiosis data one could try
+<<eval=T>>=
+pneumo <- transform(pneumo, let=log(exposure.time))
+fit <- vgam(cbind(normal, mild, severe) ~ s(let, df=2),
+ cumulative(reverse=TRUE, parallel=TRUE), pneumo)
+@
+Here, setting \texttt{df = 1} means a linear fit so that
+\texttt{df = 2} affords a little nonlinearity.
+
+
+
+
+
+
+% ----------------------------------------------------------------------
+\section[VGAM family functions]{\pkg{VGAM} family functions}
+\label{sec:jsscat.vgamff}
+
+
+
+This section summarizes and comments on the~\VGAM{} family functions
+of Table~\ref{tab:cat.quantities} for a categorical response variable
+taking values $Y=1,2,\ldots,M+1$. In its most basic invokation, the usage
+entails a trivial change compared to \texttt{glm()}: use \texttt{vglm()}
+instead and assign the \texttt{family} argument a \VGAM{}~family function.
+The use of a \VGAM{}~family function to fit a specific model is far
+simpler than having a different modeling function for each model.
+Options specific to that model appear as arguments of that \VGAM{}~family
+function.
+
+
+
+
+
+While writing \texttt{cratio()} it was found that various authors defined
+the quantity ``continuation ratio'' differently, therefore it became
+necessary to define a ``stopping ratio''. Table~\ref{tab:cat.quantities}
+defines these quantities for \VGAM{}.
+
+
+
+
+The multinomial logit model is usually described by choosing the first or
+last level of the factor to be baseline. \VGAM{}~chooses the last level
+(Table~\ref{tab:cat.quantities}) by default, however that can be changed
+to any other level by use of the \texttt{refLevel} argument.
+
+
+
+
+If the proportional odds assumption is inadequate then one strategy is
+to try use a different link function (see Section~\ref{sec:jsscat.links}
+for a selection). Another alternative is to add extra terms such as
+interaction terms into the linear predictor
+\citep[available in the \proglang{S}~language;][]{cham:hast:1993}.
+Another is to fit the so-called \textit{partial}
+proportional odds model \citep{pete:harr:1990}
+which \VGAM{} can fit via constraint matrices.
+
+
+
+In the terminology of~\cite{agre:2002},
+\texttt{cumulative()} fits the class of \textit{cumulative link models},
+e.g.,
+\texttt{cumulative(link = probit)} is a cumulative probit model.
+For \texttt{cumulative()}
+it was difficult to decide whether
+\texttt{parallel = TRUE}
+or
+\texttt{parallel = FALSE}
+should be the default.
+In fact, the latter is (for now?).
+Users need to set
+\texttt{cumulative(parallel = TRUE)} explicitly to
+fit a proportional odds model---hopefully this will alert
+them to the fact that they are making
+the proportional odds assumption and
+check its validity (\cite{pete:1990}; e.g., through a deviance or
+likelihood ratio test). However the default means numerical problems
+can occur with far greater likelihood.
+Thus there is tension between the two options.
+As a compromise there is now a \VGAM{} family function
+called \texttt{propodds(reverse = TRUE)} which is equivalent to
+\texttt{cumulative(parallel = TRUE, reverse = reverse, link = "logit")}.
+
+
+
+By the way, note that arguments such as
+\texttt{parallel}
+can handle a slightly more complex syntax.
+A call such as
+\code{parallel = TRUE ~ x2 + x5 - 1} means the parallelism assumption
+is only applied to~$X_2$ and~$X_5$.
+This might be equivalent to something like
+\code{parallel = FALSE ~ x3 + x4}, i.e., to the remaining
+explanatory variables.
+
+
+
+
+
+% ----------------------------------------------------------------------
+\section{Other models}
+\label{sec:jsscat.othermodels}
+
+
+Given the VGLM/VGAM framework of Section~\ref{sec:jsscat.VGLMVGAMoverview}
+it is found that natural extensions are readily proposed in several
+directions. This section describes some such extensions.
+
+
+
+
+\subsection{Reduced-rank VGLMs}
+\label{sec:jsscat.RRVGLMs}
+
+
+Consider a multinomial logit model where $p$ and $M$ are both large.
+A (not-too-convincing) example might be the data frame \texttt{vowel.test}
+in the package \pkg{ElemStatLearn} \citep[see][]{hast:tibs:buja:1994}.
+The vowel recognition data set involves $q=11$ symbols produced from
+8~speakers with 6~replications of each. The training data comprises
+$10$~input features (not including the intercept) based on digitized
+utterances. A multinomial logit model fitted to these data would
+have $\widehat{\bB}$ comprising of $p \times (q-1) = 110$ regression
+coefficients for $n=8\times 6\times 11 = 528$ observations. The ratio
+of $n$~to the number of parameters is small, and it would be good to
+introduce some parsimony into the model.
+
+
+
+A simple and elegant solution is to represent $\widehat{\bB}$ by
+its reduced-rank approximation. To do this, partition $\bix$ into
+$(\bix_1^{\top}, \bix_2^{\top})^{\top}$ and $\bB = (\bB_1^{\top} \;
+\bB_2^{\top})^{\top}$ so that the reduced-rank regression is applied
+to~$\bix_2$. In general, \bB{} is a dense matrix of full rank, i.e., rank
+$=\min(M,p)$, and since there are $M \times p$ regression coefficients
+to estimate this is `too' large for some models and/or data sets.
+If we approximate~$\bB_2$ by a reduced-rank regression \begin{equation}
+\label{eq:rrr.BAC} \bB_2 ~=~ \bC{} \, \bA^{\top} \end{equation} and if
+the rank~$R$ is kept low then this can cut down the number of regression
+coefficients dramatically. If~$R=2$ then the results may be biplotted
+(\texttt{biplot()} in \VGAM{}). Here, \bC{} and \bA{} are $p_2 \times R$
+and $M \times R$ respectively, and usually they are `thin'.
+
+
+More generally, the class of \textit{reduced-rank VGLMs} (RR-VGLMs)
+is simply a VGLM where~$\bB_2$ is expressed as a product of two thin
+estimated matrices (Table~\ref{tab:rrvglam.jss.subset}). Indeed,
+\cite{yee:hast:2003} show that RR-VGLMs are VGLMs with constraint
+matrices that are unknown and estimated. Computationally, this is
+done using an alternating method: in~(\ref{eq:rrr.BAC}) estimate~\bA{}
+given the current estimate of~\bC{}, and then estimate~\bC{} given the
+current estimate of~\bA{}. This alternating algorithm is repeated until
+convergence within each IRLS iteration.
+
+
+Incidentally, special cases of RR-VGLMs have appeared in the
+literature. For example, a RR-multinomial logit model, is known as the
+\textit{stereotype} model \citep{ande:1984}. Another is \cite{good:1981}'s
+RC~model (see Section~\ref{sec:jsscat.rrr.goodman}) which is reduced-rank
+multivariate Poisson model. Note that the parallelism assumption of the
+proportional odds model \citep{mccu:neld:1989} can be thought of as a
+type of reduced-rank regression where the constraint matrices are thin
+($\bone_M$, actually) and known.
+
+
+
+The modeling function \texttt{rrvglm()} should work with any \VGAM{}
+family function compatible with \texttt{vglm()}. Of course, its
+applicability should be restricted to models where a reduced-rank
+regression of~$\bB_2$ makes sense.
+
+
+
+
+
+
+
+
+
+\subsection[Goodman's R x C association model]{Goodman's $R \times C$ association model}
+\label{sec:jsscat.rrr.goodman}
+
+
+
+
+
+Let~$\bY = [(y_{ij})]$ be a $n \times M$ matrix of counts.
+Section~4.2 of~\cite{yee:hast:2003} shows that Goodman's~RC$(R)$ association
+model \citep{good:1981} fits within the VGLM framework by setting up
+the appropriate indicator variables, structural zeros and constraint
+matrices. Goodman's model fits a reduced-rank type model to~\bY{}
+by firstly assuming that~$Y_{ij}$ has a Poisson distribution, and that
+\begin{eqnarray}
+\log \, \mu_{ij} &=& \mu + \alpha_{i} + \gamma_{j} +
+\sum_{k=1}^R a_{ik} \, c_{jk} ,
+\ \ \ i=1,\ldots,n;\ \ j=1,\ldots,M,
+\label{eqn:goodmanrc}
+\end{eqnarray}
+where $\mu_{ij} = E(Y_{ij})$ is the mean of the $i$-$j$ cell, and the
+rank~$R$ satisfies $R < \min(n,M)$.
+
+
+The modeling function \texttt{grc()} should work on any two-way
+table~\bY{} of counts generated by~(\ref{eqn:goodmanrc}) provided
+the number of 0's is not too large. Its usage is quite simple, e.g.,
+\texttt{grc(Ymatrix, Rank = 2)} fits a rank-2 model to a matrix of counts.
+By default a \texttt{Rank = 1} model is fitted.
+
+
+
+
+\subsection{Bradley-Terry models}
+\label{sec:jsscat.brat}
+
+Consider
+an experiment consists of $n_{ij}$ judges who compare
+pairs of items $T_i$, $i=1,\ldots,M+1$.
+They express their preferences between $T_i$ and $T_j$.
+Let $N=\sum \sum_{i<j} n_{ij}$ be the total number of pairwise
+comparisons, and assume independence for ratings of the same pair
+by different judges and for ratings of different pairs by the same judge.
+Let $\pi_i$ be the \textit{worth} of item~$T_i$,
+$$
+\pr(T_i > T_j) ~=~ p_{i/ij} ~=~ \frac{\pi_i}{\pi_i + \pi_j},
+\ ~~~~~i \neq {j},
+$$
+where ``$T_i>T_j$'' means~$i$ is preferred over~$j$.
+Suppose that $\pi_i > 0$.
+Let~$Y_{ij}$ be the number of times that $T_i$ is preferred
+over~$T_j$ in the~$n_{ij}$ comparisons of the pairs.
+Then~$Y_{ij} \sim {\rm Bin}(n_{ij},p_{i/ij})$.
+This is a Bradley-Terry model (without ties),
+and the \VGAM{} family function is~\texttt{brat()}.
+
+
+Maximum likelihood estimation of the parameters $\pi_1,\ldots,\pi_{M+1}$
+involves maximizing
+$$
+\prod_{i<j}^{M+1}
+\left(
+\begin{array}{c}
+n_{ij} \\
+y_{ij}
+\end{array} \right)
+\left(
+\frac{\pi_i}{\pi_i + \pi_j}
+\right)^{y_{ij}}
+\left(
+\frac{\pi_j}{\pi_i + \pi_j}
+\right)^{n_{ij}-y_{ij}} .
+$$
+By default, $\pi_{M+1} \equiv 1$ is used for identifiability,
+however, this can be changed very easily.
+Note that one can define
+linear predictors $\eta_{ij}$ of the form
+\begin{equation}
+\label{eq:bradter.logit}
+\logit
+\left(
+\frac{\pi_i}{\pi_i + \pi_j}
+\right) ~=~ \log
+\left(
+\frac{\pi_i}{\pi_j}
+\right) ~=~ \lambda_i - \lambda_j .
+\end{equation}
+The VGAM{} framework can handle the Bradley-Terry model only for
+intercept-only models; it has
+\begin{equation}
+\label{eq:bradter}
+\lambda_j ~=~ \eta_j ~=~ \log\, \pi_j = \beta_{(1)j},
+\ \ \ \ j=1,\ldots,M.
+\end{equation}
+
+
+As well as having many applications in the field of preferences,
+the Bradley-Terry model has many uses in modeling `contests' between
+teams~$i$ and~$j$, where only one of the teams can win in each
+contest (ties are not allowed under the classical model).
+The {packaging} function \texttt{Brat()} can be used to
+convert a square matrix into one that has more columns, to
+serve as input to \texttt{vglm()}.
+For example,
+for journal citation data where a citation of article~B
+by article~A is a win for article~B and a loss for article~A.
+On a specific data set,
+<<>>=
+journal <- c("Biometrika", "Comm.Statist", "JASA", "JRSS-B")
+squaremat <- matrix(c(NA, 33, 320, 284, 730, NA, 813, 276,
+ 498, 68, NA, 325, 221, 17, 142, NA), 4, 4)
+dimnames(squaremat) <- list(winner = journal, loser = journal)
+@
+then \texttt{Brat(squaremat)} returns a~$1 \times 12$ matrix.
+
+
+
+
+
+
+
+\subsubsection{Bradley-Terry model with ties}
+\label{sec:cat.bratt}
+
+
+The \VGAM{} family function \texttt{bratt()}
+implements
+a Bradley-Terry model with ties (no preference), e.g.,
+where both $T_i$ and $T_j$ are equally good or bad.
+Here we assume
+\begin{eqnarray*}
+ \pr(T_i > T_j) &=& \frac{\pi_i}{\pi_i + \pi_j + \pi_0},
+\ ~~~~~
+ \pr(T_i = T_j) ~=~ \frac{\pi_0}{\pi_i + \pi_j + \pi_0},
+\end{eqnarray*}
+with $\pi_0 > 0$ as an extra parameter.
+It has
+$$
+\boldeta=(\log \pi_1,\ldots, \log \pi_{M-1}, \log \pi_{0})^{\top}
+$$
+by default, where there are $M$~competitors and $\pi_M \equiv 1$.
+Like \texttt{brat()}, one can choose a different reference group
+and reference value.
+
+
+Other \R{}~packages for the Bradley-Terry model
+include \pkg{BradleyTerry}
+\citep[with and without ties;][]{firth:2005,firth:2008}
+and \pkg{prefmod} \citep{Hatzinger:2009}.
+
+
+
+
+\begin{table}[tt]
+\centering
+\begin{tabular}[small]{|l|c|}
+\hline
+\pkg{VGAM} family function & Independent parameters \\
+\hline
+\texttt{ABO()} & $p, q$ \\
+\texttt{MNSs()} & $m_S, m_s, n_S$ \\
+\texttt{AB.Ab.aB.ab()} & $p$ \\
+\texttt{AB.Ab.aB.ab2()} & $p$ \\
+\texttt{AA.Aa.aa()} & $p_A$ \\
+\texttt{G1G2G3()} & $p_1, p_2, f$ \\
+\hline
+\end{tabular}
+\caption{Some genetic models currently implemented
+and their unique parameters.
+\label{tab:gen.all}
+}
+\end{table}
+
+
+
+
+
+\subsection{Genetic models}
+\label{sec:jsscat.genetic}
+
+
+There are quite a number of population genetic models based on the
+multinomial distribution,
+e.g., \cite{weir:1996}, \cite{lang:2002}.
+Table~\ref{tab:gen.all} lists some \pkg{VGAM}~family functions for such.
+
+
+
+
+For example the ABO blood group system
+has two independent parameters~$p$ and~$q$, say.
+Here,
+the blood groups A, B and O~form six possible combinations (genotypes)
+consisting of AA, AO, BB, BO, AB, OO
+(see Table~\ref{tab:ABO}). A and~B are dominant over
+bloodtype~O. Let $p$, $q$ and $r$ be the probabilities
+for A, B and~O respectively (so that
+$p+q+r=1$) for a given population.
+The log-likelihood function is
+\[
+\ell(p,q) \;=\; n_A\, \log(p^2 + 2pr) + n_B\, \log(q^2 + 2qr) + n_{AB}\,
+\log(2pq) + 2 n_O\, \log(1-p-q),
+\]
+where $r = 1 - p -q$, $p \in (\,0,1\,)$,
+$q \in (\,0,1\,)$, $p+q<1$.
+We let $\boldeta = (g(p), g(r))^{\top}$ where $g$ is the link function.
+Any~$g$ from Table~\ref{tab:jsscat.links} appropriate for
+a parameter $\theta \in (0,1)$ will do.
+
+
+A toy example where $p=p_A$ and $q=p_B$ is
+<<>>=
+abodat <- data.frame(A = 725, B = 258, AB = 72, O = 1073)
+fit <- vglm(cbind(A, B, AB, O) ~ 1, ABO, abodat)
+coef(fit, matrix = TRUE)
+Coef(fit) # Estimated pA and pB
+@
+The function \texttt{Coef()}, which applies only to intercept-only models,
+applies to $g_{j}(\theta_{j})=\eta_{j}$
+the inverse link function $g_{j}^{-1}$ to~$\widehat{\eta}_{j}$
+to give~$\widehat{\theta}_{j}$.
+
+
+
+
+
+
+
+\begin{table}[tt]
+% Same as Table 14.1 of E-J, and Table 2.6 of Weir 1996
+\begin{center}
+\begin{tabular}{|l|cc|cc|c|c|}
+\hline
+Genotype & AA & AO & BB & BO & AB & OO \\
+Probability&$p^2$&$2pr$&$q^2$&$ 2qr$&$2pq$& $r^2$\\
+Blood group& A & A & B & B & AB & O \\
+\hline
+\end{tabular}
+\end{center}
+\caption{Probability table for the ABO blood group system.
+Note that $p$~and $q$~are the parameters and $r=1-p-q$.
+\label{tab:ABO}
+}
+\end{table}
+
+
+
+
+
+\subsection{Three main distributions}
+\label{sec:jsscat.3maindist}
+
+\cite{agre:2002} discusses three main distributions for categorical
+variables: binomial, multinomial, and Poisson
+\citep{thom:2009}.
+All these are well-represented in the \VGAM{} package,
+accompanied by variant forms.
+For example,
+there is a
+\VGAM{} family function named \texttt{mbinomial()}
+which implements a
+matched-binomial (suitable for matched case-control studies),
+Poisson ordination (useful in ecology for multi-species-environmental data),
+negative binomial families,
+positive and zero-altered and zero-inflated variants,
+and the bivariate odds ratio model
+\citep[\texttt{binom2.or()}; see Section~6.5.6 of][]{mccu:neld:1989}.
+The latter has an \texttt{exchangeable} argument to allow for an
+exchangeable error structure:
+\begin{eqnarray}
+\bH_1 ~=~
+\left( \begin{array}{cc}
+1 & 0 \\
+1 & 0 \\
+0 & 1 \\
+\end{array} \right), ~~~~~
+\bH_k ~=~
+\left( \begin{array}{cc}
+1 \\
+1 \\
+0 \\
+\end{array} \right), ~~k=2,\ldots,p,
+\label{eqn:blom.exchangeable}
+\end{eqnarray}
+since, for data $(Y_1,Y_2,\bix)$,
+$\logit \, P\!\left( Y_{j} = 1 \Big{|} \bix \right) =
+\eta_{j}$ for ${j}=1,2$, and
+$\log \, \psi = \eta_{3}$
+where $\psi$~is the odds ratio,
+and so $\eta_{1}=\eta_{2}$.
+Here, \texttt{binom2.or(zero = 3)} by default meaning $\psi$~is
+modelled as an intercept-only
+(in general, \texttt{zero} may be assigned an integer vector
+such that the value~$j$ means $\eta_{j} = \beta_{(j)1}$,
+i.e., the $j$th~linear/additive predictor is an intercept-only).
+See the online help for all of these models.
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+% ----------------------------------------------------------------------
+\section{Some user-oriented topics}
+\label{sec:jsscat.userTopics}
+
+
+Making the most of \VGAM{} requires an understanding of the general
+VGLM/VGAM framework described Section~\ref{sec:jsscat.VGLMVGAMoverview}.
+In this section we connect elements of that framework with the software.
+Before doing so it is noted that
+a fitted \VGAM{} categorical model has access to the usual
+generic functions, e.g.,
+\texttt{coef()} for
+$\left(\widehat{\bbeta}_{(1)}^{*T},\ldots,\widehat{\bbeta}_{(p)}^{*T}\right)^{\top}$
+(see Equation~\ref{eqn:lin.coefs4}),
+\texttt{constraints()} for $\bH_k$,
+\texttt{deviance()} for $2\left(\ell_{\mathrm{max}} - \ell\right)$,
+\texttt{fitted()} for $\widehat{\bmu}_i$,
+\texttt{logLik()} for $\ell$,
+\texttt{predict()} for $\widehat{\boldeta}_i$,
+\texttt{print()},
+\texttt{residuals(..., type = "response")} for $\biy_i - \widehat{\bmu}_i$ etc.,
+\texttt{summary()},
+\texttt{vcov()} for $\widehat{\Var}(\widehat{\bbeta})$,
+etc.
+The methods function for the extractor function
+\texttt{coef()} has an argument \texttt{matrix}
+which, when set \texttt{TRUE}, returns~$\widehat{\bB}$
+(see Equation~\ref{gammod}) as a $p \times M$ matrix,
+and this is particularly useful for confirming that a fit
+has made a parallelism assumption.
+
+
+
+
+
+
+
+\subsection{Common arguments}
+\label{sec:jsscat.commonArgs}
+
+
+The structure of the unified framework given in
+Section~\ref{sec:jsscat.VGLMVGAMoverview}
+appears clearly through
+the pool of common arguments
+shared by the
+\VGAM{} family functions in Table~\ref{tab:cat.quantities}.
+In particular,
+\texttt{reverse} and
+\texttt{parallel}
+are prominent with CDA.
+These are merely convenient shortcuts for the argument \texttt{constraints},
+which accepts a named list of constraint matrices~$\bH_k$.
+For example, setting
+\texttt{cumulative(parallel = TRUE)} would constrain the coefficients $\beta_{(j)k}$
+in~(\ref{gammod2}) to be equal for all $j=1,\ldots,M$,
+each separately for $k=2,\ldots,p$.
+That is, $\bH_k = \bone_M$.
+The argument~\texttt{reverse} determines the `direction' of
+the parameter or quantity.
+
+Another argument not so much used with CDA is~\texttt{zero};
+this accepts a vector specifying which~$\eta_j$ is to be modelled as
+an intercept-only; assigning a \texttt{NULL} means none.
+
+
+
+
+
+
+
+
+\subsection{Link functions}
+\label{sec:jsscat.links}
+
+Almost all \VGAM{} family functions
+(one notable exception is \texttt{multinomial()})
+allow, in theory, for any link function to be assigned to each~$\eta_j$.
+This provides maximum capability.
+If so then there is an extra argument to pass in any known parameter
+associated with the link function.
+For example, \texttt{link = "logoff", earg = list(offset = 1)}
+signifies a log link with a unit offset:
+$\eta_{j} = \log(\theta_{j} + 1)$ for some parameter~$\theta_{j}\ (> -1)$.
+The name \texttt{earg} stands for ``extra argument''.
+Table~\ref{tab:jsscat.links} lists some links relevant to categorical data.
+While the default gives a reasonable first choice,
+users are encouraged to try different links.
+For example, fitting a binary regression model
+(\texttt{binomialff()}) to the coal miners data set \texttt{coalminers} with
+respect to the response wheeze gives a
+nonsignificant regression coefficient for $\beta_{(1)3}$~with probit analysis
+but not with a logit link when
+$\eta = \beta_{(1)1} + \beta_{(1)2} \, \mathrm{age} + \beta_{(1)3} \, \mathrm{age}^2$.
+Developers and serious users are encouraged to write and use
+new link functions compatible with~\VGAM.
+
+
+
+
+
+
+\begin{table*}[tt]
+\centering
+\medskip
+\begin{tabular}{|l|c|c|}
+\hline
+Link function & $g(\theta)$ & Range of $\theta$ \\
+\hline
+\texttt{cauchit()} & $\tan(\pi(\theta-\frac12))$ & $(0,1)$ \\
+\texttt{cloglog()} & $\log_e\{-\log_e(1 - \theta)\}$ & $(0,1)$ \\
+\texttt{fisherz()} &
+$\frac12\,\log_e\{(1 + \theta)/(1 - \theta)\}$ & $(-1,1)$ \\
+\texttt{identity()} & $\theta$ & $(-\infty,\infty)$ \\
+\texttt{logc()} & $\log_e(1 - \theta)$ & $(-\infty,1)$ \\
+\texttt{loge()} & $\log_e(\theta)$ & $(0,\infty)$ \\
+\texttt{logit()} & $\log_e(\theta/(1 - \theta))$ & $(0,1)$ \\
+\texttt{logoff()} & $\log_e(\theta + A)$ & $(-A,\infty)$ \\
+\texttt{probit()} & $\Phi^{-1}(\theta)$ & $(0,1)$ \\
+\texttt{rhobit()} & $\log_e\{(1 + \theta)/(1 - \theta)\}$ & $(-1,1)$ \\
+\hline
+\end{tabular}
+\caption{
+Some \VGAM{} link functions pertinent to this article.
+\label{tab:jsscat.links}
+}
+\end{table*}
+
+
+
+
+
+
+
+
+
+% ----------------------------------------------------------------------
+\section{Examples}
+\label{sec:jsscat.eg}
+
+This section illustrates CDA modeling on three
+data sets in order to give a flavour of what is available in the package.
+
+
+
+\subsection{2008 World Fly Fishing Championships}
+\label{sec:jsscat.eg.WFFC}
+
+The World Fly Fishing Championships (WFFC)
+is a prestigious catch-and-release competition held annually.
+In 2008 it was held in New~Zealand during the month of March.
+The data was released and appears in~\VGAM{} as the data frames
+\texttt{wffc},
+\texttt{wffc.nc},
+\texttt{wffc.indiv} and
+\texttt{wffc.teams}.
+Details about the competition are found
+in the online help, as well as~\cite{yee:2010v}.
+
+
+Briefly, we will model the abundance of fish caught during each
+three-hour session amongst the 90 or so competitors (from about
+19~countries) who fished all their sessions. There were five~sectors
+(locations) labelled I--V for the Whanganui~River, Lake~Otamangakau,
+Lake~Rotoaira, Waihou~River and Waimakariri~River, respectively. The
+sessions were sequentially labelled 1--6 where odd and even
+numbers denote morning and afternoon respectively. There were
+three consecutive days of fishing during which each sector experienced
+a rest session.
+
+
+
+\cite{yee:2010v} fitted Poisson and negative
+binomial regressions to the numbers caught at each competitor-session
+combination.
+The negative
+binomial regression had an intercept-only for its
+index parameter~$k$ and
+$\Var(Y) = \mu(1+\mu / k)$.
+Both models had the log-linear relationship
+\begin{eqnarray}
+\label{eq:wffc.use.loglinear}
+\log \, \mu_{adsc} &=&
+\eta ~=~
+\beta_{(1)1} +
+\alpha_{s} +
+\beta_{a} +
+\gamma_{d} +
+\delta_{c}.
+\end{eqnarray}
+where $\mu = E(Y)$ is the mean number caught,
+$\beta_{(1)1}$~is the intercept,
+$\alpha_{s}$~are the sector effects for $s=1,\ldots,5$ sectors,
+$\delta_{c}$~are the ``competitor effects'' for $c=1,\ldots,91$ competitors
+(8~competitors who did not fish all~5 sessions were excluded),
+$\beta_{a}$~are the morning ($a=1$) and afternoon ($a=2$) effects,
+$\gamma_{d}$~are the day effects for
+day $d=1,2,3$.
+Recall for factors that the first level is baseline, e.g.,
+$\alpha_1=\beta_1=0$ etc.
+Not used here is $b=1,\ldots,19$ for which beat/boat was
+fished/used (e.g., fixed locations on the river).
+We will fit a proportional odds model with essentially the RHS
+of~(\ref{eq:wffc.use.loglinear}) as the linear predictor.
+
+
+
+Here is a peek at the data frame used.
+Each row of~\texttt{wffc.nc} is the number of captures
+by each sector-session-beat combination.
+<<>>=
+head(wffc.nc, 5)
+@
+
+
+We first process the data a little: create the regressor
+variables and restrict the analysis to anglers who fished all their
+sessions.
+Here, ``\texttt{nc}'' stands for numbers caught, and
+``\texttt{f}'' stands for factor.
+<<>>=
+fnc <- transform(wffc.nc,
+ finame = factor(iname),
+ fsector = factor(sector),
+ fday = factor(ceiling(session / 2)),
+ mornaft = 1 - (session %% 2),
+ fbeatboat = factor(beatboat))
+
+fnc <- fnc[with(fnc, !is.element(comid, c(99,72,80,93,45,71,97,78))),]
+fnc <- transform(fnc,
+ ordnum = ifelse(numbers <= 02, "few",
+ ifelse(numbers <= 10, "more", "most")))
+fnc$ordnum <- ordered(fnc$ordnum, levels = c("few", "more", "most"))
+@
+The variable \texttt{ordnum} is ordinal with 3~levels.
+The cut-points chosen here were decided upon by manual
+inspection; they gave approximately the same numbers in each level:
+<<>>=
+with(fnc, table(ordnum))
+@
+
+
+
+Now we are in a position to fit a proportional odds model
+to mimic~(\ref{eq:wffc.use.loglinear}).
+<<>>=
+fit.pom <- vglm(ordnum ~
+ fsector +
+ mornaft +
+ fday +
+ finame,
+ family = cumulative(parallel = TRUE, reverse = TRUE),
+ data = fnc)
+@
+Here, we set \texttt{reverse = TRUE} so that the coefficients
+have the same direction as a logistic regression.
+It means that if a regression coefficient is positive then
+an increasing value of an explanatory variable is associated
+with an increasing value of the response.
+One could have used \texttt{family = propodds} instead.
+
+
+
+Before interpreting some output let's check that the input was alright.
+<<>>=
+head(fit.pom at y, 3)
+colSums(fit.pom at y)
+@
+The checking indicates no problems with the input.
+
+
+
+Now let's look at some output. Note that the Whanganui~River,
+Mornings and Day~1 are the baseline levels of the factors. Also, the
+variable \texttt{mornaft} is 0~for morning and 1~for afternoons.
+Likewise, the factor \texttt{fday} has values \texttt{1}, \texttt{2}
+and \texttt{3}.
+<<>>=
+head(coef(fit.pom, matrix = TRUE), 10)
+#head(summary(fit.pom)@coef3, 10) # Old now since 0.7-10 is nicer
+@
+verifies the parallelism assumption.
+Standard errors and Wald statistics may be obtained by
+<<>>=
+head(coef(summary(fit.pom)), 10)
+@
+Not surprisingly, these results agree with the Poisson
+and negative binomial regressions
+\citep[reported in][]{yee:2010v}.
+The most glaring qualitative results are as follows.
+We use the rough rule of thumb that if
+the absolute value of the $t$~{statistic} is greater than~$2$
+then it is `statistically significant'.
+\begin{itemize}
+
+\item
+The two lakes were clearly less productive than the rivers.
+However, neither of the other two rivers were significantly different
+from the Whanganui~River.
+
+
+
+\item
+There is a noticeable day effect: the second day is not significantly
+different from the opening day but it is for the third day.
+The decreasing values of the fitted coefficients show there is an
+increasing catch-reduction (fish depletion if it were catch-and-keep)
+as the competition progressed. Replacing \texttt{fday} by a
+variable~\texttt{day} and entering that linearly gave a $t$~statistic
+of~$-4.0$: there is a significant decrease in catch over time.
+
+
+
+\item
+Mornings were more productive than afternoons. The $p$~value for this
+would be close to~5\%. This result is in line with the day effect: fishing
+often results in a `hammering' effect over time on fish populations,
+especially in small streams. Since the morning and afternoon sessions
+were fixed at 9.00am--12.00pm and 2.30--5.30pm daily, there was only
+$2\frac12$~hours for the fish to recover until the next angler arrived.
+
+
+\end{itemize}
+
+
+
+
+
+Let us check the proportional odds assumption with respect
+to the variable~\texttt{mornaft}.
+<<>>=
+fit.ppom <- vglm(ordnum ~
+ fsector +
+ mornaft +
+ fday +
+ finame,
+ cumulative(parallel = FALSE ~ 1 + mornaft, reverse=TRUE),
+ data = fnc)
+head(coef(fit.ppom, matrix = TRUE), 8)
+@
+As expected, all rows but~\texttt{(Intercept)} and~\texttt{mornaft}
+are identical due to the parallelism.
+Then
+<<>>=
+pchisq(deviance(fit.pom) - deviance(fit.ppom),
+ df = df.residual(fit.pom) - df.residual(fit.ppom), lower.tail=FALSE)
+@
+gives a likelihood ratio test $p$~value which is non-significant.
+Repeating the testing for each variable separately indicates
+that the parallelism assumption seems reasonable here except
+with~\texttt{fday} ($p$~value $\approx 0.012$).
+For this model
+<<>>=
+fit2.ppom <- vglm(ordnum ~
+ fsector +
+ mornaft +
+ fday +
+ finame,
+ family = cumulative(parallel = FALSE ~ 1 + fday, reverse = TRUE),
+ data=fnc)
+head(coef(fit2.ppom, matrix = TRUE), 8)
+@
+
+
+Some miscellaneous output is as follows.
+<<>>=
+head(fitted(fit2.ppom), 3)
+@
+are the fitted probabilities $\widehat{P}(Y={j})$ which sum to unity for
+each row.
+The $i$th~row of
+<<>>=
+head(predict(fit2.ppom), 3)
+@
+is $\widehat{\boldeta}(\bix_i)^{\top}$.
+The dimensions of the LM and VLM design matrices are
+<<>>=
+dim(model.matrix(fit2.ppom, type = "lm"))
+dim(model.matrix(fit2.ppom, type = "vlm"))
+@
+which shows the VLM matrix grows quickly with respect to~$M$.
+Lastly,
+<<>>=
+constraints(fit2.ppom)[c(1, 2, 5, 6)]
+@
+shows some of the constraint matrices,
+$\bH_1=\bI_2$
+and
+$\bH_2=\bH_5=\bH_6=\bone_2$
+(see Equations~\ref{eqn:constraints.VGAM}--\ref{eqn:lin.coefs4}).
+
+
+
+
+
+
+
+\subsection{Marital status data}
+\label{sec:jsscat.eg.mstatus}
+
+We fit a nonparametric multinomial logit model to data collected from
+a self-administered questionnaire administered in a large New Zealand
+workforce observational study conducted during 1992--3.
+The data were augmented by a second study consisting of retirees.
+For homogeneity, this analysis is restricted
+to a subset of 6053 European males with no missing values.
+The ages ranged between~16 and 88~years.
+The data can be considered a reasonable representation of the white
+male New Zealand population in the early 1990s, and
+are detailed in~\cite{macm:etal:1995} and~\cite{yee:wild:1996}.
+We are interested in exploring how $Y=$ marital status varies as a function
+of $x_2=$ age. The nominal response~$Y$ has four levels;
+in sorted order, they are divorced or separated, married or partnered,
+single and widower.
+We will write these levels as $Y=1$, $2$, $3$, $4$, respectively,
+and will choose the married/partnered (second level) as the reference group
+because the other levels emanate directly from it.
+
+Suppose the data is in a data frame called \texttt{nzmarital}
+and looks like
+<<>>=
+head(nzmarital, 4)
+summary(nzmarital)
+@
+We fit the VGAM
+<<>>=
+fit.ms <- vgam(mstatus ~ s(age, df = 3), multinomial(refLevel=2),
+ data = nzmarital)
+@
+
+Once again let's firstly check the input.
+<<>>=
+head(fit.ms at y, 4)
+colSums(fit.ms at y)
+@
+This seems ok.
+
+
+
+
+Now the estimated component functions $\widehat{f}_{(s)2}(x_2)$
+may be plotted with
+<<fig=F>>=
+# Plot output
+mycol <- c("red","darkgreen","blue")
+ par(mfrow=c(2,2))
+plot(fit.ms, se=TRUE, scale=12,
+ lcol=mycol, scol=mycol)
+
+# Plot output overlayed
+#par(mfrow=c(1,1))
+plot(fit.ms, se=TRUE, scale=12,
+ overlay=TRUE,
+ llwd=2,
+ lcol=mycol, scol=mycol)
+@
+to produce Figure~\ref{fig:jsscat.eg.mstatus}.
+The \texttt{scale} argument is used here to ensure that the $y$-axes have
+a common scale---this makes comparisons between the component functions
+less susceptible to misinterpretation.
+The first three plots are the (centered) $\widehat{f}_{(s)2}(x_2)$ for
+$\eta_1$,
+$\eta_2$,
+$\eta_3$,
+where
+\begin{eqnarray}
+\label{eq:jsscat.eg.nzms.cf}
+\eta_{s} ~=~
+\log(\pr(Y={t}) / \pr(Y={2})) ~=~
+\beta_{(s)1} + f_{(s)2}(x_2),
+\end{eqnarray}
+$(s,t) = (1,1), (2,3), (3,4)$,
+and~$x_2$ is~\texttt{age}.
+The last plot are the smooths overlaid to aid comparison.
+
+
+It may be seen that the $\pm 2$ standard error bands
+about the \texttt{Widowed} group is particularly wide at
+young ages because of a paucity of data, and
+likewise at old ages amongst the \texttt{Single}s.
+The $\widehat{f}_{(s)2}(x_2)$ appear as one would expect.
+The log relative risk of
+being single relative to being married/partnered drops sharply from
+ages~16 to~40.
+The fitted function for the~\texttt{Widowed} group increases
+with~\texttt{age} and looks reasonably linear.
+The $\widehat{f}_{(1)2}(x_2)$
+suggests a possible maximum around 50~years old---this
+could indicate the greatest marital conflict occurs during
+the mid-life crisis years!
+
+
+
+\setkeys{Gin}{width=0.9\textwidth} % 0.8 is the current default
+
+\begin{figure}[tt]
+\begin{center}
+<<fig=TRUE,width=8,height=5.6,echo=FALSE>>=
+# Plot output
+mycol <- c("red","darkgreen","blue")
+ par(mfrow=c(2,2))
+ par(mar=c(4.2,4.0,1.2,2.2)+0.1)
+plot(fit.ms, se=TRUE, scale=12,
+ lcol=mycol, scol=mycol)
+
+# Plot output overlaid
+#par(mfrow=c(1,1))
+plot(fit.ms, se=TRUE, scale=12,
+ overlay=TRUE,
+ llwd=2,
+ lcol=mycol, scol=mycol)
+@
+\caption{
+Fitted (and centered) component functions
+$\widehat{f}_{(s)2}(x_2)$
+from the NZ marital status data
+(see Equation~\ref{eq:jsscat.eg.nzms.cf}).
+The bottom RHS plot are the smooths overlaid.
+\label{fig:jsscat.eg.mstatus}
+}
+\end{center}
+\end{figure}
+
+\setkeys{Gin}{width=0.8\textwidth} % 0.8 is the current default
+
+
+
+The methods function for~\texttt{plot()} can also plot the
+derivatives of the smooths.
+The call
+<<fig=F>>=
+plot(fit.ms, deriv=1, lcol=mycol, scale=0.3)
+@
+results in Figure~\ref{fig:jsscat.eg.mstatus.cf.deriv}.
+Once again the $y$-axis scales are commensurate.
+
+\setkeys{Gin}{width=\textwidth} % 0.8 is the current default
+
+\begin{figure}[tt]
+\begin{center}
+<<fig=TRUE,width=7.2,height=2.4,echo=FALSE>>=
+# Plot output
+ par(mfrow=c(1,3))
+ par(mar=c(4.5,4.0,0.2,2.2)+0.1)
+plot(fit.ms, deriv=1, lcol=mycol, scale=0.3)
+@
+\caption{
+Estimated first derivatives of the component functions,
+$\widehat{f'}_{(s)2}(x_2)$,
+from the NZ marital status data
+(see Equation~\ref{eq:jsscat.eg.nzms.cf}).
+\label{fig:jsscat.eg.mstatus.cf.deriv}
+}
+\end{center}
+\end{figure}
+
+\setkeys{Gin}{width=0.8\textwidth} % 0.8 is the current default
+
+
+The derivative for the \texttt{Divorced/Separated} group appears
+linear so that a quadratic component function could be tried.
+Not surprisingly the \texttt{Single} group shows the greatest change;
+also, $\widehat{f'}_{(2)2}(x_2)$ is approximately linear till~50
+and then flat---this suggests one could fit a piecewise quadratic
+function to model that component function up to 50~years.
+The~\texttt{Widowed} group appears largely flat.
+We thus fit the parametric model
+<<>>=
+foo <- function(x, elbow=50)
+ poly(pmin(x, elbow), 2)
+
+clist <- list("(Intercept)" = diag(3),
+ "poly(age, 2)" = rbind(1, 0, 0),
+ "foo(age)" = rbind(0, 1, 0),
+ "age" = rbind(0, 0, 1))
+fit2.ms <-
+ vglm(mstatus ~ poly(age, 2) + foo(age) + age,
+ family = multinomial(refLevel=2),
+ constraints=clist,
+ data=nzmarital)
+@
+Then
+<<>>=
+coef(fit2.ms, matrix = TRUE)
+@
+confirms that one term was used for each component function.
+The plots from
+<<fig=F>>=
+par(mfrow=c(2,2))
+plotvgam(fit2.ms, se=TRUE, scale=12,
+ lcol=mycol[1], scol=mycol[1], which.term=1)
+plotvgam(fit2.ms, se=TRUE, scale=12,
+ lcol=mycol[2], scol=mycol[2], which.term=2)
+plotvgam(fit2.ms, se=TRUE, scale=12,
+ lcol=mycol[3], scol=mycol[3], which.term=3)
+@
+are given in Figure~\ref{fig:jsscat.eg.mstatus.vglm}
+and appear like
+Figure~\ref{fig:jsscat.eg.mstatus}.
+
+
+\setkeys{Gin}{width=0.9\textwidth} % 0.8 is the current default
+
+\begin{figure}[tt]
+\begin{center}
+<<fig=TRUE,width=8,height=5.6,echo=FALSE>>=
+# Plot output
+par(mfrow=c(2,2))
+ par(mar=c(4.5,4.0,1.2,2.2)+0.1)
+plotvgam(fit2.ms, se=TRUE, scale=12,
+ lcol=mycol[1], scol=mycol[1], which.term=1)
+plotvgam(fit2.ms, se=TRUE, scale=12,
+ lcol=mycol[2], scol=mycol[2], which.term=2)
+plotvgam(fit2.ms, se=TRUE, scale=12,
+ lcol=mycol[3], scol=mycol[3], which.term=3)
+@
+\caption{
+Parametric version of~\texttt{fit.ms}: \texttt{fit2.ms}.
+The component functions are now quadratic, piecewise quadratic/zero,
+or linear.
+\label{fig:jsscat.eg.mstatus.vglm}
+}
+\end{center}
+\end{figure}
+
+\setkeys{Gin}{width=0.8\textwidth} % 0.8 is the current default
+
+
+
+
+It is possible to perform very crude inference based on heuristic theory
+of a deviance test:
+<<>>=
+deviance(fit.ms) - deviance(fit2.ms)
+@
+is small, so it seems the parametric model is quite reasonable
+against the original nonparametric model.
+Specifically,
+the difference in the number of `parameters' is approximately
+<<>>=
+(dfdiff <- df.residual(fit2.ms) - df.residual(fit.ms))
+@
+which gives an approximate $p$~value of
+<<>>=
+1-pchisq(deviance(fit.ms) - deviance(fit2.ms), df=dfdiff)
+@
+Thus \texttt{fit2.ms} appears quite reasonable.
+
+
+
+
+
+
+
+
+The estimated probabilities of the original fit can be plotted
+against~\texttt{age} using
+<<fig=F>>=
+ooo <- with(nzmarital, order(age))
+with(nzmarital, matplot(age[ooo], fitted(fit.ms)[ooo,],
+ type="l", las=1, lwd=2, ylim=0:1,
+ ylab="Fitted probabilities",
+ xlab="Age", # main="Marital status amongst NZ Male Europeans",
+ col=c(mycol[1], "black", mycol[-1])))
+legend(x=52.5, y=0.62, # x="topright",
+ col=c(mycol[1], "black", mycol[-1]),
+ lty=1:4,
+ legend=colnames(fit.ms at y), lwd=2)
+abline(v=seq(10,90,by=5), h=seq(0,1,by=0.1), col="gray", lty="dashed")
+@
+which gives Figure~\ref{fig:jsscat.eg.mstatus.fitted}.
+This shows that between 80--90\%~of NZ white males
+aged between their early~30s to mid-70s
+were married/partnered.
+The proportion widowed
+started to rise steeply from 70~years onwards but remained below~0.5
+since males die younger than females on average.
+
+
+\setkeys{Gin}{width=0.8\textwidth} % 0.8 is the current default
+
+\begin{figure}[tt]
+\begin{center}
+<<fig=TRUE,width=8,height=4.8,echo=FALSE>>=
+ par(mfrow=c(1,1))
+ par(mar=c(4.5,4.0,0.2,0.2)+0.1)
+ooo <- with(nzmarital, order(age))
+with(nzmarital, matplot(age[ooo], fitted(fit.ms)[ooo,],
+ type="l", las=1, lwd=2, ylim=0:1,
+ ylab="Fitted probabilities",
+ xlab="Age",
+ col=c(mycol[1], "black", mycol[-1])))
+legend(x=52.5, y=0.62,
+ col=c(mycol[1], "black", mycol[-1]),
+ lty=1:4,
+ legend=colnames(fit.ms at y), lwd=2.1)
+abline(v=seq(10,90,by=5), h=seq(0,1,by=0.1), col="gray", lty="dashed")
+@
+\caption{
+Fitted probabilities for each class for the
+NZ male European
+marital status data
+(from Equation~\ref{eq:jsscat.eg.nzms.cf}).
+\label{fig:jsscat.eg.mstatus.fitted}
+}
+\end{center}
+\end{figure}
+
+\setkeys{Gin}{width=0.8\textwidth} % 0.8 is the current default
+
+
+
+
+
+
+
+\subsection{Stereotype model}
+\label{sec:jsscat.eg.grc.stereotype}
+
+We reproduce some of the analyses of \cite{ande:1984} regarding the
+progress of 101~patients with back pain
+using the data frame \texttt{backPain} from \pkg{gnm}
+\citep{Rnews:Turner+Firth:2007,Turner+Firth:2009}.
+The three prognostic variables are
+length of previous attack ($x_1=1,2$),
+pain change ($x_2=1,2,3$)
+and lordosis ($x_3=1,2$).
+Like him, we treat these as numerical and standardize and negate them.
+%
+The output
+<<>>=
+# Scale the variables? Yes; the Anderson (1984) paper did (see his Table 6).
+head(backPain, 4)
+summary(backPain)
+backPain <- transform(backPain, sx1 = -scale(x1), sx2 = -scale(x2), sx3 = -scale(x3))
+@
+displays the six ordered categories.
+Now a rank-1 stereotype model can be fitted with
+<<>>=
+bp.rrmlm1 <- rrvglm(pain ~ sx1 + sx2 + sx3, multinomial, backPain)
+@
+Then
+<<>>=
+Coef(bp.rrmlm1)
+@
+are the fitted \bA, \bC{} and~$\bB_1$ (see Equation~\ref{eq:rrr.BAC}) and
+Table~\ref{tab:rrvglam.jss.subset}) which agrees with his Table~6.
+Here, what is known as ``corner constraints'' is used
+($(1,1)$ element of \bA{} $\equiv 1$),
+and only the intercepts are not subject to any reduced-rank regression
+by default.
+The maximized log-likelihood from \textsl{\texttt{logLik(bp.rrmlm1)}}
+is $\Sexpr{round(logLik(bp.rrmlm1), 2)}$.
+The standard errors of each parameter can be obtained by
+\textsl{\texttt{summary(bp.rrmlm1)}}.
+The negative elements of~$\widehat{\bC}$ imply the
+latent variable~$\widehat{\nu}$ decreases in value with increasing
+\textsl{\texttt{sx1}},
+\textsl{\texttt{sx2}} and
+\textsl{\texttt{sx3}}.
+The elements of~$\widehat{\bA}$ tend to decrease so it suggests
+patients get worse as $\nu$~increases,
+i.e., get better as \textsl{\texttt{sx1}},
+\textsl{\texttt{sx2}} and
+\textsl{\texttt{sx3}} increase.
+
+
+
+
+
+
+<<echo=FALSE>>=
+set.seed(123)
+@
+A rank-2 model fitted \textit{with a different normalization}
+<<>>=
+bp.rrmlm2 <- rrvglm(pain ~ sx1 + sx2 + sx3, multinomial, backPain, Rank=2,
+ Corner=FALSE, Uncor=TRUE)
+@
+produces uncorrelated $\widehat{\bnu}_i = \widehat{\bC}^{\top} \bix_{2i}$.
+In fact \textsl{\texttt{var(lv(bp.rrmlm2))}} equals $\bI_2$
+so that the latent variables are also scaled to have unit variance.
+The fit was biplotted
+(rows of $\widehat{\bC}$ plotted as arrow;
+ rows of $\widehat{\bA}$ plotted as labels) using
+<<figure=F>>=
+biplot(bp.rrmlm2, Acol="blue", Ccol="darkgreen", scores=TRUE,
+# xlim=c(-1,6), ylim=c(-1.2,4), # Use this if not scaled
+ xlim=c(-4.5,2.2), ylim=c(-2.2, 2.2), # Use this if scaled
+ chull=TRUE, clty=2, ccol="blue")
+@
+to give Figure~\ref{fig:jsscat.eg.rrmlm2.backPain}.
+It is interpreted via inner products due to~(\ref{eq:rrr.BAC}).
+The different normalization means that the interpretation of~$\nu_1$
+and~$\nu_2$ has changed, e.g., increasing
+\textsl{\texttt{sx1}},
+\textsl{\texttt{sx2}} and
+\textsl{\texttt{sx3}} results in increasing $\widehat{\nu}_1$ and
+patients improve more.
+Many of the latent variable points $\widehat{\bnu}_i$ are coincidental
+due to discrete nature of the~$\bix_i$. The rows of~$\widehat{\bA}$
+are centered on the blue labels (rather cluttered unfortunately) and
+do not seem to vary much as a function of~$\nu_2$.
+In fact this is confirmed by~\cite{ande:1984} who showed a rank-1
+model is to be preferred.
+
+
+
+This example demonstrates the ability to obtain a low dimensional view
+of higher dimensional data. The package's website has additional
+documentation including more detailed Goodman's~RC and stereotype
+examples.
+
+
+
+
+
+\setkeys{Gin}{width=0.8\textwidth} % 0.8 is the current default
+
+\begin{figure}[tt]
+\begin{center}
+<<fig=TRUE,width=8,height=5.3,echo=FALSE>>=
+# Plot output
+ par(mfrow=c(1,1))
+ par(mar=c(4.5,4.0,0.2,2.2)+0.1)
+
+biplot(bp.rrmlm2, Acol="blue", Ccol="darkgreen", scores=TRUE,
+# xlim=c(-1,6), ylim=c(-1.2,4), # Use this if not scaled
+ xlim=c(-4.5,2.2), ylim=c(-2.2, 2.2), # Use this if scaled
+ chull=TRUE, clty=2, ccol="blue")
+@
+\caption{
+Biplot of a rank-2 reduced-rank multinomial logit (stereotype) model
+fitted to the back pain data.
+A convex hull surrounds the latent variable scores
+$\widehat{\bnu}_i$
+(whose observation numbers are obscured because of their discrete nature).
+The position of the $j$th~row of~$\widehat{\bA}$
+is the center of the label ``\texttt{log(mu[,j])/mu[,6])}''.
+\label{fig:jsscat.eg.rrmlm2.backPain}
+}
+\end{center}
+\end{figure}
+
+\setkeys{Gin}{width=0.8\textwidth} % 0.8 is the current default
+
+
+
+
+
+
+
+
+
+
+% ----------------------------------------------------------------------
+\section{Some implementation details}
+\label{sec:jsscat.implementDetails}
+
+This section describes some implementation details of~\VGAM{}
+which will be more of interest to the developer than to the casual user.
+
+
+
+\subsection{Common code}
+\label{sec:jsscat.implementDetails.code}
+
+It is good programming practice to write reusable code where possible.
+All the \VGAM{}~family functions in Table~\ref{tab:cat.quantities}
+process the response in the same way because the same segment of code
+is executed. This offers a degree of uniformity in terms of how input is
+handled, and also for software maintenance
+(\cite{altm:jack:2010} enumerates good programming techniques and references).
+As well, the default initial values are computed in the same manner
+based on sample proportions of each level of~$Y$.
+
+
+
+
+
+\subsection[Matrix-band format of wz]{Matrix-band format of \texttt{wz}}
+\label{sec:jsscat.implementDetails.mbformat}
+
+The working weight matrices $\bW_i$ may become large for categorical
+regression models. In general, we have to evaluate the~$\bW_i$
+for~$i=1,\ldots,n$, and naively, this could be held in an \texttt{array} of
+dimension~\texttt{c(M, M, n)}. However, since the~$\bW_i$ are symmetric
+positive-definite it suffices to only store the upper or lower half of
+the matrix.
+
+
+
+The variable~\texttt{wz} in \texttt{vglm.fit()}
+stores the working weight matrices $\bW_i$ in
+a special format called the \textit{matrix-band} format. This
+format comprises a $n \times M^*$ matrix where
+$$
+M^* ~=~ \sum_{i=1}^{\footnotesize \textit{hbw}} \;
+\left(M-i+1\right) ~=~
+\frac12 \, \textit{hbw}\, \left(2\,M - \textit{hbw} +1\right)
+$$
+is the number of columns. Here, \textit{hbw} refers to the
+\textit{half-bandwidth} of the matrix, which is an integer
+between~1 and~$M$ inclusive. A diagonal matrix has
+unit half-bandwidth, a tridiagonal matrix has half-bandwidth~2, etc.
+
+
+Suppose $M=4$. Then \texttt{wz} will have up to $M^*=10$ columns
+enumerating the unique elements of~$\bW_i$ as follows:
+\begin{eqnarray}
+\bW_i ~=~
+\left( \begin{array}{rrrr}
+1 & 5 & 8 & 10 \\
+ & 2 & 6 & 9 \\
+ & & 3 & 7 \\
+ & & & 4
+\end{array} \right).
+\label{eqn:hbw.eg}
+\end{eqnarray}
+That is, the order is firstly the diagonal, then the band above that,
+followed by the second band above the diagonal etc.
+Why is such a format adopted?
+For this example, if $\bW_i$ is diagonal then only the first 4 columns
+of \texttt{wz} are needed. If $\bW_i$ is tridiagonal then only the
+first~7 columns of \texttt{wz} are needed.
+If $\bW_i$ \textit{is} banded then \texttt{wz} needs not have
+all $\frac12 M(M+1)$ columns; only~$M^*$ columns suffice, and the
+rest of the elements of~$\bW_i$ are implicitly zero.
+As well as reducing the size of \texttt{wz} itself in most cases, the
+matrix-band format often makes the computation of \texttt{wz} very
+simple and efficient. Furthermore, a Cholesky decomposition of a
+banded matrix will be banded. A final reason is that sometimes we
+want to input~$\bW_i$ into \VGAM: if \texttt{wz} is $M \times M \times
+n$ then \texttt{vglm(\ldots, weights = wz)} will result in an error
+whereas it will work if \texttt{wz} is an $n \times M^*$ matrix.
+
+
+
+To facilitate the use of the matrix-band format,
+a few auxiliary functions have been written.
+In particular, there is \texttt{iam()} which gives the indices
+for an array-to-matrix.
+In the $4\times 4$ example above,
+<<>>=
+iam(NA, NA, M = 4, both = TRUE, diag = TRUE)
+@
+returns the indices for the respective array coordinates for
+successive columns of matrix-band format
+(see Equation~\ref{eqn:hbw.eg}).
+If \texttt{diag = FALSE} then the first~4 elements in each vector
+are omitted. Note that the first two arguments of
+\texttt{iam()} are not used here and have been assigned
+\texttt{NA}s for simplicity.
+For its use on the multinomial logit model, where
+$(\bW_i)_{jj} = w_i\,\mu_{ij} (1-\mu_{ij}),\ j=1,\ldots,M$, and
+$(\bW_i)_{jk} = -w_i\,\mu_{ij} \mu_{ik},\ j\neq k$,
+this can be programmed succinctly like
+\begin{Code}
+wz <- mu[, 1:M] * (1 - mu[, 1:M])
+if (M > 1) {
+ index <- iam(NA, NA, M = M, both = TRUE, diag = FALSE)
+ wz <- cbind(wz, -mu[, index$row] * mu[, index$col])
+}
+wz <- w * wz
+\end{Code}
+(the actual code is slightly more complicated).
+In general, \VGAM{}~family functions can be remarkably compact,
+e.g.,
+\texttt{acat()},
+\texttt{cratio()}
+and
+\texttt{multinomial()} are all less than 120~lines of code each.
+
+
+
+
+
+
+
+
+
+
+% ----------------------------------------------------------------------
+\section{Extensions and utilities}
+\label{sec:jsscat.extnUtil}
+
+This section describes some useful utilities/extensions of the above.
+
+
+
+\subsection{Marginal effects}
+\label{sec:jsscat.extnUtil.margeff}
+
+
+Models such as the multinomial logit and cumulative link models
+model the posterior probability $p_{j} = \pr(Y=j|\bix)$ directly.
+In some applications, knowing the derivative of~$p_{j}$
+with respect to some of the~$x_k$ is useful;
+in fact, often just knowing the sign is important.
+The function \texttt{margeff()} computes the derivatives and
+returns them as a $p \times (M+1) \times n$ array.
+For the multinomial logit model it is easy to show
+\begin{eqnarray}
+\frac{\partial \, p_{j}(\bix_i)}{\partial \,
+\bix_{i}}
+&=&
+p_{j}(\bix_i)
+\left\{
+ \bbeta_{j} -
+\sum_{s=1}^{M+1}
+p_{s}(\bix_i)
+\,
+ \bbeta_{s}
+\right\},
+\label{eqn:multinomial.marginalEffects}
+\end{eqnarray}
+while for
+\texttt{cumulative(reverse = FALSE)}
+we have
+$p_{j} = \gamma_{j} - \gamma_{j-1} = h(\eta_{j}) - h(\eta_{j-1})$
+where $h=g^{-1}$ is the inverse of the link function
+(cf.~Table~\ref{tab:cat.quantities})
+so that
+\begin{eqnarray}
+\frac{\partial \, p_{j}(\bix_{})}{\partial \,
+\bix}
+&=&
+h'(\eta_{j}) \, \bbeta_{j} -
+h'(\eta_{j-1}) \, \bbeta_{j-1} .
+\label{eqn:cumulative.marginalEffects}
+\end{eqnarray}
+
+
+
+
+The function \texttt{margeff()} returns an array with these
+derivatives and should handle any value of
+\texttt{reverse} and \texttt{parallel}.
+
+
+
+
+
+
+
+
+% ----------------------------------------------------------------------
+\subsection[The xij argument]{The \texttt{xij} argument}
+\label{sec:jsscat.extnUtil.xij}
+
+There are many models, including those for categorical data,
+where the value of an explanatory variable~$x_k$ differs depending
+on which linear/additive predictor~$\eta_{j}$.
+Here is a well-known example from {consumer choice} modeling.
+Suppose an econometrician is interested in peoples'
+choice of transport for travelling to work
+and that there are four choices:
+$Y=1$ for ``bus'',
+$Y=2$ ``train'',
+$Y=3$ ``car'' and
+$Y=4$ means ``walking''.
+Assume that people only choose one means to go to work.
+Suppose there are three covariates:
+$X_2=$ cost,
+$X_3=$ journey time, and
+$X_4=$ distance.
+Of the covariates only~$X_4$ (and the intercept~$X_1$)
+is the same for all transport choices;
+the cost and journey time differ according to the means chosen.
+Suppose a random sample of~$n$ people is collected
+from some population, and that each person has
+access to all these transport modes.
+For such data, a natural regression model would be a
+multinomial logit model with~$M=3$:
+for $j=1,\ldots,M$, we have
+$\eta_{j} =$
+\begin{eqnarray}
+\log \frac{\pr(Y=j)}{\pr(Y=M+1)}
+&=&
+\beta_{(j)1}^{*} +
+\beta_{(1)2}^{*} \, (x_{i2j}-x_{i24}) +
+\beta_{(1)3}^{*} \, (x_{i3j}-x_{i34}) +
+\beta_{(1)4}^{*} \, x_{i4},
+\label{eqn:xij.eg.gotowork}
+\end{eqnarray}
+where, for the~$i$th person,
+$x_{i2j}$ is the cost for the~$j$th transport means, and
+$x_{i3j}$ is the journey time of the~$j$th transport means.
+The distance to get to work is $x_{i4}$; it has the same value
+regardless of the transport means.
+
+
+Equation~\ref{eqn:xij.eg.gotowork}
+implies $\bH_1=\bI_3$ and $\bH_2=\bH_3=\bH_4=\bone_3$.
+Note
+also that if the last response category is used as the baseline or
+reference group (the default of \texttt{multinomial()}) then $x_{ik,M+1}$
+can be subtracted from $x_{ikj}$ for~$j=1,\ldots,M$---this
+is the natural way $x_{ik,M+1}$ enters into the model.
+
+
+
+
+Recall from~(\ref{gammod2}) that we had
+\begin{equation}
+\eta_j(\bix_i) ~=~ \bbeta_j^{\top} \bix_i ~=~
+\sum_{k=1}^{p} \, x_{ik} \, \beta_{(j)k} .
+\label{eqn:xij0}
+\end{equation}
+Importantly, this can be generalized to
+\begin{equation}
+\eta_j(\bix_{ij}) ~=~ \bbeta_j^{\top} \bix_{ij} ~=~
+\sum_{k=1}^{p} \, x_{ikj} \, \beta_{(j)k} ,
+\label{eqn:xij}
+\end{equation}
+or writing this another way (as a mixture or hybrid),
+\begin{equation}
+\eta_j(\bix_{i}^{*},\bix_{ij}^{*}) ~=~
+\bbeta_{j}^{*T} \bix_{i}^{*} + \bbeta_{j}^{**T} \bix_{ij}^{*} .
+\label{eqn:xij2}
+\end{equation}
+Often $\bbeta_{j}^{**} = \bbeta_{}^{**}$, say.
+In~(\ref{eqn:xij2}) the variables in~$\bix_{i}^{*}$ are common to
+all~$\eta_{j}$, and the variables in~$\bix_{ij}^{*}$ have
+different values for differing~$\eta_{j}$.
+This allows for covariate values that are specific to each~$\eta_j$,
+a facility which is very important in many applications.
+
+
+The use of the \texttt{xij} argument with the \VGAM{} family function
+\texttt{multinomial()} has very important applications in economics.
+In that field the term ``multinomial logit model'' includes a variety of
+models such as the ``generalized logit model'' where (\ref{eqn:xij0})
+holds, the ``conditional logit model'' where~(\ref{eqn:xij}) holds,
+and the ``mixed logit model,'' which is a combination of the two,
+where~(\ref{eqn:xij2}) holds.
+The generalized logit model focusses on the individual as the unit of
+analysis, and uses individual characteristics as explanatory variables,
+e.g., age of the person in the transport example.
+The conditional logit model assumes different values for each
+alternative and the impact of a unit of~$x_k$ is assumed to be constant
+across alternatives, e.g., journey time in the choice of transport mode.
+Unfortunately, there is confusion in the literature for the terminology
+of the models. Some authors call \texttt{multinomial()}
+with~(\ref{eqn:xij0}) the ``generalized logit model''.
+Others call the mixed
+logit model the ``multinomial logit model'' and view the generalized
+logit and conditional logit models as special cases.
+In~\VGAM{} terminology there is no need to give different names to
+all these slightly differing special cases. They are all still called
+multinomial logit models, although it may be added that there are
+some covariate-specific linear/additive predictors.
+The important thing is that the framework accommodates~$\bix_{ij}$,
+so one tries to avoid making life unnecessarily complicated.
+And~\texttt{xij} can apply in theory to any VGLM and not just to the
+multinomial logit model.
+\cite{imai:king:lau:2008} present another perspective on the
+$\bix_{ij}$ problem with illustrations from \pkg{Zelig}
+\citep{Zelig:2009}.
+
+
+
+
+
+\subsubsection[Using the xij argument]{Using the \texttt{xij} argument}
+\label{sec:xij.sub}
+
+\VGAM{} handles variables whose values depend on $\eta_{j}$,
+(\ref{eqn:xij2}), using the \texttt{xij} argument.
+It is assigned an~S formula or a list of \proglang{S}~formulas.
+Each formula, which must have~$M$ \textit{different} terms,
+forms a matrix that premultiplies a constraint matrix.
+In detail, (\ref{eqn:xij0})~can be written in vector form as
+\begin{equation}
+\boldeta(\bix_i) ~=~ \bB^{\top} \bix_i ~=~
+\sum_{k=1}^{p} \, \bH_{k} \, \bbeta_{k}^{*} \, x_{ik},
+\label{eqn:xij0.vector}
+\end{equation}
+where
+$\bbeta_{k}^{*} =
+\left( \beta_{(1)k}^{*},\ldots,\beta_{(r_k)k}^{*} \right)^{\top}$
+is to be estimated.
+This may be written
+\begin{eqnarray}
+\boldeta(\bix_{i})
+&=&
+\sum_{k=1}^{p} \, \diag(x_{ik},\ldots,x_{ik}) \,
+\bH_k \, \bbeta_{k}^{*}.
+\label{eqn:xij.d.vector}
+\end{eqnarray}
+To handle~(\ref{eqn:xij})--(\ref{eqn:xij2})
+we can generalize~(\ref{eqn:xij.d.vector}) to
+\begin{eqnarray}
+\boldeta_i
+&=&
+\sum_{k=1}^{p} \, \diag(x_{ik1},\ldots,x_{ikM}) \;
+\bH_k \, \bbeta_{k}^{*}
+\ \ \ \ \left(=
+\sum_{k=1}^{p} \, \bX_{(ik)}^{*} \,
+\bH_k \, \bbeta_{k}^{*} ,
+\mathrm{\ say} \right).
+\label{eqn:xij.vector}
+\end{eqnarray}
+Each component of the list \texttt{xij} is a formula having~$M$ terms
+(ignoring the intercept) which
+specifies the successive diagonal elements of the matrix~$\bX_{(ik)}^{*}$.
+Thus each row of the constraint matrix may be multiplied by a different
+vector of values.
+The constraint matrices themselves are not affected by the
+\texttt{xij} argument.
+
+
+
+
+
+How can one fit such models in \VGAM{}?
+Let us fit~(\ref{eqn:xij.eg.gotowork}).
+Suppose the journey cost and time variables have had the
+cost and time of walking subtracted from them.
+Then,
+using ``\texttt{.trn}'' to denote train,
+\begin{Code}
+fit2 <- vglm(cbind(bus, train, car, walk) ~ Cost + Time + Distance,
+ fam = multinomial(parallel = TRUE ~ Cost + Time + Distance - 1),
+ xij = list(Cost ~ Cost.bus + Cost.trn + Cost.car,
+ Time ~ Time.bus + Time.trn + Time.car),
+ form2 = ~ Cost.bus + Cost.trn + Cost.car +
+ Time.bus + Time.trn + Time.car +
+ Cost + Time + Distance,
+ data = gotowork)
+\end{Code}
+should do the job.
+Here, the argument \texttt{form2} is assigned a second \proglang{S}~formula which
+is used in some special circumstances or by certain types
+of~\VGAM{} family functions.
+The model has $\bH_{1} = \bI_{3}$ and $\bH_{2} = \bH_{3} = \bH_{4} = \bone_{3}$
+because the lack of parallelism only applies to the intercept.
+However, unless \texttt{Cost} is the same as \texttt{Cost.bus} and
+\texttt{Time} is the same as \texttt{Time.bus},
+this model should not be plotted with \texttt{plotvgam()};
+see the author's homepage for further documentation.
+
+
+By the way,
+suppose
+$\beta_{(1)4}^{*}$
+in~(\ref{eqn:xij.eg.gotowork})
+is replaced by~$\beta_{(j)4}^{*}$.
+Then the above code but with
+\begin{Code}
+ fam = multinomial(parallel = FALSE ~ 1 + Distance),
+\end{Code}
+should fit this model.
+Equivalently,
+\begin{Code}
+ fam = multinomial(parallel = TRUE ~ Cost + Time - 1),
+\end{Code}
+
+
+
+
+
+
+\subsubsection{A more complicated example}
+\label{sec:xij.complicated}
+
+The above example is straightforward because the
+variables were entered linearly. However, things
+become more tricky if data-dependent functions are used in
+any \texttt{xij} terms, e.g., \texttt{bs()}, \texttt{ns()} or \texttt{poly()}.
+In particular, regression splines such as \texttt{bs()} and \texttt{ns()}
+can be used to estimate a general smooth function~$f(x_{ij})$, which is
+very useful for exploratory data analysis.
+
+
+
+Suppose we wish to fit the variable \texttt{Cost} with a smoother.
+This is possible with regression splines and using a trick.
+Firstly note that
+\begin{Code}
+fit3 <- vglm(cbind(bus, train, car, walk) ~ ns(Cost) + Time + Distance,
+ multinomial(parallel = TRUE ~ ns(Cost) + Time + Distance - 1),
+ xij = list(ns(Cost) ~ ns(Cost.bus) + ns(Cost.trn) + ns(Cost.car),
+ Time ~ Time.bus + Time.trn + Time.car),
+ form2 = ~ ns(Cost.bus) + ns(Cost.trn) + ns(Cost.car) +
+ Time.bus + Time.trn + Time.car +
+ ns(Cost) + Cost + Time + Distance,
+ data = gotowork)
+\end{Code}
+will \textit{not} work because the basis functions for
+\texttt{ns(Cost.bus)}, \texttt{ns(Cost.trn)} and \texttt{ns(Cost.car)}
+are not identical since the knots differ.
+Consequently, they represent different functions despite
+having common regression coefficients.
+
+
+Fortunately, it is possible to force the~\texttt{ns()} terms
+to have identical basis functions by using a trick:
+combine the vectors temporarily.
+To do this, one can let
+\begin{Code}
+NS <- function(x, ..., df = 3)
+ ns(c(x, ...), df = df)[1:length(x), , drop = FALSE]
+\end{Code}
+This computes a natural cubic B-spline evaluated at~\texttt{x} but it uses the
+other arguments as well to form an overall vector from which to obtain
+the (common) knots.
+Then the usage of \texttt{NS()} can be something like
+\begin{Code}
+fit4 <- vglm(cbind(bus, train, car, walk) ~ NS(Cost.bus, Cost.trn, Cost.car)
+ + Time + Distance,
+ multinomial(parallel = TRUE ~ NS(Cost.bus, Cost.trn, Cost.car)
+ + Time + Distance - 1),
+ xij = list(NS(Cost.bus, Cost.trn, Cost.car) ~
+ NS(Cost.bus, Cost.trn, Cost.car) +
+ NS(Cost.trn, Cost.car, Cost.bus) +
+ NS(Cost.car, Cost.bus, Cost.trn),
+ Time ~ Time.bus + Time.trn + Time.car),
+ form2 = ~ NS(Cost.bus, Cost.trn, Cost.car) +
+ NS(Cost.trn, Cost.car, Cost.bus) +
+ NS(Cost.car, Cost.bus, Cost.trn) +
+ Time.bus + Time.trn + Time.car +
+ Cost.bus + Cost.trn + Cost.car +
+ Time + Distance,
+ data = gotowork)
+\end{Code}
+So \texttt{NS(Cost.bus, Cost.trn, Cost.car)}
+is the smooth term for
+\texttt{Cost.bus}, etc.
+Furthermore, \texttt{plotvgam()} may be applied to
+\texttt{fit4}, in which case the fitted regression spline is plotted
+against its first inner argument, viz.~\texttt{Cost.bus}.
+
+
+One of the reasons why it will predict correctly, too,
+is due to ``smart prediction''
+\citep{Rnews:Yee:2008}.
+
+
+
+\subsubsection{Implementation details}
+\label{sec:jss.xij.implementationDetails}
+
+The~\texttt{xij} argument operates \textit{after} the
+ordinary $\bX_{\sVLM}$ matrix is created. Then selected columns
+of~$\bX_{\sVLM}$ are modified from the constraint matrices, \texttt{xij}
+and~\texttt{form2} arguments. That is, from \texttt{form2}'s model
+matrix $\bX_{\sformtwo}$, and the~$\bH_k$. This whole operation
+is possible because $\bX_{\sVLM}$ remains structurally the same.
+The crucial equation is~(\ref{eqn:xij.vector}).
+
+
+Other \texttt{xij} examples are given in the online help of
+\texttt{fill()} and \texttt{vglm.control()},
+as well as at the package's webpage.
+
+
+
+
+
+
+
+
+
+
+
+% ----------------------------------------------------------------------
+\section{Discussion}
+\label{sec:jsscat.discussion}
+
+
+This article has sought to convey how VGLMs/VGAMs are well suited for
+fitting regression models for categorical data. Its primary strength
+is its simple and unified framework, and when reflected in software,
+makes practical CDA more understandable and efficient. Furthermore,
+there are natural extensions such as a reduced-rank variant and
+covariate-specific~$\eta_{j}$. The \VGAM{}~package potentially offers
+a wide selection of models and utilities.
+
+
+There is much future work to do.
+Some useful additions to the package include:
+\begin{enumerate}
+
+\item
+Bias-reduction \citep{firt:1993} is a method for removing the~$O(n^{-1})$
+bias from a maximum likelihood estimate. For a substantial class of
+models including GLMs it can be formulated in terms of a minor adjustment
+of the score vector within an IRLS algorithm \citep{kosm:firt:2009}.
+One by-product, for logistic regression, is that while the maximum
+likelihood estimate (MLE) can be infinite, the adjustment leads to
+estimates that are always finite. At present the \R{}~package \pkg{brglm}
+\citep{Kosmidis:2008} implements bias-reduction for a number of models.
+Bias-reduction might be implemented by adding an argument
+\texttt{bred = FALSE}, say, to some existing \VGAM{} family functions.
+
+
+\item
+Nested logit models were developed to overcome a fundamental shortcoming
+related to the multinomial logit model, viz.~the independence of
+irrelevant alternatives~(IIA) assumption. Roughly, the multinomial logit
+model assumes the ratio of the choice probabilities of two alternatives
+is not dependent on the presence or absence of other alternatives in
+the model. This presents problems that are often illustrated by the
+famed red bus-blue bus problem.
+
+
+
+
+\item
+The generalized estimating equations (GEE) methodology is largely
+amenable to IRLS and this should be added to the package in the future
+\citep{wild:yee:1996}.
+
+
+\item
+For logistic regression \proglang{SAS}'s \code{proc logistic} gives
+a warning if the data is {completely separate} or {quasi-completely
+separate}. Its effects are that some regression coefficients tend to~$\pm
+\infty$. With such data, all (to my knowledge) \R{}~implementations
+give warnings that are vague, if any at all, and this is rather
+unacceptable \citep{alli:2004}. The \pkg{safeBinaryRegression} package
+\citep{Konis:2009} overloads \code{glm()} so that a check for the
+existence of the MLE is made before fitting a binary response GLM.
+
+
+\end{enumerate}
+
+
+In closing, the \pkg{VGAM} package is continually being developed,
+therefore some future changes in the implementation details and usage
+may occur. These may include non-backward-compatible changes (see the
+\code{NEWS} file.) Further documentation and updates are available at
+the author's homepage whose URL is given in the \code{DESCRIPTION} file.
+
+
+
+% ----------------------------------------------------------------------
+\section*{Acknowledgments}
+
+The author thanks Micah Altman, David Firth and Bill Venables for helpful
+conversations, and Ioannis Kosmidis for a reprint.
+Thanks also to The Institute for Quantitative Social Science at Harvard
+University for their hospitality while this document was written during a
+sabbatical visit.
+
+
+
+
+
+\bibliography{categoricalVGAMbib}
+
+\end{document}
+
+
+
+
diff --git a/inst/doc/categoricalVGAM.pdf b/inst/doc/categoricalVGAM.pdf
new file mode 100644
index 0000000..bd4b46e
Binary files /dev/null and b/inst/doc/categoricalVGAM.pdf differ
diff --git a/inst/doc/categoricalVGAMbib.bib b/inst/doc/categoricalVGAMbib.bib
new file mode 100644
index 0000000..7343b44
--- /dev/null
+++ b/inst/doc/categoricalVGAMbib.bib
@@ -0,0 +1,611 @@
+ at article{yee:wild:1996,
+ Author = {Yee, T. W. and Wild, C. J.},
+ Title = {Vector Generalized Additive Models},
+ Year = 1996,
+ JOURNAL = {Journal of the Royal Statistical Society~B},
+ Volume = 58,
+ Pages = {481--493},
+ Keywords = {Nonparametric regression; Smoothing},
+ Number = 3,
+}
+
+ at article{gree:1984,
+ Author = {Green, P. J.},
+ Title = {Iteratively Reweighted Least Squares for Maximum Likelihood
+ Estimation, and Some Robust and Resistant Alternatives},
+ Year = 1984,
+ JOURNAL = {Journal of the Royal Statistical Society~B},
+ Volume = 46,
+ Pages = {149--192},
+ Keywords = {Scoring; Generalized linear model; Regression; Residual},
+ Number = 2,
+}
+
+ at book{hast:tibs:1990,
+ Author = {Hastie, T. J. and Tibshirani, R. J.},
+ Title = {Generalized Additive Models},
+ Year = 1990,
+ Publisher = {Chapman \& Hall},
+ Address = {London},
+ Pages = {335},
+ Keywords = {Regression; Nonparametric; Generalized linear model}
+}
+
+ at Manual{gam:pack:2009,
+ title = {\pkg{gam}: Generalized Additive Models},
+ author = {Trevor Hastie},
+ year = {2008},
+ note = {\proglang{R}~package version~1.01},
+ url = {http://CRAN.R-project.org/package=gam}
+}
+
+ at article{ande:1984,
+ Author = {Anderson, J. A.},
+ Title = {Regression and Ordered Categorical Variables},
+ Year = 1984,
+ JOURNAL = {Journal of the Royal Statistical Society~B},
+ Volume = 46,
+ Pages = {1--30},
+ Keywords = {Assessed variable; Logistic regression; Stereotype
+ regression; Maximum likelihood},
+ Number = 1,
+}
+
+ at article{firt:1993,
+author = {Firth, D.},
+title = {Bias Reduction of Maximum Likelihood Estimates},
+journal = {Biometrika},
+volume = {80},
+pages = {27--38},
+year = {1993},
+number = {1},
+abstract = {It is shown how, in regular parametric problems, the
+first-order term is removed from the asymptotic bias of maximum likelihood
+estimates by a suitable modification of the score function. In exponential
+families with canonical parameterization the effect is to penalize the
+likelihood by the Jeffreys invariant prior. In binomial logistic models,
+Poisson log linear models and certain other generalized linear models,
+the Jeffreys prior penalty function can be imposed in standard regression
+software using a scheme of iterative adjustments to the data.},
+}
+
+ at InProceedings{alli:2004,
+ Author = {Allison, P.},
+ Title = {Convergence Problems in Logistic Regression},
+ chapter = {10},
+ Year = 2004,
+ Crossref = {altm:gill:mcdo:2004},
+ Pages = {238--252},
+ BookTITLE = {Numerical Issues in Statistical Computing for the Social
+ Scientist},
+ PUBLISHER = {Wiley-Interscience},
+ ADDRESS = {Hoboken, NJ, USA},
+}
+
+ at book {altm:gill:mcdo:2004,
+ AUTHOR = {Altman, Micah and Gill, Jeff and McDonald, Michael P.},
+ TITLE = {Numerical Issues in Statistical Computing for the Social
+ Scientist},
+ PUBLISHER = {Wiley-Interscience},
+ ADDRESS = {Hoboken, NJ, USA},
+ YEAR = {2004},
+ PAGES = {xvi+323},
+ MRCLASS = {62-02 (62-04 62P25 65-02 91-02)},
+ MRNUMBER = {MR2020104},
+}
+
+ at article{yee:2010v,
+ Author = {Yee, T. W.},
+ Title = {{VGLM}s and {VGAM}s:
+ An Overview for Applications in Fisheries Research},
+ Year = 2010,
+ Journal = {Fisheries Research},
+ FJournal = {Fisheries Research},
+ Volume = {101},
+ Pages = {116--126},
+ Number = {1--2},
+}
+
+ at article{imai:king:lau:2008,
+ AUTHOR = {Imai, Kosuke and King, Gary and Lau, Olivia},
+ TITLE = {Toward A Common Framework for Statistical Analysis and
+ Development},
+ JOURNAL = {Journal of Computational and Graphical Statistics},
+ YEAR = 2008,
+ VOLUME = 17,
+ PAGES = {892--913},
+ NUMBER = 4,
+}
+
+ at book{stok:davi:koch:2000,
+ Author = {Stokes, W. and Davis, J. and Koch, W.},
+ Title = {Categorical Data Analysis Using The \proglang{SAS} System},
+ Year = 2000,
+ Edition = {2nd},
+ Publisher = {SAS Institute Inc.},
+ Address = {Cary, NC, USA},
+ PAGES = {648},
+}
+
+ at article{neld:wedd:1972,
+ Author = {Nelder, J. A. and Wedderburn, R. W. M.},
+ Title = {Generalized Linear Models},
+ Year = 1972,
+ JOURNAL = {Journal of the Royal Statistical Society~A},
+ Volume = 135,
+ Pages = {370--384},
+ Keywords = {Probit analysis; Analysis of variance; Contingency table;
+ Exponential family; Quantal response; Weighted least
+ squares},
+ Number = 3,
+}
+
+ at book{agre:2002,
+ Author = {Agresti, Alan},
+ Title = {Categorical Data Analysis},
+ Year = 2002,
+ Publisher = {John Wiley \& Sons},
+ Address = {New York, USA},
+ Edition = {2nd},
+}
+
+ at book{fahr:tutz:2001,
+ Author = {Fahrmeir, L. and Tutz, G.},
+ Title = {Multivariate Statistical Modelling Based on Generalized Linear
+ Models},
+ Year = 2001,
+ Edition = {2nd},
+ Publisher = {Springer-Verlag},
+ ADDRESS = {New York, USA},
+}
+
+ at book{leon:2000,
+ Author = {Leonard, Thomas},
+ Title = {A Course in Categorical Data Analysis},
+ Year = 2000,
+ Publisher = {Chapman \& Hall/CRC},
+ Address = {Boca Raton, FL, USA},
+}
+
+ at book{lloy:1999,
+ Author = {Lloyd, C. J.},
+ Title = {Statistical Analysis of Categorical Data},
+ Year = 1999,
+ Publisher = {John Wiley \& Sons},
+ Address = {New York, USA}
+}
+
+ at book{long:1997,
+ Author = {Long, J. S.},
+ Title = {Regression Models for Categorical and Limited Dependent Variables},
+ Year = 1997,
+ Publisher = {Sage Publications},
+ ADDRESS = {Thousand Oaks, CA, USA},
+}
+
+ at book{mccu:neld:1989,
+ Author = {McCullagh, P. and Nelder, J. A.},
+ Title = {Generalized Linear Models},
+ Year = 1989,
+ Edition = {2nd},
+ Publisher = {Chapman \& Hall},
+ Address = {London},
+ Pages = {500}
+}
+
+ at book{simo:2003,
+ Author = {Simonoff, J. S.},
+ Title = {Analyzing Categorical Data},
+ Year = 2003,
+ Pages = {496},
+ Publisher = {Springer-Verlag},
+ Address = {New York, USA}
+}
+
+ at article{liu:agre:2005,
+ Author = {Liu, I. and Agresti, A.},
+ Title = {The Analysis of Ordered Categorical Data:
+ An Overview and a Survey of Recent Developments},
+ Year = 2005,
+ Journal = {Sociedad Estad{\'i}stica e Investigaci{\'o}n Operativa Test},
+ Volume = 14,
+ Pages = {1--73},
+ Number = 1,
+}
+
+ at MANUAL{thom:2009,
+ TITLE = {\proglang{R} (and \proglang{S-PLUS}) Manual to Accompany
+ Agresti's \textit{Categorical Data Analysis}~(2002),
+ 2nd edition},
+ AUTHOR = {Thompson, L. A.},
+ YEAR = {2009},
+ URL = {https://home.comcast.net/~lthompson221/Splusdiscrete2.pdf},
+}
+
+ at article{yee:2008c,
+ Author = {Yee, T. W.},
+ Title = {The \pkg{VGAM} Package},
+ Year = 2008,
+ Journal = {\proglang{R} {N}ews},
+ Volume = 8,
+ Pages = {28--39},
+ Number = 2,
+}
+
+ at article{Rnews:Yee:2008,
+ author = {Thomas W. Yee},
+ title = {The \pkg{VGAM} Package},
+ journal = {\proglang{R}~News},
+ year = 2008,
+ volume = 8,
+ pages = {28--39},
+ month = {October},
+ url = {http://CRAN.R-project.org/doc/Rnews/},
+ number = 2,
+}
+
+ at article{yee:hast:2003,
+ AUTHOR = {Yee, T. W. and Hastie, T. J.},
+ TITLE = {Reduced-rank Vector Generalized Linear Models},
+ JOURNAL = {Statistical Modelling},
+ Volume = 3,
+ Pages = {15--41},
+ YEAR = {2003},
+ Number = 1,
+}
+
+article{yee:wild:1996,
+ Author = {Yee, T. W. and Wild, C. J.},
+ Title = {Vector Generalized Additive Models},
+ Year = 1996,
+ JOURNAL = {Journal of the Royal Statistical Society~B},
+ Volume = 58,
+ Pages = {481--493},
+ Keywords = {Nonparametric regression; Smoothing},
+ Number = 3,
+}
+
+ at article{good:1981,
+ Author = {Goodman, L. A.},
+ Title = {Association Models and Canonical Correlation in the Analysis
+ of Cross-classifications Having Ordered Categories},
+ Year = 1981,
+ Journal = {Journal of the American Statistical Association},
+ Volume = 76,
+ Pages = {320--334},
+ Number = 374,
+}
+
+ at article{buja:hast:tibs:1989,
+ Author = {Buja, Andreas and Hastie, Trevor and Tibshirani, Robert},
+ Title = {Linear Smoothers and Additive Models},
+ Year = 1989,
+ JOURNAL = {The Annals of Statistics},
+ Volume = 17,
+ Pages = {453--510},
+ Keywords = {Nonparametric; Regression; Kernel estimator},
+ Number = 2,
+}
+
+ at article{yee:step:2007,
+ AUTHOR = {Yee, Thomas W. and Stephenson, Alec G.},
+ TITLE = {Vector Generalized Linear and Additive Extreme Value Models},
+ JOURNAL = {Extremes},
+ FJOURNAL = {Extremes. Statistical Theory and Applications in Science,
+ Engineering and Economics},
+ VOLUME = {10},
+ YEAR = {2007},
+ PAGES = {1--19},
+ MRCLASS = {Database Expansion Item},
+ MRNUMBER = {MR2407639},
+ NUMBER = {1--2},
+}
+
+ at article{wand:orme:2008,
+ Author = {Wand, M. P. and Ormerod, J. T.},
+ Title = {On Semiparametric Regression with {O}'{S}ullivan Penalized Splines},
+ Year = 2008,
+ Journal = {The Australian and New Zealand Journal of Statistics},
+ Volume = 50,
+ Issue = 2,
+ Pages = {179--198},
+ Number = 2,
+}
+
+ at book{cham:hast:1993,
+ Editor = {Chambers, John M. and Hastie, Trevor J.},
+ Title = {Statistical Models in \proglang{S}},
+ Publisher = {Chapman \& Hall},
+ Year = 1993,
+ Pages = {608},
+ Address = {New York, USA},
+ Keywords = {Computing},
+}
+
+ at Article{pete:harr:1990,
+ Author = {Peterson, B. and Harrell, Frank E.},
+ Title = {Partial Proportional Odds Models for Ordinal Response Variables},
+ Year = 1990,
+ Journal = {Applied Statistics},
+ Volume = 39,
+ Pages = {205--217},
+ Number = 2,
+}
+
+ at article{pete:1990,
+ Author = {Peterson, B.},
+ Title = {Letter to the Editor: Ordinal Regression Models for
+ Epidemiologic Data},
+ Year = 1990,
+ Journal = {American Journal of Epidemiology},
+ Volume = 131,
+ Pages = {745--746}
+}
+
+ at article{hast:tibs:buja:1994,
+ AUTHOR = {Hastie, Trevor and Tibshirani, Robert and Buja, Andreas},
+ TITLE = {Flexible Discriminant Analysis by Optimal Scoring},
+ JOURNAL = {Journal of the American Statistical Association},
+ VOLUME = {89},
+ YEAR = {1994},
+ PAGES = {1255--1270},
+ CODEN = {JSTNAL},
+ MRCLASS = {62H30},
+ MRNUMBER = {95h:62099},
+ NUMBER = {428},
+}
+
+ at article{firth:2005,
+ Author = {Firth, David},
+ Title = {{B}radley-{T}erry Models in \proglang{R}},
+ Year = 2005,
+ Journal = {Journal of Statistical Software},
+ Volume = 12,
+ Number = 1,
+ Pages = {1--12},
+ URL = "http://www.jstatsoft.org/v12/i01/",
+}
+
+ at book{weir:1996,
+ Author = {Weir, Bruce S.},
+ Title = {Genetic Data Analysis II: Methods for Discrete Population
+ Genetic Data},
+ Year = 1996,
+ Publisher = {Sinauer Associates, Inc.},
+ Address = {Sunderland, MA, USA}
+}
+
+ at book{lang:2002,
+ Author = {Lange, Kenneth},
+ Title = {Mathematical and Statistical Methods for Genetic Analysis},
+ Year = 2002,
+ Edition = {2nd},
+ Publisher = {Springer-Verlag},
+ Address = {New York, USA},
+}
+
+ at article{macm:etal:1995,
+ Author = {MacMahon, S. and Norton, R. and Jackson, R. and Mackie, M. J. and
+ Cheng, A. and
+ Vander Hoorn, S. and Milne, A. and McCulloch, A.},
+ Title = {Fletcher {C}hallenge-{U}niversity of {A}uckland {H}eart \&
+ {H}ealth {S}tudy: Design and Baseline Findings},
+ Year = 1995,
+ Journal = {New Zealand Medical Journal},
+ Volume = 108,
+ Pages = {499--502},
+}
+
+ at article{altm:jack:2010,
+ author = {Altman, M. and Jackman, S.},
+ title = "Nineteen Ways of Looking at Statistical Software",
+ journal = "Journal of Statistical Software",
+ year = "2010",
+ note = "Forthcoming"
+}
+
+ at article{fox:hong:2009,
+ author = "John Fox and Jangman Hong",
+ title = {Effect Displays in \proglang{R} for Multinomial and
+ Proportional-Odds Logit Models:
+ Extensions to the \pkg{effects} Package},
+ journal = "Journal of Statistical Software",
+ volume = "32",
+ number = "1",
+ pages = "1--24",
+ year = "2009",
+ URL = "http://www.jstatsoft.org/v32/i01/",
+}
+
+ at article{wild:yee:1996,
+ Author = {Wild, C. J. and Yee, T. W.},
+ Title = {Additive Extensions to Generalized Estimating Equation
+ Methods},
+ Year = 1996,
+ JOURNAL = {Journal of the Royal Statistical Society~B},
+ Volume = 58,
+ Pages = {711--725},
+ Keywords = {Longitudinal data; Nonparametric; Regression; Smoothing},
+ NUMBER = {4},
+}
+
+ at Article{Yee:2010,
+ author = {Thomas W. Yee},
+ title = {The \pkg{VGAM} Package for Categorical Data Analysis},
+ journal = {Journal of Statistical Software},
+ year = {2010},
+ volume = {32},
+ number = {10},
+ pages = {1--34},
+ url = {http://www.jstatsoft.org/v32/i10/}
+}
+
+ at Manual{R,
+ title = {\proglang{R}: {A} Language and Environment
+ for Statistical Computing},
+ author = {{\proglang{R} Development Core Team}},
+ organization = {\proglang{R} Foundation for Statistical Computing},
+ address = {Vienna, Austria},
+ year = {2009},
+ note = {{ISBN} 3-900051-07-0},
+ url = {http://www.R-project.org/}
+}
+
+ at Book{Venables+Ripley:2002,
+ author = {William N. Venables and Brian D. Ripley},
+ title = {Modern Applied Statistics with \proglang{S}},
+ edition = {4th},
+ year = {2002},
+ pages = {495},
+ publisher = {Springer-Verlag},
+ address = {New York},
+ url = {http://www.stats.ox.ac.uk/pub/MASS4/},
+}
+
+ at Manual{SAS,
+ author = {{\proglang{SAS} Institute Inc.}},
+ title = {The \proglang{SAS} System, Version 9.1},
+ year = {2003},
+ address = {Cary, NC},
+ url = {http://www.sas.com/}
+}
+
+ at Manual{yee:VGAM:2010,
+ title = {\pkg{VGAM}: Vector Generalized Linear and Additive Models},
+ author = {Yee, T. W.},
+ year = {2010},
+ note = {\proglang{R}~package version~0.7-10},
+ url = {http://CRAN.R-project.org/package=VGAM}
+}
+
+ at Manual{Harrell:2009,
+ title = {\pkg{rms}: Regression Modeling Strategies},
+ author = {Frank E. {Harrell, Jr.}},
+ year = {2009},
+ note = {\proglang{R}~package version~2.1-0},
+ url = {http://CRAN.R-project.org/package=rms}
+}
+
+ at Manual{Meyer+Zeileis+Hornik:2009,
+ title = {\pkg{vcd}: Visualizing Categorical Data},
+ author = {David Meyer and Achim Zeileis and Kurt Hornik},
+ year = {2009},
+ note = {\proglang{R}~package version~1.2-7},
+ url = {http://CRAN.R-project.org/package=vcd}
+}
+
+ at Article{Meyer+Zeileis+Hornik:2006,
+ author = {David Meyer and Achim Zeileis and Kurt Hornik},
+ title = {The Strucplot Framework: Visualizing Multi-Way
+ Contingency Tables with \pkg{vcd}},
+ journal = {Journal of Statistical Software},
+ year = {2006},
+ volume = {17},
+ number = {3},
+ pages = {1--48},
+ url = {http://www.jstatsoft.org/v17/i03/}
+}
+
+ at Manual{Turner+Firth:2009,
+ title = {Generalized Nonlinear Models in \proglang{R}:
+ An Overview of the \pkg{gnm} Package},
+ author = {Heather Turner and David Firth},
+ year = {2009},
+ note = {\proglang{R}~package version~0.10-0},
+ url = {http://CRAN.R-project.org/package=gnm},
+}
+
+ at Article{Rnews:Turner+Firth:2007,
+ author = {Heather Turner and David Firth},
+ title = {\pkg{gnm}: A Package for Generalized Nonlinear Models},
+ journal = {\proglang{R}~News},
+ year = 2007,
+ volume = 7,
+ number = 2,
+ pages = {8--12},
+ month = {October},
+ url = {http://CRAN.R-project.org/doc/Rnews/},
+}
+
+
+ at Manual{ElemStatLearn:2009,
+ title = {\pkg{ElemStatLearn}: Data Sets, Functions and
+ Examples from the Book `The Elements
+ of Statistical Learning, Data Mining, Inference, and
+ Prediction' by Trevor Hastie, Robert Tibshirani and Jerome
+ Friedman},
+ author = {Kjetil Halvorsen},
+ year = {2009},
+ note = {\proglang{R}~package version~0.1-7},
+ url = {http://CRAN.R-project.org/package=ElemStatLearn},
+ }
+
+ at Manual{Zelig:2009,
+ title = {\pkg{Zelig}: Everyone's Statistical Software},
+ author = {Kosuke Imai and Gary King and Olivia Lau},
+ year = {2009},
+ note = {\proglang{R}~package version~3.4-5},
+ url = {http://CRAN.R-project.org/package=Zelig},
+}
+
+ at article{kosm:firt:2009,
+ author = {Kosmidis, I. and Firth, D.},
+ title = {Bias Reduction in Exponential Family Nonlinear Models},
+ year = {2009},
+ JOURNAL = {Biometrika},
+ FJOURNAL = {Biometrika},
+ volume = {96},
+ PAGES = {793--804},
+ NUMBER = {4},
+}
+
+ at techreport{kosm:firt:2008,
+ author = {Kosmidis, I. and Firth, D.},
+ title = {Bias Reduction in Exponential Family Nonlinear Models},
+ Journal = {CRiSM Paper No.~08-05v2},
+ year = {2008},
+ URL = "http://www.warwick.ac.uk/go/crism",
+ Institution = {Department of Statistics, Warwick University},
+}
+
+ at Manual{Kosmidis:2008,
+ title = {\pkg{brglm}: Bias Reduction in Binary-Response {GLMs}},
+ author = {Ioannis Kosmidis},
+ year = {2008},
+ note = {\proglang{R}~package version~0.5-4},
+ url = {http://CRAN.R-project.org/package=brglm},
+}
+
+ at Manual{Hatzinger:2009,
+ title = {\pkg{prefmod}: Utilities to Fit Paired Comparison
+ Models for Preferences},
+ author = {Reinhold Hatzinger},
+ year = {2009},
+ note = {\proglang{R}~package version~0.8-16},
+ url = {http://CRAN.R-project.org/package=prefmod},
+}
+
+ at Manual{firth:2008,
+ title = {\pkg{BradleyTerry}: Bradley-Terry Models},
+ author = {David Firth},
+ year = {2008},
+ note = {\proglang{R}~package version~0.8-7},
+ url = {http://CRAN.R-project.org/package=BradleyTerry},
+ }
+
+ at Manual{gnlm:2007,
+ title = {\pkg{gnlm}: Generalized Nonlinear Regression Models},
+ author = {Jim Lindsey},
+ year = {2007},
+ note = {\proglang{R}~package version~1.0},
+ url = {http://popgen.unimaas.nl/~jlindsey/rcode.html},
+}
+
+ at Manual{Konis:2009,
+ title = {\pkg{safeBinaryRegression}: Safe Binary Regression},
+ author = {Kjell Konis},
+ year = {2009},
+ note = {\proglang{R}~package version~0.1-2},
+ url = {http://CRAN.R-project.org/package=safeBinaryRegression},
+}
+
diff --git a/inst/doc/jss.bst b/inst/doc/jss.bst
new file mode 100644
index 0000000..a5b0e78
--- /dev/null
+++ b/inst/doc/jss.bst
@@ -0,0 +1,1647 @@
+%%
+%% This is file `jss.bst',
+%% generated with the docstrip utility.
+%%
+%% The original source files were:
+%%
+%% merlin.mbs (with options: `ay,nat,nm-rvx,keyxyr,dt-beg,yr-par,note-yr,tit-qq,bt-qq,atit-u,trnum-it,vol-bf,volp-com,num-xser,isbn,issn,edpar,pp,ed,xedn,xand,etal-it,revdata,eprint,url,url-blk,doi,nfss')
+%% ----------------------------------------
+%% *** Journal of Statistical Software ***
+%%
+%% Copyright 1994-2004 Patrick W Daly
+ % ===============================================================
+ % IMPORTANT NOTICE:
+ % This bibliographic style (bst) file has been generated from one or
+ % more master bibliographic style (mbs) files, listed above.
+ %
+ % This generated file can be redistributed and/or modified under the terms
+ % of the LaTeX Project Public License Distributed from CTAN
+ % archives in directory macros/latex/base/lppl.txt; either
+ % version 1 of the License, or any later version.
+ % ===============================================================
+ % Name and version information of the main mbs file:
+ % \ProvidesFile{merlin.mbs}[2004/02/09 4.13 (PWD, AO, DPC)]
+ % For use with BibTeX version 0.99a or later
+ %-------------------------------------------------------------------
+ % This bibliography style file is intended for texts in ENGLISH
+ % This is an author-year citation style bibliography. As such, it is
+ % non-standard LaTeX, and requires a special package file to function properly.
+ % Such a package is natbib.sty by Patrick W. Daly
+ % The form of the \bibitem entries is
+ % \bibitem[Jones et al.(1990)]{key}...
+ % \bibitem[Jones et al.(1990)Jones, Baker, and Smith]{key}...
+ % The essential feature is that the label (the part in brackets) consists
+ % of the author names, as they should appear in the citation, with the year
+ % in parentheses following. There must be no space before the opening
+ % parenthesis!
+ % With natbib v5.3, a full list of authors may also follow the year.
+ % In natbib.sty, it is possible to define the type of enclosures that is
+ % really wanted (brackets or parentheses), but in either case, there must
+ % be parentheses in the label.
+ % The \cite command functions as follows:
+ % \citet{key} ==>> Jones et al. (1990)
+ % \citet*{key} ==>> Jones, Baker, and Smith (1990)
+ % \citep{key} ==>> (Jones et al., 1990)
+ % \citep*{key} ==>> (Jones, Baker, and Smith, 1990)
+ % \citep[chap. 2]{key} ==>> (Jones et al., 1990, chap. 2)
+ % \citep[e.g.][]{key} ==>> (e.g. Jones et al., 1990)
+ % \citep[e.g.][p. 32]{key} ==>> (e.g. Jones et al., p. 32)
+ % \citeauthor{key} ==>> Jones et al.
+ % \citeauthor*{key} ==>> Jones, Baker, and Smith
+ % \citeyear{key} ==>> 1990
+ %---------------------------------------------------------------------
+
+ENTRY
+ { address
+ archive
+ author
+ booktitle
+ chapter
+ collaboration
+ doi
+ edition
+ editor
+ eid
+ eprint
+ howpublished
+ institution
+ isbn
+ issn
+ journal
+ key
+ month
+ note
+ number
+ numpages
+ organization
+ pages
+ publisher
+ school
+ series
+ title
+ type
+ url
+ volume
+ year
+ }
+ {}
+ { label extra.label sort.label short.list }
+INTEGERS { output.state before.all mid.sentence after.sentence after.block }
+FUNCTION {init.state.consts}
+{ #0 'before.all :=
+ #1 'mid.sentence :=
+ #2 'after.sentence :=
+ #3 'after.block :=
+}
+STRINGS { s t}
+FUNCTION {output.nonnull}
+{ 's :=
+ output.state mid.sentence =
+ { ", " * write$ }
+ { output.state after.block =
+ { add.period$ write$
+ newline$
+ "\newblock " write$
+ }
+ { output.state before.all =
+ 'write$
+ { add.period$ " " * write$ }
+ if$
+ }
+ if$
+ mid.sentence 'output.state :=
+ }
+ if$
+ s
+}
+FUNCTION {output}
+{ duplicate$ empty$
+ 'pop$
+ 'output.nonnull
+ if$
+}
+FUNCTION {output.check}
+{ 't :=
+ duplicate$ empty$
+ { pop$ "empty " t * " in " * cite$ * warning$ }
+ 'output.nonnull
+ if$
+}
+FUNCTION {fin.entry}
+{ add.period$
+ write$
+ newline$
+}
+
+FUNCTION {new.block}
+{ output.state before.all =
+ 'skip$
+ { after.block 'output.state := }
+ if$
+}
+FUNCTION {new.sentence}
+{ output.state after.block =
+ 'skip$
+ { output.state before.all =
+ 'skip$
+ { after.sentence 'output.state := }
+ if$
+ }
+ if$
+}
+FUNCTION {add.blank}
+{ " " * before.all 'output.state :=
+}
+
+FUNCTION {date.block}
+{
+ new.block
+}
+
+FUNCTION {not}
+{ { #0 }
+ { #1 }
+ if$
+}
+FUNCTION {and}
+{ 'skip$
+ { pop$ #0 }
+ if$
+}
+FUNCTION {or}
+{ { pop$ #1 }
+ 'skip$
+ if$
+}
+FUNCTION {non.stop}
+{ duplicate$
+ "}" * add.period$
+ #-1 #1 substring$ "." =
+}
+
+STRINGS {z}
+FUNCTION {remove.dots}
+{ 'z :=
+ ""
+ { z empty$ not }
+ { z #1 #1 substring$
+ z #2 global.max$ substring$ 'z :=
+ duplicate$ "." = 'pop$
+ { * }
+ if$
+ }
+ while$
+}
+FUNCTION {new.block.checkb}
+{ empty$
+ swap$ empty$
+ and
+ 'skip$
+ 'new.block
+ if$
+}
+FUNCTION {field.or.null}
+{ duplicate$ empty$
+ { pop$ "" }
+ 'skip$
+ if$
+}
+FUNCTION {emphasize}
+{ duplicate$ empty$
+ { pop$ "" }
+ { "\emph{" swap$ * "}" * }
+ if$
+}
+FUNCTION {bolden}
+{ duplicate$ empty$
+ { pop$ "" }
+ { "\textbf{" swap$ * "}" * }
+ if$
+}
+FUNCTION {tie.or.space.prefix}
+{ duplicate$ text.length$ #3 <
+ { "~" }
+ { " " }
+ if$
+ swap$
+}
+
+FUNCTION {capitalize}
+{ "u" change.case$ "t" change.case$ }
+
+FUNCTION {space.word}
+{ " " swap$ * " " * }
+ % Here are the language-specific definitions for explicit words.
+ % Each function has a name bbl.xxx where xxx is the English word.
+ % The language selected here is ENGLISH
+FUNCTION {bbl.and}
+{ "and"}
+
+FUNCTION {bbl.etal}
+{ "et~al." }
+
+FUNCTION {bbl.editors}
+{ "eds." }
+
+FUNCTION {bbl.editor}
+{ "ed." }
+
+FUNCTION {bbl.edby}
+{ "edited by" }
+
+FUNCTION {bbl.edition}
+{ "edition" }
+
+FUNCTION {bbl.volume}
+{ "volume" }
+
+FUNCTION {bbl.of}
+{ "of" }
+
+FUNCTION {bbl.number}
+{ "number" }
+
+FUNCTION {bbl.nr}
+{ "no." }
+
+FUNCTION {bbl.in}
+{ "in" }
+
+FUNCTION {bbl.pages}
+{ "pp." }
+
+FUNCTION {bbl.page}
+{ "p." }
+
+FUNCTION {bbl.eidpp}
+{ "pages" }
+
+FUNCTION {bbl.chapter}
+{ "chapter" }
+
+FUNCTION {bbl.techrep}
+{ "Technical Report" }
+
+FUNCTION {bbl.mthesis}
+{ "Master's thesis" }
+
+FUNCTION {bbl.phdthesis}
+{ "Ph.D. thesis" }
+
+MACRO {jan} {"January"}
+
+MACRO {feb} {"February"}
+
+MACRO {mar} {"March"}
+
+MACRO {apr} {"April"}
+
+MACRO {may} {"May"}
+
+MACRO {jun} {"June"}
+
+MACRO {jul} {"July"}
+
+MACRO {aug} {"August"}
+
+MACRO {sep} {"September"}
+
+MACRO {oct} {"October"}
+
+MACRO {nov} {"November"}
+
+MACRO {dec} {"December"}
+
+MACRO {acmcs} {"ACM Computing Surveys"}
+
+MACRO {acta} {"Acta Informatica"}
+
+MACRO {cacm} {"Communications of the ACM"}
+
+MACRO {ibmjrd} {"IBM Journal of Research and Development"}
+
+MACRO {ibmsj} {"IBM Systems Journal"}
+
+MACRO {ieeese} {"IEEE Transactions on Software Engineering"}
+
+MACRO {ieeetc} {"IEEE Transactions on Computers"}
+
+MACRO {ieeetcad}
+ {"IEEE Transactions on Computer-Aided Design of Integrated Circuits"}
+
+MACRO {ipl} {"Information Processing Letters"}
+
+MACRO {jacm} {"Journal of the ACM"}
+
+MACRO {jcss} {"Journal of Computer and System Sciences"}
+
+MACRO {scp} {"Science of Computer Programming"}
+
+MACRO {sicomp} {"SIAM Journal on Computing"}
+
+MACRO {tocs} {"ACM Transactions on Computer Systems"}
+
+MACRO {tods} {"ACM Transactions on Database Systems"}
+
+MACRO {tog} {"ACM Transactions on Graphics"}
+
+MACRO {toms} {"ACM Transactions on Mathematical Software"}
+
+MACRO {toois} {"ACM Transactions on Office Information Systems"}
+
+MACRO {toplas} {"ACM Transactions on Programming Languages and Systems"}
+
+MACRO {tcs} {"Theoretical Computer Science"}
+FUNCTION {bibinfo.check}
+{ swap$
+ duplicate$ missing$
+ {
+ pop$ pop$
+ ""
+ }
+ { duplicate$ empty$
+ {
+ swap$ pop$
+ }
+ { swap$
+ pop$
+ }
+ if$
+ }
+ if$
+}
+FUNCTION {bibinfo.warn}
+{ swap$
+ duplicate$ missing$
+ {
+ swap$ "missing " swap$ * " in " * cite$ * warning$ pop$
+ ""
+ }
+ { duplicate$ empty$
+ {
+ swap$ "empty " swap$ * " in " * cite$ * warning$
+ }
+ { swap$
+ pop$
+ }
+ if$
+ }
+ if$
+}
+FUNCTION {format.eprint}
+{ eprint duplicate$ empty$
+ 'skip$
+ { "\eprint"
+ archive empty$
+ 'skip$
+ { "[" * archive * "]" * }
+ if$
+ "{" * swap$ * "}" *
+ }
+ if$
+}
+FUNCTION {format.url}
+{ url empty$
+ { "" }
+ { "\urlprefix\url{" url * "}" * }
+ if$
+}
+
+STRINGS { bibinfo}
+INTEGERS { nameptr namesleft numnames }
+
+FUNCTION {format.names}
+{ 'bibinfo :=
+ duplicate$ empty$ 'skip$ {
+ 's :=
+ "" 't :=
+ #1 'nameptr :=
+ s num.names$ 'numnames :=
+ numnames 'namesleft :=
+ { namesleft #0 > }
+ { s nameptr
+ "{vv~}{ll}{ jj}{ f{}}"
+ format.name$
+ remove.dots
+ bibinfo bibinfo.check
+ 't :=
+ nameptr #1 >
+ {
+ namesleft #1 >
+ { ", " * t * }
+ {
+ "," *
+ s nameptr "{ll}" format.name$ duplicate$ "others" =
+ { 't := }
+ { pop$ }
+ if$
+ t "others" =
+ {
+ " " * bbl.etal emphasize *
+ }
+ { " " * t * }
+ if$
+ }
+ if$
+ }
+ 't
+ if$
+ nameptr #1 + 'nameptr :=
+ namesleft #1 - 'namesleft :=
+ }
+ while$
+ } if$
+}
+FUNCTION {format.names.ed}
+{
+ 'bibinfo :=
+ duplicate$ empty$ 'skip$ {
+ 's :=
+ "" 't :=
+ #1 'nameptr :=
+ s num.names$ 'numnames :=
+ numnames 'namesleft :=
+ { namesleft #0 > }
+ { s nameptr
+ "{f{}~}{vv~}{ll}{ jj}"
+ format.name$
+ remove.dots
+ bibinfo bibinfo.check
+ 't :=
+ nameptr #1 >
+ {
+ namesleft #1 >
+ { ", " * t * }
+ {
+ "," *
+ s nameptr "{ll}" format.name$ duplicate$ "others" =
+ { 't := }
+ { pop$ }
+ if$
+ t "others" =
+ {
+
+ " " * bbl.etal emphasize *
+ }
+ { " " * t * }
+ if$
+ }
+ if$
+ }
+ 't
+ if$
+ nameptr #1 + 'nameptr :=
+ namesleft #1 - 'namesleft :=
+ }
+ while$
+ } if$
+}
+FUNCTION {format.key}
+{ empty$
+ { key field.or.null }
+ { "" }
+ if$
+}
+
+FUNCTION {format.authors}
+{ author "author" format.names
+ duplicate$ empty$ 'skip$
+ { collaboration "collaboration" bibinfo.check
+ duplicate$ empty$ 'skip$
+ { " (" swap$ * ")" * }
+ if$
+ *
+ }
+ if$
+}
+FUNCTION {get.bbl.editor}
+{ editor num.names$ #1 > 'bbl.editors 'bbl.editor if$ }
+
+FUNCTION {format.editors}
+{ editor "editor" format.names duplicate$ empty$ 'skip$
+ {
+ " " *
+ get.bbl.editor
+ "(" swap$ * ")" *
+ *
+ }
+ if$
+}
+FUNCTION {format.isbn}
+{ isbn "isbn" bibinfo.check
+ duplicate$ empty$ 'skip$
+ {
+ new.block
+ "ISBN " swap$ *
+ }
+ if$
+}
+
+FUNCTION {format.issn}
+{ issn "issn" bibinfo.check
+ duplicate$ empty$ 'skip$
+ {
+ new.block
+ "ISSN " swap$ *
+ }
+ if$
+}
+
+FUNCTION {format.doi}
+{ doi "doi" bibinfo.check
+ duplicate$ empty$ 'skip$
+ {
+ new.block
+ "\doi{" swap$ * "}" *
+ }
+ if$
+}
+FUNCTION {format.note}
+{
+ note empty$
+ { "" }
+ { note #1 #1 substring$
+ duplicate$ "{" =
+ 'skip$
+ { output.state mid.sentence =
+ { "l" }
+ { "u" }
+ if$
+ change.case$
+ }
+ if$
+ note #2 global.max$ substring$ * "note" bibinfo.check
+ }
+ if$
+}
+
+FUNCTION {format.title}
+{ title
+ "title" bibinfo.check
+ duplicate$ empty$ 'skip$
+ {
+ "\enquote{" swap$ *
+ add.period$ "}" *
+ }
+ if$
+}
+FUNCTION {end.quote.btitle}
+{ booktitle empty$
+ 'skip$
+ { before.all 'output.state := }
+ if$
+}
+FUNCTION {format.full.names}
+{'s :=
+ "" 't :=
+ #1 'nameptr :=
+ s num.names$ 'numnames :=
+ numnames 'namesleft :=
+ { namesleft #0 > }
+ { s nameptr
+ "{vv~}{ll}" format.name$
+ 't :=
+ nameptr #1 >
+ {
+ namesleft #1 >
+ { ", " * t * }
+ {
+ s nameptr "{ll}" format.name$ duplicate$ "others" =
+ { 't := }
+ { pop$ }
+ if$
+ t "others" =
+ {
+ " " * bbl.etal emphasize *
+ }
+ {
+ numnames #2 >
+ { "," * }
+ 'skip$
+ if$
+ bbl.and
+ space.word * t *
+ }
+ if$
+ }
+ if$
+ }
+ 't
+ if$
+ nameptr #1 + 'nameptr :=
+ namesleft #1 - 'namesleft :=
+ }
+ while$
+}
+
+FUNCTION {author.editor.key.full}
+{ author empty$
+ { editor empty$
+ { key empty$
+ { cite$ #1 #3 substring$ }
+ 'key
+ if$
+ }
+ { editor format.full.names }
+ if$
+ }
+ { author format.full.names }
+ if$
+}
+
+FUNCTION {author.key.full}
+{ author empty$
+ { key empty$
+ { cite$ #1 #3 substring$ }
+ 'key
+ if$
+ }
+ { author format.full.names }
+ if$
+}
+
+FUNCTION {editor.key.full}
+{ editor empty$
+ { key empty$
+ { cite$ #1 #3 substring$ }
+ 'key
+ if$
+ }
+ { editor format.full.names }
+ if$
+}
+
+FUNCTION {make.full.names}
+{ type$ "book" =
+ type$ "inbook" =
+ or
+ 'author.editor.key.full
+ { type$ "proceedings" =
+ 'editor.key.full
+ 'author.key.full
+ if$
+ }
+ if$
+}
+
+FUNCTION {output.bibitem}
+{ newline$
+ "\bibitem[{" write$
+ label write$
+ ")" make.full.names duplicate$ short.list =
+ { pop$ }
+ { * }
+ if$
+ "}]{" * write$
+ cite$ write$
+ "}" write$
+ newline$
+ ""
+ before.all 'output.state :=
+}
+
+FUNCTION {n.dashify}
+{
+ 't :=
+ ""
+ { t empty$ not }
+ { t #1 #1 substring$ "-" =
+ { t #1 #2 substring$ "--" = not
+ { "--" *
+ t #2 global.max$ substring$ 't :=
+ }
+ { { t #1 #1 substring$ "-" = }
+ { "-" *
+ t #2 global.max$ substring$ 't :=
+ }
+ while$
+ }
+ if$
+ }
+ { t #1 #1 substring$ *
+ t #2 global.max$ substring$ 't :=
+ }
+ if$
+ }
+ while$
+}
+
+FUNCTION {word.in}
+{ bbl.in capitalize
+ " " * }
+
+FUNCTION {format.date}
+{ year "year" bibinfo.check duplicate$ empty$
+ {
+ "empty year in " cite$ * "; set to ????" * warning$
+ pop$ "????"
+ }
+ 'skip$
+ if$
+ extra.label *
+ before.all 'output.state :=
+ " (" swap$ * ")" *
+}
+FUNCTION {format.btitle}
+{ title "title" bibinfo.check
+ duplicate$ empty$ 'skip$
+ {
+ emphasize
+ }
+ if$
+}
+FUNCTION {either.or.check}
+{ empty$
+ 'pop$
+ { "can't use both " swap$ * " fields in " * cite$ * warning$ }
+ if$
+}
+FUNCTION {format.bvolume}
+{ volume empty$
+ { "" }
+ { bbl.volume volume tie.or.space.prefix
+ "volume" bibinfo.check * *
+ series "series" bibinfo.check
+ duplicate$ empty$ 'pop$
+ { swap$ bbl.of space.word * swap$
+ emphasize * }
+ if$
+ "volume and number" number either.or.check
+ }
+ if$
+}
+FUNCTION {format.number.series}
+{ volume empty$
+ { number empty$
+ { series field.or.null }
+ { series empty$
+ { number "number" bibinfo.check }
+ { output.state mid.sentence =
+ { bbl.number }
+ { bbl.number capitalize }
+ if$
+ number tie.or.space.prefix "number" bibinfo.check * *
+ bbl.in space.word *
+ series "series" bibinfo.check *
+ }
+ if$
+ }
+ if$
+ }
+ { "" }
+ if$
+}
+
+FUNCTION {format.edition}
+{ edition duplicate$ empty$ 'skip$
+ {
+ output.state mid.sentence =
+ { "l" }
+ { "t" }
+ if$ change.case$
+ "edition" bibinfo.check
+ " " * bbl.edition *
+ }
+ if$
+}
+INTEGERS { multiresult }
+FUNCTION {multi.page.check}
+{ 't :=
+ #0 'multiresult :=
+ { multiresult not
+ t empty$ not
+ and
+ }
+ { t #1 #1 substring$
+ duplicate$ "-" =
+ swap$ duplicate$ "," =
+ swap$ "+" =
+ or or
+ { #1 'multiresult := }
+ { t #2 global.max$ substring$ 't := }
+ if$
+ }
+ while$
+ multiresult
+}
+FUNCTION {format.pages}
+{ pages duplicate$ empty$ 'skip$
+ { duplicate$ multi.page.check
+ {
+ bbl.pages swap$
+ n.dashify
+ }
+ {
+ bbl.page swap$
+ }
+ if$
+ tie.or.space.prefix
+ "pages" bibinfo.check
+ * *
+ }
+ if$
+}
+FUNCTION {format.journal.pages}
+{ pages duplicate$ empty$ 'pop$
+ { swap$ duplicate$ empty$
+ { pop$ pop$ format.pages }
+ {
+ ", " *
+ swap$
+ n.dashify
+ "pages" bibinfo.check
+ *
+ }
+ if$
+ }
+ if$
+}
+FUNCTION {format.journal.eid}
+{ eid "eid" bibinfo.check
+ duplicate$ empty$ 'pop$
+ { swap$ duplicate$ empty$ 'skip$
+ {
+ ", " *
+ }
+ if$
+ swap$ *
+ numpages empty$ 'skip$
+ { bbl.eidpp numpages tie.or.space.prefix
+ "numpages" bibinfo.check * *
+ " (" swap$ * ")" * *
+ }
+ if$
+ }
+ if$
+}
+FUNCTION {format.vol.num.pages}
+{ volume field.or.null
+ duplicate$ empty$ 'skip$
+ {
+ "volume" bibinfo.check
+ }
+ if$
+ bolden
+ number "number" bibinfo.check duplicate$ empty$ 'skip$
+ {
+ swap$ duplicate$ empty$
+ { "there's a number but no volume in " cite$ * warning$ }
+ 'skip$
+ if$
+ swap$
+ "(" swap$ * ")" *
+ }
+ if$ *
+ eid empty$
+ { format.journal.pages }
+ { format.journal.eid }
+ if$
+}
+
+FUNCTION {format.chapter.pages}
+{ chapter empty$
+ 'format.pages
+ { type empty$
+ { bbl.chapter }
+ { type "l" change.case$
+ "type" bibinfo.check
+ }
+ if$
+ chapter tie.or.space.prefix
+ "chapter" bibinfo.check
+ * *
+ pages empty$
+ 'skip$
+ { ", " * format.pages * }
+ if$
+ }
+ if$
+}
+
+FUNCTION {bt.enquote}
+{ duplicate$ empty$ 'skip$
+ { "\enquote{" swap$ *
+ non.stop
+ { ",} " * }
+ { "}, " * }
+ if$
+ }
+ if$
+}
+FUNCTION {format.booktitle}
+{
+ booktitle "booktitle" bibinfo.check
+ bt.enquote
+}
+FUNCTION {format.in.ed.booktitle}
+{ format.booktitle duplicate$ empty$ 'skip$
+ {
+ editor "editor" format.names.ed duplicate$ empty$ 'pop$
+ {
+ " " *
+ get.bbl.editor
+ "(" swap$ * "), " *
+ * swap$
+ * }
+ if$
+ word.in swap$ *
+ }
+ if$
+}
+FUNCTION {format.thesis.type}
+{ type duplicate$ empty$
+ 'pop$
+ { swap$ pop$
+ "t" change.case$ "type" bibinfo.check
+ }
+ if$
+}
+FUNCTION {format.tr.number}
+{ number "number" bibinfo.check
+ type duplicate$ empty$
+ { pop$ bbl.techrep }
+ 'skip$
+ if$
+ "type" bibinfo.check
+ swap$ duplicate$ empty$
+ { pop$ "t" change.case$ }
+ { tie.or.space.prefix * * }
+ if$
+}
+FUNCTION {format.article.crossref}
+{
+ word.in
+ " \cite{" * crossref * "}" *
+}
+FUNCTION {format.book.crossref}
+{ volume duplicate$ empty$
+ { "empty volume in " cite$ * "'s crossref of " * crossref * warning$
+ pop$ word.in
+ }
+ { bbl.volume
+ capitalize
+ swap$ tie.or.space.prefix "volume" bibinfo.check * * bbl.of space.word *
+ }
+ if$
+ " \cite{" * crossref * "}" *
+}
+FUNCTION {format.incoll.inproc.crossref}
+{
+ word.in
+ " \cite{" * crossref * "}" *
+}
+FUNCTION {format.org.or.pub}
+{ 't :=
+ ""
+ address empty$ t empty$ and
+ 'skip$
+ {
+ t empty$
+ { address "address" bibinfo.check *
+ }
+ { t *
+ address empty$
+ 'skip$
+ { ", " * address "address" bibinfo.check * }
+ if$
+ }
+ if$
+ }
+ if$
+}
+FUNCTION {format.publisher.address}
+{ publisher "publisher" bibinfo.warn format.org.or.pub
+}
+
+FUNCTION {format.organization.address}
+{ organization "organization" bibinfo.check format.org.or.pub
+}
+
+FUNCTION {article}
+{ output.bibitem
+ format.authors "author" output.check
+ author format.key output
+ format.date "year" output.check
+ date.block
+ format.title "title" output.check
+ new.block
+ crossref missing$
+ {
+ journal
+ "journal" bibinfo.check
+ emphasize
+ "journal" output.check
+ format.vol.num.pages output
+ }
+ { format.article.crossref output.nonnull
+ format.pages output
+ }
+ if$
+ format.issn output
+ format.doi output
+ new.block
+ format.note output
+ format.eprint output
+ format.url output
+ fin.entry
+}
+FUNCTION {book}
+{ output.bibitem
+ author empty$
+ { format.editors "author and editor" output.check
+ editor format.key output
+ }
+ { format.authors output.nonnull
+ crossref missing$
+ { "author and editor" editor either.or.check }
+ 'skip$
+ if$
+ }
+ if$
+ format.date "year" output.check
+ date.block
+ format.btitle "title" output.check
+ crossref missing$
+ { format.bvolume output
+ new.block
+ format.number.series output
+ new.sentence
+ format.publisher.address output
+ }
+ {
+ new.block
+ format.book.crossref output.nonnull
+ }
+ if$
+ format.edition output
+ format.isbn output
+ format.doi output
+ new.block
+ format.note output
+ format.eprint output
+ format.url output
+ fin.entry
+}
+FUNCTION {booklet}
+{ output.bibitem
+ format.authors output
+ author format.key output
+ format.date "year" output.check
+ date.block
+ format.title "title" output.check
+ new.block
+ howpublished "howpublished" bibinfo.check output
+ address "address" bibinfo.check output
+ format.isbn output
+ format.doi output
+ new.block
+ format.note output
+ format.eprint output
+ format.url output
+ fin.entry
+}
+
+FUNCTION {inbook}
+{ output.bibitem
+ author empty$
+ { format.editors "author and editor" output.check
+ editor format.key output
+ }
+ { format.authors output.nonnull
+ crossref missing$
+ { "author and editor" editor either.or.check }
+ 'skip$
+ if$
+ }
+ if$
+ format.date "year" output.check
+ date.block
+ format.btitle "title" output.check
+ crossref missing$
+ {
+ format.bvolume output
+ format.chapter.pages "chapter and pages" output.check
+ new.block
+ format.number.series output
+ new.sentence
+ format.publisher.address output
+ }
+ {
+ format.chapter.pages "chapter and pages" output.check
+ new.block
+ format.book.crossref output.nonnull
+ }
+ if$
+ format.edition output
+ crossref missing$
+ { format.isbn output }
+ 'skip$
+ if$
+ format.doi output
+ new.block
+ format.note output
+ format.eprint output
+ format.url output
+ fin.entry
+}
+
+FUNCTION {incollection}
+{ output.bibitem
+ format.authors "author" output.check
+ author format.key output
+ format.date "year" output.check
+ date.block
+ format.title "title" output.check
+ new.block
+ crossref missing$
+ { format.in.ed.booktitle "booktitle" output.check
+ end.quote.btitle
+ format.bvolume output
+ format.number.series output
+ format.chapter.pages output
+ new.sentence
+ format.publisher.address output
+ format.edition output
+ format.isbn output
+ }
+ { format.incoll.inproc.crossref output.nonnull
+ format.chapter.pages output
+ }
+ if$
+ format.doi output
+ new.block
+ format.note output
+ format.eprint output
+ format.url output
+ fin.entry
+}
+FUNCTION {inproceedings}
+{ output.bibitem
+ format.authors "author" output.check
+ author format.key output
+ format.date "year" output.check
+ date.block
+ format.title "title" output.check
+ new.block
+ crossref missing$
+ { format.in.ed.booktitle "booktitle" output.check
+ end.quote.btitle
+ format.bvolume output
+ format.number.series output
+ format.pages output
+ new.sentence
+ publisher empty$
+ { format.organization.address output }
+ { organization "organization" bibinfo.check output
+ format.publisher.address output
+ }
+ if$
+ format.isbn output
+ format.issn output
+ }
+ { format.incoll.inproc.crossref output.nonnull
+ format.pages output
+ }
+ if$
+ format.doi output
+ new.block
+ format.note output
+ format.eprint output
+ format.url output
+ fin.entry
+}
+FUNCTION {conference} { inproceedings }
+FUNCTION {manual}
+{ output.bibitem
+ format.authors output
+ author format.key output
+ format.date "year" output.check
+ date.block
+ format.btitle "title" output.check
+ organization address new.block.checkb
+ organization "organization" bibinfo.check output
+ address "address" bibinfo.check output
+ format.edition output
+ format.doi output
+ new.block
+ format.note output
+ format.eprint output
+ format.url output
+ fin.entry
+}
+
+FUNCTION {mastersthesis}
+{ output.bibitem
+ format.authors "author" output.check
+ author format.key output
+ format.date "year" output.check
+ date.block
+ format.btitle
+ "title" output.check
+ new.block
+ bbl.mthesis format.thesis.type output.nonnull
+ school "school" bibinfo.warn output
+ address "address" bibinfo.check output
+ format.doi output
+ new.block
+ format.note output
+ format.eprint output
+ format.url output
+ fin.entry
+}
+
+FUNCTION {misc}
+{ output.bibitem
+ format.authors output
+ author format.key output
+ format.date "year" output.check
+ date.block
+ format.title output
+ new.block
+ howpublished "howpublished" bibinfo.check output
+ format.doi output
+ new.block
+ format.note output
+ format.eprint output
+ format.url output
+ fin.entry
+}
+FUNCTION {phdthesis}
+{ output.bibitem
+ format.authors "author" output.check
+ author format.key output
+ format.date "year" output.check
+ date.block
+ format.btitle
+ "title" output.check
+ new.block
+ bbl.phdthesis format.thesis.type output.nonnull
+ school "school" bibinfo.warn output
+ address "address" bibinfo.check output
+ format.doi output
+ new.block
+ format.note output
+ format.eprint output
+ format.url output
+ fin.entry
+}
+
+FUNCTION {proceedings}
+{ output.bibitem
+ format.editors output
+ editor format.key output
+ format.date "year" output.check
+ date.block
+ format.btitle "title" output.check
+ format.bvolume output
+ format.number.series output
+ new.sentence
+ publisher empty$
+ { format.organization.address output }
+ { organization "organization" bibinfo.check output
+ format.publisher.address output
+ }
+ if$
+ format.isbn output
+ format.issn output
+ format.doi output
+ new.block
+ format.note output
+ format.eprint output
+ format.url output
+ fin.entry
+}
+
+FUNCTION {techreport}
+{ output.bibitem
+ format.authors "author" output.check
+ author format.key output
+ format.date "year" output.check
+ date.block
+ format.title
+ "title" output.check
+ new.block
+ format.tr.number emphasize output.nonnull
+ institution "institution" bibinfo.warn output
+ address "address" bibinfo.check output
+ format.doi output
+ new.block
+ format.note output
+ format.eprint output
+ format.url output
+ fin.entry
+}
+
+FUNCTION {unpublished}
+{ output.bibitem
+ format.authors "author" output.check
+ author format.key output
+ format.date "year" output.check
+ date.block
+ format.title "title" output.check
+ format.doi output
+ new.block
+ format.note "note" output.check
+ format.eprint output
+ format.url output
+ fin.entry
+}
+
+FUNCTION {default.type} { misc }
+READ
+FUNCTION {sortify}
+{ purify$
+ "l" change.case$
+}
+INTEGERS { len }
+FUNCTION {chop.word}
+{ 's :=
+ 'len :=
+ s #1 len substring$ =
+ { s len #1 + global.max$ substring$ }
+ 's
+ if$
+}
+FUNCTION {format.lab.names}
+{ 's :=
+ "" 't :=
+ s #1 "{vv~}{ll}" format.name$
+ s num.names$ duplicate$
+ #2 >
+ { pop$
+ " " * bbl.etal emphasize *
+ }
+ { #2 <
+ 'skip$
+ { s #2 "{ff }{vv }{ll}{ jj}" format.name$ "others" =
+ {
+ " " * bbl.etal emphasize *
+ }
+ { bbl.and space.word * s #2 "{vv~}{ll}" format.name$
+ * }
+ if$
+ }
+ if$
+ }
+ if$
+}
+
+FUNCTION {author.key.label}
+{ author empty$
+ { key empty$
+ { cite$ #1 #3 substring$ }
+ 'key
+ if$
+ }
+ { author format.lab.names }
+ if$
+}
+
+FUNCTION {author.editor.key.label}
+{ author empty$
+ { editor empty$
+ { key empty$
+ { cite$ #1 #3 substring$ }
+ 'key
+ if$
+ }
+ { editor format.lab.names }
+ if$
+ }
+ { author format.lab.names }
+ if$
+}
+
+FUNCTION {editor.key.label}
+{ editor empty$
+ { key empty$
+ { cite$ #1 #3 substring$ }
+ 'key
+ if$
+ }
+ { editor format.lab.names }
+ if$
+}
+
+FUNCTION {calc.short.authors}
+{ type$ "book" =
+ type$ "inbook" =
+ or
+ 'author.editor.key.label
+ { type$ "proceedings" =
+ 'editor.key.label
+ 'author.key.label
+ if$
+ }
+ if$
+ 'short.list :=
+}
+
+FUNCTION {calc.label}
+{ calc.short.authors
+ short.list
+ "("
+ *
+ year duplicate$ empty$
+ short.list key field.or.null = or
+ { pop$ "" }
+ 'skip$
+ if$
+ *
+ 'label :=
+}
+
+FUNCTION {sort.format.names}
+{ 's :=
+ #1 'nameptr :=
+ ""
+ s num.names$ 'numnames :=
+ numnames 'namesleft :=
+ { namesleft #0 > }
+ { s nameptr
+ "{vv{ } }{ll{ }}{ f{ }}{ jj{ }}"
+ format.name$ 't :=
+ nameptr #1 >
+ {
+ " " *
+ namesleft #1 = t "others" = and
+ { "zzzzz" * }
+ { t sortify * }
+ if$
+ }
+ { t sortify * }
+ if$
+ nameptr #1 + 'nameptr :=
+ namesleft #1 - 'namesleft :=
+ }
+ while$
+}
+
+FUNCTION {sort.format.title}
+{ 't :=
+ "A " #2
+ "An " #3
+ "The " #4 t chop.word
+ chop.word
+ chop.word
+ sortify
+ #1 global.max$ substring$
+}
+FUNCTION {author.sort}
+{ author empty$
+ { key empty$
+ { "to sort, need author or key in " cite$ * warning$
+ ""
+ }
+ { key sortify }
+ if$
+ }
+ { author sort.format.names }
+ if$
+}
+FUNCTION {author.editor.sort}
+{ author empty$
+ { editor empty$
+ { key empty$
+ { "to sort, need author, editor, or key in " cite$ * warning$
+ ""
+ }
+ { key sortify }
+ if$
+ }
+ { editor sort.format.names }
+ if$
+ }
+ { author sort.format.names }
+ if$
+}
+FUNCTION {editor.sort}
+{ editor empty$
+ { key empty$
+ { "to sort, need editor or key in " cite$ * warning$
+ ""
+ }
+ { key sortify }
+ if$
+ }
+ { editor sort.format.names }
+ if$
+}
+FUNCTION {presort}
+{ calc.label
+ label sortify
+ " "
+ *
+ type$ "book" =
+ type$ "inbook" =
+ or
+ 'author.editor.sort
+ { type$ "proceedings" =
+ 'editor.sort
+ 'author.sort
+ if$
+ }
+ if$
+ #1 entry.max$ substring$
+ 'sort.label :=
+ sort.label
+ *
+ " "
+ *
+ title field.or.null
+ sort.format.title
+ *
+ #1 entry.max$ substring$
+ 'sort.key$ :=
+}
+
+ITERATE {presort}
+SORT
+STRINGS { last.label next.extra }
+INTEGERS { last.extra.num number.label }
+FUNCTION {initialize.extra.label.stuff}
+{ #0 int.to.chr$ 'last.label :=
+ "" 'next.extra :=
+ #0 'last.extra.num :=
+ #0 'number.label :=
+}
+FUNCTION {forward.pass}
+{ last.label label =
+ { last.extra.num #1 + 'last.extra.num :=
+ last.extra.num int.to.chr$ 'extra.label :=
+ }
+ { "a" chr.to.int$ 'last.extra.num :=
+ "" 'extra.label :=
+ label 'last.label :=
+ }
+ if$
+ number.label #1 + 'number.label :=
+}
+FUNCTION {reverse.pass}
+{ next.extra "b" =
+ { "a" 'extra.label := }
+ 'skip$
+ if$
+ extra.label 'next.extra :=
+ extra.label
+ duplicate$ empty$
+ 'skip$
+ { "{\natexlab{" swap$ * "}}" * }
+ if$
+ 'extra.label :=
+ label extra.label * 'label :=
+}
+EXECUTE {initialize.extra.label.stuff}
+ITERATE {forward.pass}
+REVERSE {reverse.pass}
+FUNCTION {bib.sort.order}
+{ sort.label
+ " "
+ *
+ year field.or.null sortify
+ *
+ " "
+ *
+ title field.or.null
+ sort.format.title
+ *
+ #1 entry.max$ substring$
+ 'sort.key$ :=
+}
+ITERATE {bib.sort.order}
+SORT
+FUNCTION {begin.bib}
+{ preamble$ empty$
+ 'skip$
+ { preamble$ write$ newline$ }
+ if$
+ "\begin{thebibliography}{" number.label int.to.str$ * "}" *
+ write$ newline$
+ "\newcommand{\enquote}[1]{``#1''}"
+ write$ newline$
+ "\providecommand{\natexlab}[1]{#1}"
+ write$ newline$
+ "\providecommand{\url}[1]{\texttt{#1}}"
+ write$ newline$
+ "\providecommand{\urlprefix}{URL }"
+ write$ newline$
+ "\expandafter\ifx\csname urlstyle\endcsname\relax"
+ write$ newline$
+ " \providecommand{\doi}[1]{doi:\discretionary{}{}{}#1}\else"
+ write$ newline$
+ " \providecommand{\doi}{doi:\discretionary{}{}{}\begingroup \urlstyle{rm}\Url}\fi"
+ write$ newline$
+ "\providecommand{\eprint}[2][]{\url{#2}}"
+ write$ newline$
+}
+EXECUTE {begin.bib}
+EXECUTE {init.state.consts}
+ITERATE {call.type$}
+FUNCTION {end.bib}
+{ newline$
+ "\end{thebibliography}" write$ newline$
+}
+EXECUTE {end.bib}
+%% End of customized bst file
+%%
+%% End of file `jss.bst'.
diff --git a/inst/doc/jss.cls b/inst/doc/jss.cls
new file mode 100644
index 0000000..3aa0b85
--- /dev/null
+++ b/inst/doc/jss.cls
@@ -0,0 +1,473 @@
+%%
+%% This is file `jss.cls',
+%% generated with the docstrip utility.
+%%
+%% The original source files were:
+%%
+%% jss.dtx (with options: `class')
+%%
+%% IMPORTANT NOTICE:
+%%
+%% For the copyright see the source file.
+%%
+%% Any modified versions of this file must be renamed
+%% with new filenames distinct from jss.cls.
+%%
+%% For distribution of the original source see the terms
+%% for copying and modification in the file jss.dtx.
+%%
+%% This generated file may be distributed as long as the
+%% original source files, as listed above, are part of the
+%% same distribution. (The sources need not necessarily be
+%% in the same archive or directory.)
+\def\fileversion{1.8}
+\def\filename{jss}
+\def\filedate{2008/04/07}
+%%
+%% Package `jss' to use with LaTeX2e for JSS publications
+%% http://www.jstatsoft.org/
+%% Copyright (C) 2004 Achim Zeileis
+%% Please report errors to Achim.Zeileis at R-project.org
+%%
+\NeedsTeXFormat{LaTeX2e}
+\ProvidesClass{jss}[\filedate\space\fileversion\space jss class by Achim Zeileis]
+%% options
+\newif\if at article
+\newif\if at codesnippet
+\newif\if at bookreview
+\newif\if at softwarereview
+\newif\if at review
+\newif\if at shortnames
+\newif\if at nojss
+
+\@articletrue
+\@codesnippetfalse
+\@bookreviewfalse
+\@softwarereviewfalse
+\@reviewfalse
+\@shortnamesfalse
+\@nojssfalse
+
+\DeclareOption{article}{\@articletrue%
+ \@codesnippetfalse \@bookreviewfalse \@softwarereviewfalse}
+\DeclareOption{codesnippet}{\@articlefalse%
+ \@codesnippettrue \@bookreviewfalse \@softwarereviewfalse}
+\DeclareOption{bookreview}{\@articlefalse%
+ \@codesnippetfalse \@bookreviewtrue \@softwarereviewfalse}
+\DeclareOption{softwarereview}{\@articlefalse%
+ \@codesnippetfalse \@bookreviewfalse \@softwarereviewtrue}
+\DeclareOption{shortnames}{\@shortnamestrue}
+\DeclareOption{nojss}{\@nojsstrue}
+
+\ProcessOptions
+\LoadClass[11pt,a4paper,twoside]{article}
+%% required packages
+\RequirePackage{graphicx,a4wide,color,ae,fancyvrb}
+\RequirePackage[T1]{fontenc}
+\IfFileExists{upquote.sty}{\RequirePackage{upquote}}{}
+%% bibliography
+\if at shortnames
+ \usepackage[authoryear,round]{natbib}
+\else
+ \usepackage[authoryear,round,longnamesfirst]{natbib}
+\fi
+\bibpunct{(}{)}{;}{a}{}{,}
+\bibliographystyle{jss}
+%% paragraphs
+\setlength{\parskip}{0.7ex plus0.1ex minus0.1ex}
+\setlength{\parindent}{0em}
+%% for all publications
+\newcommand{\Address}[1]{\def\@Address{#1}}
+\newcommand{\Plaintitle}[1]{\def\@Plaintitle{#1}}
+\newcommand{\Shorttitle}[1]{\def\@Shorttitle{#1}}
+\newcommand{\Plainauthor}[1]{\def\@Plainauthor{#1}}
+\newcommand{\Volume}[1]{\def\@Volume{#1}}
+\newcommand{\Year}[1]{\def\@Year{#1}}
+\newcommand{\Month}[1]{\def\@Month{#1}}
+\newcommand{\Issue}[1]{\def\@Issue{#1}}
+\newcommand{\Submitdate}[1]{\def\@Submitdate{#1}}
+%% for articles and code snippets
+\newcommand{\Acceptdate}[1]{\def\@Acceptdate{#1}}
+\newcommand{\Abstract}[1]{\def\@Abstract{#1}}
+\newcommand{\Keywords}[1]{\def\@Keywords{#1}}
+\newcommand{\Plainkeywords}[1]{\def\@Plainkeywords{#1}}
+%% for book and software reviews
+\newcommand{\Reviewer}[1]{\def\@Reviewer{#1}}
+\newcommand{\Booktitle}[1]{\def\@Booktitle{#1}}
+\newcommand{\Bookauthor}[1]{\def\@Bookauthor{#1}}
+\newcommand{\Publisher}[1]{\def\@Publisher{#1}}
+\newcommand{\Pubaddress}[1]{\def\@Pubaddress{#1}}
+\newcommand{\Pubyear}[1]{\def\@Pubyear{#1}}
+\newcommand{\ISBN}[1]{\def\@ISBN{#1}}
+\newcommand{\Pages}[1]{\def\@Pages{#1}}
+\newcommand{\Price}[1]{\def\@Price{#1}}
+\newcommand{\Plainreviewer}[1]{\def\@Plainreviewer{#1}}
+\newcommand{\Softwaretitle}[1]{\def\@Softwaretitle{#1}}
+\newcommand{\URL}[1]{\def\@URL{#1}}
+%% for internal use
+\newcommand{\Seriesname}[1]{\def\@Seriesname{#1}}
+\newcommand{\Hypersubject}[1]{\def\@Hypersubject{#1}}
+\newcommand{\Hyperauthor}[1]{\def\@Hyperauthor{#1}}
+\newcommand{\Footername}[1]{\def\@Footername{#1}}
+\newcommand{\Firstdate}[1]{\def\@Firstdate{#1}}
+\newcommand{\Seconddate}[1]{\def\@Seconddate{#1}}
+\newcommand{\Reviewauthor}[1]{\def\@Reviewauthor{#1}}
+%% defaults
+\author{Firstname Lastname\\Affiliation}
+\title{Title}
+\Abstract{---!!!---an abstract is required---!!!---}
+\Plainauthor{\@author}
+\Volume{VV}
+\Year{YYYY}
+\Month{MMMMMM}
+\Issue{II}
+\Submitdate{yyyy-mm-dd}
+\Acceptdate{yyyy-mm-dd}
+\Address{
+ Firstname Lastname\\
+ Affiliation\\
+ Address, Country\\
+ E-mail: \email{name at address}\\
+ URL: \url{http://link/to/webpage/}
+}
+
+\Reviewer{Firstname Lastname\\Affiliation}
+\Plainreviewer{Firstname Lastname}
+\Booktitle{Book Title}
+\Bookauthor{Book Author}
+\Publisher{Publisher}
+\Pubaddress{Publisher's Address}
+\Pubyear{YYY}
+\ISBN{x-xxxxx-xxx-x}
+\Pages{xv + 123}
+\Price{USD 69.95 (P)}
+\URL{http://link/to/webpage/}
+\if at article
+ \Seriesname{Issue}
+ \Hypersubject{Journal of Statistical Software}
+ \Plaintitle{\@title}
+ \Shorttitle{\@title}
+ \Plainkeywords{\@Keywords}
+\fi
+
+\if at codesnippet
+ \Seriesname{Code Snippet}
+ \Hypersubject{Journal of Statistical Software -- Code Snippets}
+ \Plaintitle{\@title}
+ \Shorttitle{\@title}
+ \Plainkeywords{\@Keywords}
+\fi
+
+\if at bookreview
+ \Seriesname{Book Review}
+ \Hypersubject{Journal of Statistical Software -- Book Reviews}
+ \Plaintitle{\@Booktitle}
+ \Shorttitle{\@Booktitle}
+ \Reviewauthor{\@Bookauthor\\
+ \@Publisher, \@Pubaddress, \@Pubyear.\\
+ ISBN~\@ISBN. \@Pages~pp. \@Price.\\
+ \url{\@URL}}
+ \Plainkeywords{}
+ \@reviewtrue
+\fi
+
+\if at softwarereview
+ \Seriesname{Software Review}
+ \Hypersubject{Journal of Statistical Software -- Software Reviews}
+ \Plaintitle{\@Softwaretitle}
+ \Shorttitle{\@Softwaretitle}
+ \Booktitle{\@Softwaretitle}
+ \Reviewauthor{\@Publisher, \@Pubaddress. \@Price.\\
+ \url{\@URL}}
+ \Plainkeywords{}
+ \@reviewtrue
+\fi
+
+\if at review
+ \Hyperauthor{\@Plainreviewer}
+ \Keywords{}
+ \Footername{Reviewer}
+ \Firstdate{\textit{Published:} \@Submitdate}
+ \Seconddate{}
+\else
+ \Hyperauthor{\@Plainauthor}
+ \Keywords{---!!!---at least one keyword is required---!!!---}
+ \Footername{Affiliation}
+ \Firstdate{\textit{Submitted:} \@Submitdate}
+ \Seconddate{\textit{Accepted:} \@Acceptdate}
+\fi
+%% Sweave(-like)
+\DefineVerbatimEnvironment{Sinput}{Verbatim}{fontshape=sl}
+\DefineVerbatimEnvironment{Soutput}{Verbatim}{}
+\DefineVerbatimEnvironment{Scode}{Verbatim}{fontshape=sl}
+%%%% zz commented out 20090609:
+\newenvironment{Schunk}{}{}
+\DefineVerbatimEnvironment{Code}{Verbatim}{}
+\DefineVerbatimEnvironment{CodeInput}{Verbatim}{fontshape=sl}
+\DefineVerbatimEnvironment{CodeOutput}{Verbatim}{}
+\newenvironment{CodeChunk}{}{}
+\setkeys{Gin}{width=0.8\textwidth}
+%% footer
+\newlength{\footerskip}
+\setlength{\footerskip}{2.5\baselineskip plus 2ex minus 0.5ex}
+
+\newcommand{\makefooter}{%
+ \vspace{\footerskip}
+
+ \if at nojss
+ \begin{samepage}
+ \textbf{\large \@Footername: \nopagebreak}\\[.3\baselineskip] \nopagebreak
+ \@Address \nopagebreak
+ \end{samepage}
+ \else
+ \begin{samepage}
+ \textbf{\large \@Footername: \nopagebreak}\\[.3\baselineskip] \nopagebreak
+ \@Address \nopagebreak
+ \vfill
+ \hrule \nopagebreak
+ \vspace{.1\baselineskip}
+ {\fontfamily{pzc} \fontsize{13}{15} \selectfont Journal of Statistical Software}
+ \hfill
+ \url{http://www.jstatsoft.org/}\\ \nopagebreak
+ published by the American Statistical Association
+ \hfill
+ \url{http://www.amstat.org/}\\[.3\baselineskip] \nopagebreak
+ {Volume~\@Volume, \@Seriesname~\@Issue}
+ \hfill
+ \@Firstdate\\ \nopagebreak
+ {\@Month{} \@Year}
+ \hfill
+ \@Seconddate \nopagebreak
+ \vspace{.3\baselineskip}
+ \hrule
+ \end{samepage}
+ \fi
+}
+\AtEndDocument{\makefooter}
+%% required packages
+\RequirePackage{hyperref}
+%% new \maketitle
+\def\@myoddhead{
+ {\color{white} JSS}\\[-1.42cm]
+ \hspace{-2em} \includegraphics[height=23mm,keepaspectratio]{jsslogo} \hfill
+ \parbox[b][23mm]{118mm}{\hrule height 3pt
+ \center{
+ {\fontfamily{pzc} \fontsize{28}{32} \selectfont Journal of Statistical Software}
+ \vfill
+ {\it \small \@Month{} \@Year, Volume~\@Volume, \@Seriesname~\@Issue.%
+ \hfill \href{http://www.jstatsoft.org/}{http://www.jstatsoft.org/}}}\\[0.1cm]
+ \hrule height 3pt}}
+\if at review
+ \renewcommand{\maketitle}{
+ \if at nojss
+ %% \@oddhead{\@myoddhead}\\[3\baselineskip]
+ \else
+ \@oddhead{\@myoddhead}\\[3\baselineskip]
+ \fi
+ {\large
+ \noindent
+ Reviewer: \@Reviewer
+ \vspace{\baselineskip}
+ \hrule
+ \vspace{\baselineskip}
+ \textbf{\@Booktitle}
+ \begin{quotation} \noindent
+ \@Reviewauthor
+ \end{quotation}
+ \vspace{0.7\baselineskip}
+ \hrule
+ \vspace{1.3\baselineskip}
+ }
+
+ \thispagestyle{empty}
+ \if at nojss
+ \markboth{\centerline{\@Shorttitle}}{\centerline{\@Hyperauthor}}
+ \else
+ \markboth{\centerline{\@Shorttitle}}{\centerline{\@Hypersubject}}
+ \fi
+ \pagestyle{myheadings}
+ }
+\else
+ \def\maketitle{
+ \if at nojss
+ %% \@oddhead{\@myoddhead} \par
+ \else
+ \@oddhead{\@myoddhead} \par
+ \fi
+ \begingroup
+ \def\thefootnote{\fnsymbol{footnote}}
+ \def\@makefnmark{\hbox to 0pt{$^{\@thefnmark}$\hss}}
+ \long\def\@makefntext##1{\parindent 1em\noindent
+ \hbox to1.8em{\hss $\m at th ^{\@thefnmark}$}##1}
+ \@maketitle \@thanks
+ \endgroup
+ \setcounter{footnote}{0}
+ \thispagestyle{empty}
+ \if at nojss
+ \markboth{\centerline{\@Shorttitle}}{\centerline{\@Hyperauthor}}
+ \else
+ \markboth{\centerline{\@Shorttitle}}{\centerline{\@Hypersubject}}
+ \fi
+ \pagestyle{myheadings}
+
+ \let\maketitle\relax \let\@maketitle\relax
+ \gdef\@thanks{}\gdef\@author{}\gdef\@title{}\let\thanks\relax
+ }
+
+ \def\@maketitle{\vbox{\hsize\textwidth \linewidth\hsize
+ \if at nojss
+ %% \vskip 1in
+ \else
+ \vskip 1in
+ \fi
+ {\centering
+ {\LARGE\bf \@title\par}
+ \vskip 0.2in plus 1fil minus 0.1in
+ {
+ \def\and{\unskip\enspace{\rm and}\enspace}%
+ \def\And{\end{tabular}\hss \egroup \hskip 1in plus 2fil
+ \hbox to 0pt\bgroup\hss \begin{tabular}[t]{c}\large\bf\rule{\z@}{24pt}\ignorespaces}%
+ \def\AND{\end{tabular}\hss\egroup \hfil\hfil\egroup
+ \vskip 0.1in plus 1fil minus 0.05in
+ \hbox to \linewidth\bgroup\rule{\z@}{10pt} \hfil\hfil
+ \hbox to 0pt\bgroup\hss \begin{tabular}[t]{c}\large\bf\rule{\z@}{24pt}\ignorespaces}
+ \hbox to \linewidth\bgroup\rule{\z@}{10pt} \hfil\hfil
+ \hbox to 0pt\bgroup\hss \begin{tabular}[t]{c}\large\bf\rule{\z@}{24pt}\@author
+ \end{tabular}\hss\egroup
+ \hfil\hfil\egroup}
+ \vskip 0.3in minus 0.1in
+ \hrule
+ \begin{abstract}
+ \@Abstract
+ \end{abstract}}
+ \textit{Keywords}:~\@Keywords.
+ \vskip 0.1in minus 0.05in
+ \hrule
+ \vskip 0.2in minus 0.1in
+ }}
+\fi
+%% sections, subsections, and subsubsections
+\newlength{\preXLskip}
+\newlength{\preLskip}
+\newlength{\preMskip}
+\newlength{\preSskip}
+\newlength{\postMskip}
+\newlength{\postSskip}
+\setlength{\preXLskip}{1.8\baselineskip plus 0.5ex minus 0ex}
+\setlength{\preLskip}{1.5\baselineskip plus 0.3ex minus 0ex}
+\setlength{\preMskip}{1\baselineskip plus 0.2ex minus 0ex}
+\setlength{\preSskip}{.8\baselineskip plus 0.2ex minus 0ex}
+\setlength{\postMskip}{.5\baselineskip plus 0ex minus 0.1ex}
+\setlength{\postSskip}{.3\baselineskip plus 0ex minus 0.1ex}
+
+\newcommand{\jsssec}[2][default]{\vskip \preXLskip%
+ \pdfbookmark[1]{#1}{Section.\thesection.#1}%
+ \refstepcounter{section}%
+ \centerline{\textbf{\Large \thesection. #2}} \nopagebreak
+ \vskip \postMskip \nopagebreak}
+\newcommand{\jsssecnn}[1]{\vskip \preXLskip%
+ \centerline{\textbf{\Large #1}} \nopagebreak
+ \vskip \postMskip \nopagebreak}
+
+\newcommand{\jsssubsec}[2][default]{\vskip \preMskip%
+ \pdfbookmark[2]{#1}{Subsection.\thesubsection.#1}%
+ \refstepcounter{subsection}%
+ \textbf{\large \thesubsection. #2} \nopagebreak
+ \vskip \postSskip \nopagebreak}
+\newcommand{\jsssubsecnn}[1]{\vskip \preMskip%
+ \textbf{\large #1} \nopagebreak
+ \vskip \postSskip \nopagebreak}
+
+\newcommand{\jsssubsubsec}[2][default]{\vskip \preSskip%
+ \pdfbookmark[3]{#1}{Subsubsection.\thesubsubsection.#1}%
+ \refstepcounter{subsubsection}%
+ {\large \textit{#2}} \nopagebreak
+ \vskip \postSskip \nopagebreak}
+\newcommand{\jsssubsubsecnn}[1]{\vskip \preSskip%
+ {\textit{\large #1}} \nopagebreak
+ \vskip \postSskip \nopagebreak}
+
+\newcommand{\jsssimplesec}[2][default]{\vskip \preLskip%
+%% \pdfbookmark[1]{#1}{Section.\thesection.#1}%
+ \refstepcounter{section}%
+ \textbf{\large #1} \nopagebreak
+ \vskip \postSskip \nopagebreak}
+\newcommand{\jsssimplesecnn}[1]{\vskip \preLskip%
+ \textbf{\large #1} \nopagebreak
+ \vskip \postSskip \nopagebreak}
+
+\if at review
+ \renewcommand{\section}{\secdef \jsssimplesec \jsssimplesecnn}
+ \renewcommand{\subsection}{\secdef \jsssimplesec \jsssimplesecnn}
+ \renewcommand{\subsubsection}{\secdef \jsssimplesec \jsssimplesecnn}
+\else
+ \renewcommand{\section}{\secdef \jsssec \jsssecnn}
+ \renewcommand{\subsection}{\secdef \jsssubsec \jsssubsecnn}
+ \renewcommand{\subsubsection}{\secdef \jsssubsubsec \jsssubsubsecnn}
+\fi
+%% colors
+\definecolor{Red}{rgb}{0.5,0,0}
+\definecolor{Blue}{rgb}{0,0,0.5}
+\if at review
+ \hypersetup{%
+ hyperindex = {true},
+ colorlinks = {true},
+ linktocpage = {true},
+ plainpages = {false},
+ linkcolor = {Blue},
+ citecolor = {Blue},
+ urlcolor = {Red},
+ pdfstartview = {Fit},
+ pdfpagemode = {None},
+ pdfview = {XYZ null null null}
+ }
+\else
+ \hypersetup{%
+ hyperindex = {true},
+ colorlinks = {true},
+ linktocpage = {true},
+ plainpages = {false},
+ linkcolor = {Blue},
+ citecolor = {Blue},
+ urlcolor = {Red},
+ pdfstartview = {Fit},
+ pdfpagemode = {UseOutlines},
+ pdfview = {XYZ null null null}
+ }
+\fi
+\if at nojss
+ \AtBeginDocument{
+ \hypersetup{%
+ pdfauthor = {\@Hyperauthor},
+ pdftitle = {\@Plaintitle},
+ pdfkeywords = {\@Plainkeywords}
+ }
+ }
+\else
+ \AtBeginDocument{
+ \hypersetup{%
+ pdfauthor = {\@Hyperauthor},
+ pdftitle = {\@Plaintitle},
+ pdfsubject = {\@Hypersubject},
+ pdfkeywords = {\@Plainkeywords}
+ }
+ }
+\fi
+\AtBeginDocument{\maketitle}
+%% commands
+\makeatletter
+\newcommand\code{\bgroup\@makeother\_\@makeother\~\@makeother\$\@codex}
+\def\@codex#1{{\normalfont\ttfamily\hyphenchar\font=-1 #1}\egroup}
+\makeatother
+%%\let\code=\texttt
+\let\proglang=\textsf
+\newcommand{\pkg}[1]{{\fontseries{b}\selectfont #1}}
+\newcommand{\email}[1]{\href{mailto:#1}{\normalfont\texttt{#1}}}
+\newcommand{\doi}[1]{\href{http://dx.doi.org/#1}{\normalfont\texttt{doi:#1}}}
+\newcommand{\E}{\mathsf{E}}
+\newcommand{\VAR}{\mathsf{VAR}}
+\newcommand{\COV}{\mathsf{COV}}
+\newcommand{\Prob}{\mathsf{P}}
+\endinput
+%%
+%% End of file `jss.cls'.
diff --git a/man/AA.Aa.aa.Rd b/man/AA.Aa.aa.Rd
index 181b62f..2cd9152 100644
--- a/man/AA.Aa.aa.Rd
+++ b/man/AA.Aa.aa.Rd
@@ -60,7 +60,6 @@ Sunderland, MA: Sinauer Associates, Inc.
}
\examples{
y = cbind(53, 95, 38)
-fit = vglm(y ~ 1, AA.Aa.aa(link="logit"), trace=TRUE)
fit = vglm(y ~ 1, AA.Aa.aa(link="probit"), trace=TRUE)
rbind(y, sum(y)*fitted(fit))
Coef(fit) # Estimated pA
diff --git a/man/AB.Ab.aB.ab2.Rd b/man/AB.Ab.aB.ab2.Rd
index 3e0f129..8014a67 100644
--- a/man/AB.Ab.aB.ab2.Rd
+++ b/man/AB.Ab.aB.ab2.Rd
@@ -65,7 +65,6 @@ family function.
# See Elandt-Johnson, pp.430,427
# Estimated variance is approx 0.0021
y = cbind(68, 11, 13, 21)
-fit = vglm(y ~ 1, AB.Ab.aB.ab2(link=logit), trace=TRUE, crit="coef")
fit = vglm(y ~ 1, AB.Ab.aB.ab2(link=cloglog), trace=TRUE, crit="coef")
Coef(fit) # Estimated p
rbind(y, sum(y)*fitted(fit))
diff --git a/man/ABO.Rd b/man/ABO.Rd
index a7f6931..f49a2e4 100644
--- a/man/ABO.Rd
+++ b/man/ABO.Rd
@@ -72,7 +72,6 @@ ABO(link = "logit", earg=list(), ipA = NULL, ipO = NULL)
}
\examples{
y = cbind(A=725, B=258, AB=72, O=1073) # Order matters, not the name
-fit = vglm(y ~ 1, ABO(link=logit), trace=TRUE, cri="coef")
fit = vglm(y ~ 1, ABO(link=identity), trace=TRUE, cri="coef")
coef(fit, matrix=TRUE)
Coef(fit) # Estimated pA and pB
diff --git a/man/AICvlm.Rd b/man/AICvlm.Rd
index ef83504..0458241 100644
--- a/man/AICvlm.Rd
+++ b/man/AICvlm.Rd
@@ -85,12 +85,12 @@ AICvlm(object, \dots, k = 2)
}
\examples{
pneumo = transform(pneumo, let=log(exposure.time))
-(fit1 = vglm(cbind(normal, mild, severe) ~ let,
- cumulative(parallel=TRUE, reverse=TRUE), pneumo))
+(fit1 <- vglm(cbind(normal, mild, severe) ~ let,
+ cumulative(parallel=TRUE, reverse=TRUE), pneumo))
coef(fit1, matrix=TRUE)
AIC(fit1)
-(fit2 = vglm(cbind(normal, mild, severe) ~ let,
- cumulative(parallel=FALSE, reverse=TRUE), pneumo))
+(fit2 <- vglm(cbind(normal, mild, severe) ~ let,
+ cumulative(parallel=FALSE, reverse=TRUE), pneumo))
coef(fit2, matrix=TRUE)
AIC(fit2)
}
diff --git a/man/BratUC.Rd b/man/BratUC.Rd
index 4e24f2b..cb2f47e 100644
--- a/man/BratUC.Rd
+++ b/man/BratUC.Rd
@@ -35,13 +35,12 @@ The second value is used to handle ties.
}
}
\details{
- In the \pkg{VGAM} package
- it is necessary for each matrix to be represented as a single
-row of data by \code{\link{brat}} and \code{\link{bratt}}.
-Hence the non-diagonal elements of the \eqn{M+1} by \eqn{M+1} matrix
-are concatenated into \eqn{M(M+1)} values (no ties), while
-if there are ties, the non-diagonal elements of the \eqn{M} by \eqn{M} matrix
-are concatenated into \eqn{M(M-1)} values.
+ In the \pkg{VGAM} package it is necessary for each matrix to
+ be represented as a single row of data by \code{\link{brat}} and
+ \code{\link{bratt}}. Hence the non-diagonal elements of the \eqn{M+1}
+ by \eqn{M+1} matrix are concatenated into \eqn{M(M+1)} values (no ties),
+ while if there are ties, the non-diagonal elements of the \eqn{M}
+ by \eqn{M} matrix are concatenated into \eqn{M(M-1)} values.
}
\value{
diff --git a/man/Coef.qrrvglm-class.Rd b/man/Coef.qrrvglm-class.Rd
index af12152..71a0ad4 100644
--- a/man/Coef.qrrvglm-class.Rd
+++ b/man/Coef.qrrvglm-class.Rd
@@ -114,10 +114,10 @@ y1 = rpois(n, lambda1)
y2 = rpois(n, lambda2)
y3 = rpois(n, lambda3)
yy = cbind(y1,y2,y3)
-p1 = cqo(yy ~ x2 + x3 + x4, fam=poissonff, trace=FALSE)
+# vvv p1 = cqo(yy ~ x2 + x3 + x4, fam=poissonff, trace=FALSE)
\dontrun{
lvplot(p1, y=TRUE, lcol=1:3, pch=1:3, pcol=1:3)
}
-print(Coef(p1), digits=3)
+# vvv print(Coef(p1), digits=3)
}
\keyword{classes}
diff --git a/man/Coef.qrrvglm.Rd b/man/Coef.qrrvglm.Rd
index 1feb168..0371a02 100644
--- a/man/Coef.qrrvglm.Rd
+++ b/man/Coef.qrrvglm.Rd
@@ -117,12 +117,12 @@ y1 = rpois(n, lambda1)
y2 = rpois(n, lambda2)
y3 = rpois(n, lambda3)
set.seed(111)
-p1 = cqo(cbind(y1,y2,y3) ~ x2 + x3 + x4, poissonff, trace=FALSE)
+# vvv p1 = cqo(cbind(y1,y2,y3) ~ x2 + x3 + x4, poissonff, trace=FALSE)
\dontrun{
lvplot(p1, y=TRUE, lcol=1:3, pch=1:3, pcol=1:3)
}
-Coef(p1)
-print(Coef(p1), digits=3)
+# vvv Coef(p1)
+# vvv print(Coef(p1), digits=3)
}
\keyword{models}
\keyword{regression}
diff --git a/man/CommonVGAMffArguments.Rd b/man/CommonVGAMffArguments.Rd
index 3b17b3b..e330c5f 100644
--- a/man/CommonVGAMffArguments.Rd
+++ b/man/CommonVGAMffArguments.Rd
@@ -4,21 +4,18 @@
\title{Common VGAM family function Arguments }
\description{
Here is a description of some common and typical arguments found
- in \pkg{VGAM} family functions, e.g.,
+ in many \pkg{VGAM} family functions, e.g.,
\code{lsigma},
\code{isigma}, \code{nsimEI}, \code{parallel} and \code{zero}.
}
\usage{
-TypicalVGAMfamilyFunction(lsigma="loge", esigma=list(),
- isigma=NULL, parallel = TRUE,
- shrinkage.init = 0.95,
- method.init=1, nsimEIM=100, zero=NULL)
+TypicalVGAMfamilyFunction(lsigma = "loge", esigma = list(), isigma = NULL,
+ parallel = TRUE, shrinkage.init = 0.95,
+ nointercept = NULL, method.init = 1,
+ nsimEIM = 100, zero = NULL)
}
\arguments{
- Almost every \pkg{VGAM} family function has an argument list similar to
- the one given above. Below, \eqn{M} is the number of linear/additive
- predictors.
\item{lsigma}{
Character.
@@ -106,6 +103,8 @@ TypicalVGAMfamilyFunction(lsigma="loge", esigma=list(),
set \eqn{\{1,2,\ldots,M\}}.
The value \code{zero=NULL} means model all linear/additive predictors
as functions of the explanatory variables.
+ Here, \eqn{M} is the number of linear/additive predictors.
+
Some \pkg{VGAM} family functions allow the \code{zero} argument to
accept negative values; if so then its absolute value is recycled
@@ -131,6 +130,13 @@ TypicalVGAMfamilyFunction(lsigma="loge", esigma=list(),
the argument \code{method.init} is assigned a certain value.
}
+ \item{nointercept}{
+ An integer-valued vector specifying which
+ linear/additive predictors have no intercepts.
+ Any values must be from the set \{1,2,\ldots,\eqn{M}\}.
+ A value of \code{NULL} means no such constraints.
+
+ }
}
\value{
@@ -147,6 +153,20 @@ TypicalVGAMfamilyFunction(lsigma="loge", esigma=list(),
If not sure, use, e.g., \code{constraints(fit)} and
\code{coef(fit, matrix=TRUE)} to check the result of a fit \code{fit}.
+
+ The arguments \code{zero} and \code{nointercept} can be inputted
+ with values that fail. For example,
+ \code{multinomial(zero = 2, nointercept = 1:3)} means the
+ second linear/additive predictor is identically zero,
+ which will cause a failure.
+
+
+ Be careful about the use of other potentially contradictory constraints,
+ e.g., \code{multinomial(zero = 2, parallel = TRUE ~ x3)}. If in doubt,
+ apply \code{constraints()} to the fitted object to check.
+
+
+
\pkg{VGAM} family functions with the \code{nsimEIM} may have inaccurate
working weight matrices. If so, then the standard errors of the
regression coefficients may be inaccurate. Thus output from
diff --git a/man/DeLury.Rd b/man/DeLury.Rd
index cd81005..c5d7846 100644
--- a/man/DeLury.Rd
+++ b/man/DeLury.Rd
@@ -123,6 +123,11 @@ statistics of fish populations.
\emph{Bull. Fish. Res. Bd. Can.},
\bold{191}, 382--
+ Yee, T. W. (2009)
+ VGLMs and VGAMs: an overview for applications in fisheries research.
+ In press.
+
+
}
\author{ T. W. Yee. }
\note{
diff --git a/man/Links.Rd b/man/Links.Rd
index 01918cb..d0f6572 100644
--- a/man/Links.Rd
+++ b/man/Links.Rd
@@ -13,14 +13,6 @@ TypicalVGAMlinkFunction(theta, earg=list(), inverse=FALSE,
deriv=0, short=TRUE, tag=FALSE)
}
\arguments{
- Almost all \pkg{VGAM} link functions have something similar to
- the argument list as given above.
- That is, there is a matching \code{earg} for each \code{link}
- argument.
- In the following we have \eqn{\eta=g(\theta)}{eta=g(theta)}
- where \eqn{g} is the link function, \eqn{\theta}{theta} is the parameter
- and \eqn{\eta}{eta} is the linear/additive predictor.
-
\item{theta}{
Numeric or character.
Actually this can be \eqn{\theta}{theta} (default) or \eqn{\eta}{eta},
@@ -69,6 +61,7 @@ TypicalVGAMlinkFunction(theta, earg=list(), inverse=FALSE,
}
}
\value{
+
Returns one of the link function value or its first or second derivative,
the inverse link or its first or second derivative,
or a character description of the link.
@@ -94,6 +87,18 @@ TypicalVGAMlinkFunction(theta, earg=list(), inverse=FALSE,
}
\details{
+ Almost all \pkg{VGAM} link functions have something similar to
+ the argument list as given above.
+ That is, there is a matching \code{earg} for each \code{link} argument.
+ In this help file
+ we have \eqn{\eta=g(\theta)}{eta=g(theta)}
+ where \eqn{g} is the link function, \eqn{\theta}{theta} is the parameter
+ and \eqn{\eta}{eta} is the linear/additive predictor.
+
+
+
+
+
The following is a brief enumeration of all \pkg{VGAM} link functions.
For parameters lying between 0 and 1 (e.g., probabilities):
@@ -150,6 +155,11 @@ TypicalVGAMlinkFunction(theta, earg=list(), inverse=FALSE,
}
\author{T. W. Yee}
\note{
+ \pkg{VGAM} link functions are generally not compatible with other functions
+ outside the package.
+ In particular, they won't work with
+ \code{\link[stats]{glm}} or any other package for fitting GAMs.
+
From October 2006 onwards,
all \pkg{VGAM} family functions will only
contain one default value for each link argument rather than giving a
diff --git a/man/Opt.Rd b/man/Opt.Rd
index 0a72369..0ef6307 100644
--- a/man/Opt.Rd
+++ b/man/Opt.Rd
@@ -70,13 +70,13 @@ called the \emph{species score}.
\examples{
set.seed(111) # This leads to the global solution
hspider[,1:6] = scale(hspider[,1:6]) # Standardized environmental vars
-p1 = cqo(cbind(Alopacce, Alopcune, Alopfabr, Arctlute, Arctperi,
- Auloalbi, Pardlugu, Pardmont, Pardnigr, Pardpull,
- Trocterr, Zoraspin) ~
- WaterCon + BareSand + FallTwig + CoveMoss + CoveHerb + ReflLux,
- Bestof = 2,
- fam = quasipoissonff, data = hspider, Crow1positive=FALSE)
-Opt(p1)
+# vvv p1 = cqo(cbind(Alopacce, Alopcune, Alopfabr, Arctlute, Arctperi,
+# vvv Auloalbi, Pardlugu, Pardmont, Pardnigr, Pardpull,
+# vvv Trocterr, Zoraspin) ~
+# vvv WaterCon + BareSand + FallTwig + CoveMoss + CoveHerb + ReflLux,
+# vvv Bestof = 2,
+# vvv fam = quasipoissonff, data = hspider, Crow1positive=FALSE)
+# vvv Opt(p1)
\dontrun{
index = 1:ncol(p1 at y)
diff --git a/man/SurvS4-class.Rd b/man/SurvS4-class.Rd
index ed59328..ef744d7 100644
--- a/man/SurvS4-class.Rd
+++ b/man/SurvS4-class.Rd
@@ -30,7 +30,7 @@ Class \code{"\linkS4class{vector}"}, by class "matrix", distance 4, with explici
T. W. Yee.
}
\note{
- The purpose of having \code{\link{Surv}} in \pkg{VGAM} is so that
+ The purpose of having \code{\link{SurvS4}} in \pkg{VGAM} is so that
the same input can be fed into \code{\link{vglm}} as functions in
\pkg{survival} such as \code{\link[survival]{survreg}}.
@@ -42,7 +42,7 @@ Class \code{"\linkS4class{vector}"}, by class "matrix", distance 4, with explici
}
\seealso{
- \code{\link{Surv}}.
+ \code{\link{SurvS4}}.
% or \code{\linkS4class{CLASSNAME}} for links to other classes
}
\examples{
diff --git a/man/Surv.Rd b/man/SurvS4.Rd
similarity index 93%
rename from man/Surv.Rd
rename to man/SurvS4.Rd
index 9731a0e..80f1d55 100644
--- a/man/Surv.Rd
+++ b/man/SurvS4.Rd
@@ -1,5 +1,5 @@
-\name{Surv}
-\alias{Surv}
+\name{SurvS4}
+\alias{SurvS4}
\alias{is.SurvS4}
\alias{print.SurvS4}
\alias{Math.SurvS4}
@@ -19,7 +19,7 @@ Create a Survival Object
}
\usage{
-Surv(time, time2, event, type =, origin = 0)
+SurvS4(time, time2, event, type =, origin = 0)
is.SurvS4(x)
}
\arguments{
@@ -71,8 +71,8 @@ is.SurvS4(x)
\details{
Typical usages are
\preformatted{
-Surv(time, event)
-Surv(time, time2, event, type=, origin=0)
+SurvS4(time, event)
+SurvS4(time, time2, event, type=, origin=0)
}
In theory it is possible to represent interval censored data without a
@@ -122,7 +122,7 @@ guess wrong. Use 0/1 coding in this case.
}
\note{
- The purpose of having \code{Surv} in \pkg{VGAM} is so that
+ The purpose of having \code{SurvS4} in \pkg{VGAM} is so that
the same input can be fed into \code{\link{vglm}} as functions in
\pkg{survival} such as \code{\link[survival]{survreg}}. The class
name has been changed from \code{"Surv"} to \code{"SurvS4"}; see
@@ -144,8 +144,9 @@ guess wrong. Use 0/1 coding in this case.
\code{\link{leukemia}}.
}
\examples{
-with(leukemia, Surv(time, status))
+with(leukemia, SurvS4(time, status))
+class(with(leukemia, SurvS4(time, status)))
}
\keyword{survival}
% Converted by Sd2Rd version 0.3-2.
-% with(heart, Surv(start,stop,event))
+% with(heart, SurvS4(start,stop,event))
diff --git a/man/Tol.Rd b/man/Tol.Rd
index 380adeb..a2190dc 100644
--- a/man/Tol.Rd
+++ b/man/Tol.Rd
@@ -81,14 +81,14 @@ Constrained additive ordination.
\examples{
set.seed(111) # This leads to the global solution
hspider[,1:6] = scale(hspider[,1:6]) # Standardized environmental vars
-p1 = cqo(cbind(Alopacce, Alopcune, Alopfabr, Arctlute, Arctperi,
- Auloalbi, Pardlugu, Pardmont, Pardnigr, Pardpull,
- Trocterr, Zoraspin) ~
- WaterCon + BareSand + FallTwig + CoveMoss + CoveHerb + ReflLux,
- Bestof = 2,
- fam = quasipoissonff, data = hspider, Crow1positive=FALSE)
-
-Tol(p1)
+# vvv p1 = cqo(cbind(Alopacce, Alopcune, Alopfabr, Arctlute, Arctperi,
+# vvv Auloalbi, Pardlugu, Pardmont, Pardnigr, Pardpull,
+# vvv Trocterr, Zoraspin) ~
+# vvv WaterCon + BareSand + FallTwig + CoveMoss + CoveHerb + ReflLux,
+# vvv Bestof = 2,
+# vvv fam = quasipoissonff, data = hspider, Crow1positive=FALSE)
+# vvv
+# vvv Tol(p1)
}
\keyword{models}
\keyword{regression}
diff --git a/man/VGAM-package.Rd b/man/VGAM-package.Rd
index aae4b45..24bfdf7 100644
--- a/man/VGAM-package.Rd
+++ b/man/VGAM-package.Rd
@@ -71,6 +71,14 @@ Maintainer: Thomas Yee <t.yee at auckland.ac.nz>
}
\references{
+
+Yee, T. W. (2010)
+The \pkg{VGAM} package for categorical data analysis.
+\emph{Journal of Statistical Software},
+\bold{32}, 1--34.
+\url{http://www.jstatsoft.org/v32/i10/}.
+
+
Yee, T. W. and Hastie, T. J. (2003)
Reduced-rank vector generalized linear models.
\emph{Statistical Modelling},
@@ -116,19 +124,16 @@ contains further information and examples.
%~~ \code{\link[<pkg>:<pkg>-package]{<pkg>}} ~~
}
\examples{
-# Example 1
-# 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,
- cumulative(parallel=TRUE, reverse=TRUE), pneumo))
+# Example 1; proportional odds model
+pneumo = transform(pneumo, let = log(exposure.time))
+(fit = vglm(cbind(normal, mild, severe) ~ let, propodds, pneumo))
fit at y # Sample proportions
-weights(fit, type="prior") # Number of observations
-coef(fit, matrix=TRUE)
-constraints(fit) # Constraint matrices
+weights(fit, type = "prior") # Number of observations
+coef(fit, matrix = TRUE) # p.179, in McCullagh and Nelder (1989)
+constraints(fit) # Constraint matrices
-# Example 2
-# Zero-inflated Poisson model
+# Example 2; zero-inflated Poisson model
x = runif(n <- 2000)
phi = logit(-0.5 + 1*x, inverse=TRUE)
lambda = loge(0.5 + 2*x, inverse=TRUE)
@@ -138,24 +143,22 @@ fit = vglm(y ~ x, zipoisson, trace=TRUE)
coef(fit, matrix=TRUE) # These should agree with the above values
-# Example 3
-# Fit a two species GAM simultaneously
+# Example 3; fit a two species GAM simultaneously
fit2 = vgam(cbind(agaaus, kniexc) ~ s(altitude, df=c(2,3)),
binomialff(mv=TRUE), hunua)
coef(fit2, mat=TRUE) # Not really interpretable
\dontrun{
plot(fit2, se=TRUE, overlay=TRUE, lcol=1:2, scol=1:2)
-o = with(hunua, order(altitude))
-with(hunua, matplot(altitude[o], fitted(fit2)[o,], type="l", lwd=2,
+ooo = with(hunua, order(altitude))
+with(hunua, matplot(altitude[ooo], fitted(fit2)[ooo,], type="l", lwd=2,
xlab="Altitude (m)", ylab="Probability of presence", las=1,
main="Two plant species' response curves", ylim=c(0,.8)))
with(hunua, rug(altitude))
}
-# Example 4
-# LMS quantile regression
+# Example 4; LMS quantile regression
fit = vgam(BMI ~ s(age, df=c(4,2)), lms.bcn(zero=1), dat=bminz, trac=TRUE)
head(predict(fit))
head(fitted(fit))
@@ -180,14 +183,13 @@ a at post$deplot # Contains density function values
}
-# Example 5
-# GEV distribution for extremes
+# Example 5; GEV distribution for extremes
(fit = vglm(maxtemp ~ 1, egev, data=oxtemp, trace=TRUE))
head(fitted(fit))
-coef(fit, mat=TRUE)
+coef(fit, mat = TRUE)
Coef(fit)
vcov(fit)
-vcov(fit, untransform=TRUE)
+vcov(fit, untransform = TRUE)
sqrt(diag(vcov(fit))) # Approximate standard errors
\dontrun{ rlplot(fit) }
}
diff --git a/man/acat.Rd b/man/acat.Rd
index 0780a25..a711d5a 100644
--- a/man/acat.Rd
+++ b/man/acat.Rd
@@ -12,10 +12,6 @@ acat(link = "loge", earg = list(),
}
%- maybe also 'usage' for other objects documented here.
\arguments{
- In the following, the response \eqn{Y} is assumed to be a factor
- with ordered values \eqn{1,2,\ldots,M+1}, so that
- \eqn{M} is the number of linear/additive predictors
- \eqn{\eta_j}{eta_j}.
\item{link}{
Link function applied to the ratios of the
@@ -51,6 +47,12 @@ acat(link = "loge", earg = list(),
}
}
\details{
+ In this help file the response \eqn{Y} is assumed to be a factor
+ with ordered values \eqn{1,2,\ldots,M+1}, so that
+ \eqn{M} is the number of linear/additive predictors
+ \eqn{\eta_j}{eta_j}.
+
+
By default, the log link is used because the ratio of two probabilities
is positive.
@@ -67,10 +69,19 @@ Agresti, A. (2002)
\emph{Categorical Data Analysis},
2nd ed. New York: Wiley.
+
Simonoff, J. S. (2003)
\emph{Analyzing Categorical Data},
New York: Springer-Verlag.
+
+Yee, T. W. (2010)
+The \pkg{VGAM} package for categorical data analysis.
+\emph{Journal of Statistical Software},
+\bold{32}, 1--34.
+\url{http://www.jstatsoft.org/v32/i10/}.
+
+
Documentation accompanying the \pkg{VGAM} package at
\url{http://www.stat.auckland.ac.nz/~yee}
contains further information and examples.
@@ -107,7 +118,7 @@ contains further information and examples.
}
\examples{
pneumo = transform(pneumo, let=log(exposure.time))
-(fit = vglm(cbind(normal,mild,severe) ~ let, acat, pneumo))
+(fit <- vglm(cbind(normal,mild,severe) ~ let, acat, pneumo))
coef(fit, matrix=TRUE)
constraints(fit)
model.matrix(fit)
diff --git a/man/alaplace3.Rd b/man/alaplace3.Rd
index a5ef059..bdc3226 100644
--- a/man/alaplace3.Rd
+++ b/man/alaplace3.Rd
@@ -256,24 +256,24 @@ Boston: Birkhauser.
\examples{
# Example 1: quantile regression with smoothing splines
-alldat = data.frame(x = sort(runif(n <- 500)))
+adata = data.frame(x = sort(runif(n <- 500)))
mymu = function(x) exp(-2 + 6*sin(2*x-0.2) / (x+0.5)^2)
-alldat = transform(alldat, y = rpois(n, lambda=mymu(x)))
+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), data=alldat, trace=TRUE)
+ parallelLoc=FALSE), adata, trace=TRUE)
fitp = vgam(y ~ s(x, df=mydof), alaplace1(tau=mytau, llocation="loge",
- parallelLoc=TRUE), data=alldat, trace=TRUE)
+ parallelLoc=TRUE), adata, trace=TRUE)
\dontrun{
par(las=1)
mylwd = 1.5
-with(alldat, plot(x, jitter(y, factor=0.5), col="red",
+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(alldat, matlines(x, fitted(fit), col="blue", lty="solid", lwd=mylwd))
-with(alldat, 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)),
@@ -287,18 +287,18 @@ fit at extra # Contains useful information
fitp2 = vglm(y ~ bs(x, df=mydof),
family = alaplace1(tau=mytau, llocation="loge",
parallelLoc=TRUE),
- data=alldat, trace=TRUE)
+ adata, trace=TRUE)
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"),
- data=alldat)
+ adata)
\dontrun{
-with(alldat, plot(x, jitter(y, factor=0.5), col="red", ylab="y",
+with(adata, plot(x, jitter(y, factor=0.5), col="red", ylab="y",
pch="o", cex=0.75,
main="Example 2; parallelLoc=TRUE"))
-with(alldat, matlines(x, fitted(fitp2), col="blue", lty="solid", lwd=mylwd))
-with(alldat, matlines(x, fitted(fitp3), col="black", lty="solid", lwd=mylwd))
+with(adata, matlines(x, fitted(fitp2), col="blue", lty="solid", lwd=mylwd))
+with(adata, matlines(x, fitted(fitp3), col="black", lty="solid", lwd=mylwd))
}
@@ -308,33 +308,33 @@ with(alldat, matlines(x, fitted(fitp3), col="black", lty="solid", lwd=mylwd))
# link to ensure an increasing quantiles at any value of x.
mytau = seq(0.2, 0.9, by=0.1)
-answer = matrix(0, nrow(alldat), length(mytau)) # Stores the quantiles
-alldat = transform(alldat, offsety=y*0)
+answer = matrix(0, nrow(adata), length(mytau)) # Stores the quantiles
+adata = transform(adata, offsety=y*0)
usetau = mytau
for(ii in 1:length(mytau)) {
# cat("\n\nii =", ii, "\n")
- alldat = transform(alldat, usey=y-offsety)
- iloc = ifelse(ii==1, with(alldat, median(y)), 1.0) # Well-chosen!
+ adata = transform(adata, usey=y-offsety)
+ 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), data=alldat, trace=TRUE,
+ fit3 = vglm(usey ~ ns(x, df=mydf), adata, trace=TRUE,
fam=alaplace1(tau=usetau[ii], lloc=lloc, iloc=iloc))
answer[,ii] = (if(ii==1) 0 else answer[,ii-1]) + fitted(fit3)
- alldat = transform(alldat, offsety=answer[,ii])
+ adata = transform(adata, offsety=answer[,ii])
}
# Plot the results.
\dontrun{
-with(alldat, plot(x, y, col="blue",
+with(adata, plot(x, y, col="blue",
main=paste("Noncrossing and nonparallel; tau =",
paste(mytau, collapse=", "))))
-with(alldat, matlines(x, answer, col="red", lty=1))
+with(adata, matlines(x, answer, col="red", lty=1))
# Zoom in near the origin.
-with(alldat, plot(x, y, col="blue", xlim=c(0, 0.2), ylim=0:1,
+with(adata, plot(x, y, col="blue", xlim=c(0, 0.2), ylim=0:1,
main=paste("Noncrossing and nonparallel; tau =",
paste(mytau, collapse=", "))))
-with(alldat, matlines(x, answer, col="red", lty=1))
+with(adata, matlines(x, answer, col="red", lty=1))
}
}
\keyword{models}
diff --git a/man/amh.Rd b/man/amh.Rd
index d2ca0ff..45d917e 100644
--- a/man/amh.Rd
+++ b/man/amh.Rd
@@ -9,8 +9,7 @@
}
\usage{
-amh(lalpha="rhobit", ealpha=list(), ialpha=NULL,
- method.init=1, nsimEIM=250)
+amh(lalpha="rhobit", ealpha=list(), ialpha=NULL, method.init=1, nsimEIM=250)
}
%- maybe also 'usage' for other objects documented here.
\arguments{
diff --git a/man/amlbinomial.Rd b/man/amlbinomial.Rd
index f162ddf..ac26422 100644
--- a/man/amlbinomial.Rd
+++ b/man/amlbinomial.Rd
@@ -8,13 +8,10 @@
}
\usage{
-amlbinomial(w.aml=1, parallel=FALSE, digw=4, link="logit", earg=list())
+amlbinomial(w.aml = 1, parallel = FALSE, digw = 4, link = "logit", earg = list())
}
%- maybe also 'usage' for other objects documented here.
\arguments{
- In this documentation the word \emph{quantile} can often be
- interchangeably replaced by \emph{expectile}
- (things are informal here).
\item{w.aml}{
Numeric, a vector of positive constants controlling the percentiles.
@@ -81,12 +78,20 @@ amlbinomial(w.aml=1, parallel=FALSE, digw=4, link="logit", earg=list())
Also, the individual deviance values corresponding to each element of
the argument \code{w.aml} is stored in the \code{extra} slot.
+
For \code{amlbinomial} objects, methods functions for the generic functions
\code{qtplot} and \code{cdf} have not been written yet.
+
See \code{\link{amlpoisson}} about comments on the jargon, e.g.,
\emph{expectiles} etc.
+
+ In this documentation the word \emph{quantile} can often be
+ interchangeably replaced by \emph{expectile}
+ (things are informal here).
+
+
}
\section{Warning }{
@@ -107,11 +112,10 @@ amlbinomial(w.aml=1, parallel=FALSE, digw=4, link="logit", earg=list())
\examples{
# Example: binomial data with lots of trials per observation
set.seed(1234)
-sizevec = rep(100, length=(n <- 200))
-mydat = data.frame(x = sort(runif(n)))
-mydat = transform(mydat,
- prob=logit(-0+2.5*x+x^2, inverse=TRUE))
-mydat = transform(mydat, y = rbinom(n, size=sizevec, prob=prob))
+sizevec = rep(100, length=(nn <- 200))
+mydat = data.frame(x = sort(runif(nn)))
+mydat = transform(mydat, prob=logit(-0+2.5*x+x^2, inverse=TRUE))
+mydat = transform(mydat, y = rbinom(nn, size=sizevec, prob=prob))
mydat = transform(mydat, y = y / sizevec) # Convert to proportions
(fit = vgam(y ~ s(x, df=3), fam=amlbinomial(w=c(0.01,0.2,1,5,60)),
data=mydat, weight=sizevec, trace=TRUE))
diff --git a/man/amlexponential.Rd b/man/amlexponential.Rd
index 6705167..ce3ebbf 100644
--- a/man/amlexponential.Rd
+++ b/man/amlexponential.Rd
@@ -8,14 +8,11 @@
}
\usage{
-amlexponential(w.aml=1, parallel=FALSE, method.init=1, digw=4,
- link="loge", earg=list())
+amlexponential(w.aml = 1, parallel = FALSE, method.init = 1, digw = 4,
+ link = "loge", earg = list())
}
%- maybe also 'usage' for other objects documented here.
\arguments{
- In this documentation the word \emph{quantile} can often be
- interchangeably replaced by \emph{expectile}
- (things are informal here).
\item{w.aml}{
Numeric, a vector of positive constants controlling the expectiles.
@@ -87,12 +84,20 @@ amlexponential(w.aml=1, parallel=FALSE, method.init=1, digw=4,
Also, the individual deviance values corresponding to each element of
the argument \code{w.aml} is stored in the \code{extra} slot.
+
For \code{amlexponential} objects, methods functions for the generic functions
\code{qtplot} and \code{cdf} have not been written yet.
+
See \code{\link{amlpoisson}} about comments on the jargon, e.g.,
\emph{expectiles} etc.
+
+ In this documentation the word \emph{quantile} can often be
+ interchangeably replaced by \emph{expectile}
+ (things are informal here).
+
+
}
\section{Warning }{
@@ -116,13 +121,13 @@ amlexponential(w.aml=1, parallel=FALSE, method.init=1, digw=4,
}
\examples{
-n = 2000
-mydat = data.frame(x = seq(0, 1, length=n))
+nn = 2000
+mydat = data.frame(x = seq(0, 1, length=nn))
mydat = transform(mydat, mu = loge(-0+1.5*x+0.2*x^2, inverse=TRUE))
mydat = transform(mydat, mu = loge(0-sin(8*x), inverse=TRUE))
-mydat = transform(mydat, y = rexp(n, rate=1/mu))
+mydat = transform(mydat, y = rexp(nn, rate=1/mu))
(fit = vgam(y ~ s(x,df=5), amlexponential(w=c(0.001,0.1,0.5,5,60)),
- data=mydat, trace=TRUE))
+ mydat, trace=TRUE))
fit at extra
\dontrun{
diff --git a/man/amlnormal.Rd b/man/amlnormal.Rd
index 239b2d7..f525122 100644
--- a/man/amlnormal.Rd
+++ b/man/amlnormal.Rd
@@ -11,17 +11,13 @@
}
\usage{
-amlnormal(w.als=1, parallel=FALSE, lexpectile = "identity",
- eexpectile = list(), iexpectile = NULL,
- method.init=1, digw=4)
+amlnormal(w.aml = 1, parallel = FALSE, lexpectile = "identity",
+ eexpectile = list(), iexpectile = NULL, method.init = 1, digw = 4)
}
%- maybe also 'usage' for other objects documented here.
\arguments{
- In this documentation the word \emph{quantile} can often be
- interchangeably replaced by \emph{expectile}
- (things are informal here).
- \item{w.als}{
+ \item{w.aml}{
Numeric, a vector of positive constants controlling the percentiles.
The larger the value the larger the fitted percentile value
(the proportion of points below the ``w-regression plane'').
@@ -30,7 +26,7 @@ amlnormal(w.als=1, parallel=FALSE, lexpectile = "identity",
}
\item{parallel}{
- If \code{w.als} has more than one value then
+ If \code{w.aml} has more than one value then
this argument allows the quantile curves to differ by the same amount
as a function of the covariates.
Setting this to be \code{TRUE} should force the quantile curves to
@@ -49,7 +45,7 @@ amlnormal(w.als=1, parallel=FALSE, lexpectile = "identity",
}
\item{digw }{
Passed into \code{\link[base]{Round}} as the \code{digits} argument
- for the \code{w.als} values;
+ for the \code{w.aml} values;
used cosmetically for labelling.
}
@@ -85,29 +81,40 @@ amlnormal(w.als=1, parallel=FALSE, lexpectile = "identity",
\author{ Thomas W. Yee }
\note{
- On fitting, the \code{extra} slot has list components \code{"w.als"} and
+ On fitting, the \code{extra} slot has list components \code{"w.aml"} and
\code{"percentile"}. The latter is the percent of observations below
the ``w-regression plane'', which is the fitted values.
- One difficulty is finding the \code{w.als} value giving a specified
+
+ One difficulty is finding the \code{w.aml} value giving a specified
percentile. One solution is to fit the model within a root finding
function such as \code{\link[stats]{uniroot}}; see the example below.
+
For \code{amlnormal} objects, methods functions for the generic functions
\code{qtplot} and \code{cdf} have not been written yet.
+
See the note in \code{\link{amlpoisson}} on the jargon, including
\emph{expectiles} and \emph{regression quantiles}.
+
The \code{deviance} slot computes the total asymmetric squared error
loss (2.5).
- If \code{w.als} has more than one value then the value returned by
- the slot is the sum taken over all the \code{w.als} values.
+ If \code{w.aml} has more than one value then the value returned by
+ the slot is the sum taken over all the \code{w.aml} values.
+
This \pkg{VGAM} family function could well be renamed \code{amlnormal()}
instead, given the other function names \code{\link{amlpoisson}},
\code{\link{amlbinomial}}, etc.
+
+ In this documentation the word \emph{quantile} can often be
+ interchangeably replaced by \emph{expectile}
+ (things are informal here).
+
+
}
%\section{Warning }{
@@ -131,11 +138,10 @@ amlnormal(w.als=1, parallel=FALSE, lexpectile = "identity",
\examples{
# Example 1
-o = with(bminz, order(age))
-bminz = bminz[o,] # Sort by age
-(fit = vglm(BMI ~ bs(age), fam=amlnormal(w.als=0.1), data=bminz))
+ooo = with(bminz, order(age))
+bminz = bminz[ooo,] # Sort by age
+(fit = vglm(BMI ~ bs(age), fam=amlnormal(w.aml=0.1), bminz))
fit at extra # Gives the w value and the percentile
-coef(fit)
coef(fit, matrix=TRUE)
\dontrun{
@@ -143,8 +149,7 @@ coef(fit, matrix=TRUE)
with(bminz, plot(age, BMI, col="blue", main=
paste(round(fit at extra$percentile, dig=1),
"expectile-percentile curve")))
-with(bminz, lines(age, c(fitted(fit)), col="black"))
-}
+with(bminz, lines(age, c(fitted(fit)), col="black")) }
@@ -157,25 +162,23 @@ findw = function(w, percentile=50) {
\dontrun{
# Quantile plot
with(bminz, plot(age, BMI, col="blue", las=1, main=
- "25, 50 and 75 expectile-percentile curves"))
-}
+ "25, 50 and 75 expectile-percentile curves")) }
for(myp in c(25,50,75)) {
# Note: uniroot() can only find one root at a time
bestw = uniroot(f=findw, interval=c(1/10^4, 10^4), percentile=myp)
fit2 = vglm(BMI ~ bs(age), fam=amlnormal(w=bestw$root), data=bminz)
\dontrun{
- with(bminz, lines(age, c(fitted(fit2)), col="red"))
-}
+ with(bminz, lines(age, c(fitted(fit2)), col="red")) }
}
# Example 3; this is Example 1 but with smoothing splines and
# a vector w and a parallelism assumption.
-o = with(bminz, order(age))
-bminz = bminz[o,] # Sort by age
+ooo = with(bminz, order(age))
+bminz = bminz[ooo,] # Sort by age
fit3 = vgam(BMI ~ s(age, df=4), fam=amlnormal(w=c(.1,1,10), parallel=TRUE),
- data=bminz, trac=TRUE)
+ bminz, trac=TRUE)
fit3 at extra # The w values, percentiles and weighted deviances
# The linear components of the fit; not for human consumption:
diff --git a/man/amlpoisson.Rd b/man/amlpoisson.Rd
index f99af01..1718a81 100644
--- a/man/amlpoisson.Rd
+++ b/man/amlpoisson.Rd
@@ -8,14 +8,11 @@
}
\usage{
-amlpoisson(w.aml=1, parallel=FALSE, method.init=1, digw=4,
- link="loge", earg=list())
+amlpoisson(w.aml = 1, parallel = FALSE, method.init = 1, digw = 4,
+ link = "loge", earg = list())
}
%- maybe also 'usage' for other objects documented here.
\arguments{
- In this documentation the word \emph{quantile} can often be
- interchangeably replaced by \emph{expectile}
- (things are informal here).
\item{w.aml}{
Numeric, a vector of positive constants controlling the percentiles.
@@ -102,9 +99,11 @@ amlpoisson(w.aml=1, parallel=FALSE, method.init=1, digw=4,
the individual deviance values corresponding to each element of the
argument \code{w.aml} is stored in the \code{extra} slot.
+
For \code{amlpoisson} objects, methods functions for the generic
functions \code{qtplot} and \code{cdf} have not been written yet.
+
About the jargon, Newey and Powell (1987) used the name
\emph{expectiles} for regression surfaces obtained by asymmetric
least squares.
@@ -118,6 +117,12 @@ amlpoisson(w.aml=1, parallel=FALSE, method.init=1, digw=4,
Poisson cases, the phrase \emph{quantile regression} is used loosely
in this \pkg{VGAM} documentation.
+
+ In this documentation the word \emph{quantile} can often be
+ interchangeably replaced by \emph{expectile}
+ (things are informal here).
+
+
}
\section{Warning }{
@@ -136,10 +141,10 @@ amlpoisson(w.aml=1, parallel=FALSE, method.init=1, digw=4,
\examples{
set.seed(1234)
-mydat = data.frame(x = sort(runif(n <- 200)))
-mydat = transform(mydat, y = rpois(n, exp(0-sin(8*x))))
+mydat = data.frame(x = sort(runif(nn <- 200)))
+mydat = transform(mydat, y = rpois(nn, exp(0-sin(8*x))))
(fit = vgam(y ~ s(x), fam=amlpoisson(w.aml=c(0.02, 0.2, 1, 5, 50)),
- data=mydat, trace=TRUE))
+ mydat, trace=TRUE))
fit at extra
\dontrun{
@@ -147,8 +152,7 @@ fit at extra
with(mydat, plot(x, jitter(y), col="blue", las=1, main=
paste(paste(round(fit at extra$percentile, dig=1), collapse=", "),
"percentile-expectile curves")))
-with(mydat, matlines(x, fitted(fit), lwd=2))
-}
+with(mydat, matlines(x, fitted(fit), lwd=2)) }
}
\keyword{models}
\keyword{regression}
diff --git a/man/auuc.Rd b/man/auuc.Rd
index 88a27eb..9af6923 100644
--- a/man/auuc.Rd
+++ b/man/auuc.Rd
@@ -22,14 +22,16 @@ Each student is cross-classified by their
colleges (Science and Engineering have been combined) and
the socio-economic status (SES) of their fathers (1 = highest,
down to 4 = lowest).
+
}
\source{
Dr Tony Morrison.
}
\references{
Wild, C. J. and Seber, G. A. F. (2000)
-\emph{Chance Encounters: A First Course in Data Analysis and Inference},
-New York: Wiley.
+ \emph{Chance Encounters: A First Course in Data Analysis and Inference},
+ New York: Wiley.
+
}
\examples{
round(fitted(grc(auuc)))
diff --git a/man/backPain.Rd b/man/backPain.Rd
new file mode 100644
index 0000000..210d03e
--- /dev/null
+++ b/man/backPain.Rd
@@ -0,0 +1,52 @@
+\name{backPain}
+\alias{backPain}
+\docType{data}
+\title{ Data on Back Pain Prognosis, from Anderson (1984) }
+\description{
+ Data from a study of patients suffering from back pain. Prognostic
+ variables were recorded at presentation and progress was categorised
+ three weeks after treatment.
+}
+\usage{data(backPain)}
+\format{
+ A data frame with 101 observations on the following 4 variables.
+ \describe{
+ \item{x1}{length of previous attack.}
+ \item{x2}{pain change.}
+ \item{x3}{lordosis.}
+ \item{pain}{an ordered factor describing the progress of each
+ patient with levels \code{worse} < \code{same} <
+ \code{slight.improvement} < \code{moderate.improvement} <
+ \code{marked.improvement} < \code{complete.relief}. }
+ }
+}
+\source{
+ \url{http://ideas.repec.org/c/boc/bocode/s419001.html}
+
+ The data set and this help file was copied from \pkg{gnm}
+ so that a vignette in \pkg{VGAM} could be run; the analysis is
+ described in Yee (2010).
+
+
+}
+\references{
+ Anderson, J. A. (1984) Regression and Ordered Categorical
+ Variables. \emph{J. R. Statist. Soc. B}, \bold{46(1)}, 1-30.
+
+Yee, T. W. (2010)
+The \pkg{VGAM} package for categorical data analysis.
+\emph{Journal of Statistical Software},
+\bold{32}, 1--34.
+\url{http://www.jstatsoft.org/v32/i10/}.
+
+}
+\examples{
+summary(backPain)
+}
+\keyword{datasets}
+% set.seed(1)
+% data(backPain)
+
+
+
+
diff --git a/man/benfUC.Rd b/man/benfUC.Rd
index cecfea3..9448b5e 100644
--- a/man/benfUC.Rd
+++ b/man/benfUC.Rd
@@ -107,24 +107,21 @@ Note on the Frequency of Use of the Different Digits in Natural Numbers.
% \code{\link{logff}}.
%}
\examples{
-x = c(0:10, NA, NaN, -Inf, Inf)
-dbenf(x)
+dbenf(x <- c(0:10, NA, NaN, -Inf, Inf))
pbenf(x)
\dontrun{
-x = 1:9; # par(mfrow=c(2,1))
-barplot(dbenf(x), col = "lightblue", las=1, xlab="Leading digit",
- ylab = "Probability",
- main=paste("Benford's distribution", sep=""),
- names.arg = as.character(x))
+xx = 1:9; # par(mfrow=c(2,1))
+barplot(dbenf(xx), col = "lightblue", las=1, xlab="Leading digit",
+ ylab = "Probability", names.arg = as.character(xx),
+ main=paste("Benford's distribution", sep=""))
hist(rbenf(n=1000), border = "blue", prob=TRUE,
- main="Random variates from Benford's distribution",
- xlab="Leading digit",
- sub="Red is the true probability",
+ main="1000 random variates from Benford's distribution",
+ xlab="Leading digit", sub="Red is the true probability",
breaks=0:9+0.5, ylim=c(0, 0.35), xlim=c(0, 10.0))
-lines(1:9, dbenf(1:9), col="red", type="h")
-points(1:9, dbenf(1:9), col="red")
+lines(xx, dbenf(xx), col="red", type="h")
+points(xx, dbenf(xx), col="red")
}
}
\keyword{distribution}
diff --git a/man/benini.Rd b/man/benini.Rd
index e9e6d9d..9cce164 100644
--- a/man/benini.Rd
+++ b/man/benini.Rd
@@ -85,15 +85,15 @@ Hoboken, NJ: Wiley-Interscience.
\code{\link{Benini}}.
}
\examples{
-y = rbenini(n <- 3000, y0=1, shape=exp(2))
-fit = vglm(y ~ 1, benini(y0=1), trace=TRUE, crit="c")
+y0 = 1
+bdata = data.frame(y = rbenini(n=3000, y0=y0, shape=exp(2)))
+fit = vglm(y ~ 1, benini(y0=y0), bdata, trace=TRUE, crit="c")
coef(fit, matrix=TRUE)
Coef(fit)
fit at extra$y0
-# Apparent discrepancy:
-head(fitted(fit))
-mean(y)
+head(fitted(fit), 1) # Apparent discrepancy:
+with(bdata, mean(y))
}
\keyword{models}
\keyword{regression}
diff --git a/man/beniniUC.Rd b/man/beniniUC.Rd
index 57eab08..3a17a43 100644
--- a/man/beniniUC.Rd
+++ b/man/beniniUC.Rd
@@ -57,15 +57,14 @@ Hoboken, NJ: Wiley-Interscience.
}
\examples{
\dontrun{
-y0 = 1
-shape = exp(1)
-x = seq(-0.0, 4, len=101)
-plot(x, dbenini(x, y0=y0,shape=shape), type="l", col="blue", las=1,
+y0 = 1; shape = exp(1)
+xx = seq(0.0, 4, len=101)
+plot(xx, dbenini(xx, y0=y0,shape=shape), type="l", col="blue", las=1,
main="Blue is density, red is cumulative distribution function",
sub="Purple lines are the 10,20,...,90 percentiles", ylim=0:1,
- ylab="")
+ ylab="", xlab="x")
abline(h=0, col="blue", lty=2)
-lines(x, pbenini(x, y0=y0,shape=shape), col="red")
+lines(xx, pbenini(xx, y0=y0,shape=shape), col="red")
probs = seq(0.1, 0.9, by=0.1)
Q = qbenini(probs, y0=y0,shape=shape)
lines(Q, dbenini(Q, y0=y0,shape=shape), col="purple", lty=3, type="h")
diff --git a/man/beta.ab.Rd b/man/beta.ab.Rd
index 6b907d9..994b7d4 100644
--- a/man/beta.ab.Rd
+++ b/man/beta.ab.Rd
@@ -95,7 +95,7 @@ beta.ab(lshape1="loge", lshape2="loge",
Gupta, A. K. and Nadarajah, S. (2004)
\emph{Handbook of Beta Distribution and Its Applications},
- NY: Marcel Dekker, Inc.
+ New York: Marcel Dekker.
%Evans, M., Hastings, N. and Peacock, B. (2000)
%\emph{Statistical Distributions},
@@ -128,17 +128,17 @@ beta.ab(lshape1="loge", lshape2="loge",
}
\examples{
-y = rbeta(n=1000, shape1=exp(0), shape2=exp(1))
+betadat = data.frame(y = rbeta(n=1000, shape1=exp(0), shape2=exp(1)))
fit = vglm(y ~ 1, beta.ab(lshape1="identity", lshape2="identity"),
- trace = TRUE, crit="c")
-fit = vglm(y ~ 1, beta.ab, trace = TRUE, crit="c")
+ data=betadat, trace=TRUE, crit="c")
+fit = vglm(y ~ 1, beta.ab, data=betadat, trace=TRUE, crit="c")
coef(fit, matrix=TRUE)
Coef(fit) # Useful for intercept-only models
-Y = 5 + 8 * y # From 5 to 13, not 0 to 1
-fit = vglm(Y ~ 1, beta.ab(A=5, B=13), trace = TRUE)
-Coef(fit)
-c(mean(Y), head(fitted(fit)))
+betadat = transform(betadat, Y = 5 + 8 * y) # From 5 to 13, not 0 to 1
+fit = vglm(Y ~ 1, beta.ab(A=5, B=13), data=betadat, trace=TRUE)
+Coef(fit)
+c(meanY=with(betadat, mean(Y)), head(fitted(fit),2))
}
\keyword{models}
\keyword{regression}
diff --git a/man/betaII.Rd b/man/betaII.Rd
index 5831eda..af108cd 100644
--- a/man/betaII.Rd
+++ b/man/betaII.Rd
@@ -89,9 +89,9 @@ Hoboken, NJ: Wiley-Interscience.
}
\examples{
-y = rsinmad(n=2000, a=1, 6, 2) # Not genuine data!
-fit = vglm(y ~ 1, betaII, trace=TRUE)
-fit = vglm(y ~ 1, betaII(init.p=0.7, init.q=0.7), trace=TRUE, crit="c")
+bdata = data.frame(y = rsinmad(n=2000, a=1, 6, 2)) # Not genuine data!
+fit = vglm(y ~ 1, betaII, bdata, trace=TRUE)
+fit = vglm(y ~ 1, betaII(init.p=0.7, init.q=0.7), bdata, trace=TRUE, crit="c")
coef(fit, mat=TRUE)
Coef(fit)
summary(fit)
diff --git a/man/betabin.ab.Rd b/man/betabin.ab.Rd
index dcb4b93..ed51062 100644
--- a/man/betabin.ab.Rd
+++ b/man/betabin.ab.Rd
@@ -9,9 +9,8 @@
}
\usage{
-betabin.ab(lshape12 = "loge", earg = list(),
- i1 = 1, i2 = NULL, method.init=1,
- shrinkage.init=0.95, nsimEIM=NULL, zero=NULL)
+betabin.ab(lshape12 = "loge", earg = list(), i1 = 1, i2 = NULL,
+ method.init=1, shrinkage.init=0.95, nsimEIM=NULL, zero=NULL)
}
%- maybe also 'usage' for other objects documented here.
\arguments{
@@ -190,7 +189,7 @@ t(fit at y)
t(weights(fit, type="prior"))
# A "loge" link for the 2 shape parameters is a logistic regression:
all.equal(c(fitted(fit)),
-c(logit(predict(fit)[,1] - predict(fit)[,2], inverse=TRUE)))
+ c(logit(predict(fit)[,1] - predict(fit)[,2], inverse=TRUE)))
# Example 3, which is more complicated
@@ -216,8 +215,8 @@ smalldf = with(lirat, lirat[N>1,])
for(gp in 1:4) {
xx = with(smalldf, hb[grp==gp])
yy = with(smalldf, fitted(fit2)[grp==gp])
- o = order(xx)
- lines(xx[o], yy[o], col=gp)
+ ooo = order(xx)
+ lines(xx[ooo], yy[ooo], col=gp)
}
}
}
diff --git a/man/betabinUC.Rd b/man/betabinUC.Rd
index f498b19..52f8e26 100644
--- a/man/betabinUC.Rd
+++ b/man/betabinUC.Rd
@@ -90,17 +90,17 @@ rbetabin.ab(n, size, shape1, shape2)
}
\examples{
\dontrun{
-N = 9; x = 0:N; s1=2; s2=3
-dy = dbetabin.ab(x, size=N, shape1=s1, shape2=s2)
-barplot(rbind(dy, dbinom(x, size=N, prob=s1/(s1+s2))),
+N = 9; xx = 0:N; s1=2; s2=3
+dy = dbetabin.ab(xx, size=N, shape1=s1, shape2=s2)
+barplot(rbind(dy, dbinom(xx, size=N, prob=s1/(s1+s2))),
beside = TRUE, col = c("blue","green"), las=1,
main=paste("Beta-binomial (size=",N,", shape1=",s1,
", shape2=",s2,") (blue) vs\n",
" Binomial(size=", N, ", prob=", s1/(s1+s2), ") (green)", sep=""),
- names.arg = as.character(x), cex.main=0.8)
-sum(dy*x) # Check expected values are equal
-sum(dbinom(x, size=N, prob=s1/(s1+s2))*x)
-cumsum(dy) - pbetabin.ab(x, N, shape1=s1, shape2=s2)
+ names.arg = as.character(xx), cex.main=0.8)
+sum(dy*xx) # Check expected values are equal
+sum(dbinom(xx, size=N, prob=s1/(s1+s2))*xx)
+cumsum(dy) - pbetabin.ab(xx, N, shape1=s1, shape2=s2)
y = rbetabin.ab(n=10000, size=N, shape1=s1, shape2=s2)
ty = table(y)
@@ -110,7 +110,7 @@ barplot(rbind(dy, ty/sum(ty)),
", shape2=",s2,") (blue) vs\n",
" Random generated beta-binomial(size=", N, ", prob=", s1/(s1+s2),
") (red)", sep=""), cex.main=0.8,
- names.arg = as.character(x))
+ names.arg = as.character(xx))
}
}
\keyword{distribution}
diff --git a/man/betabinomial.Rd b/man/betabinomial.Rd
index deb2836..b2ac5f9 100644
--- a/man/betabinomial.Rd
+++ b/man/betabinomial.Rd
@@ -8,9 +8,8 @@
}
\usage{
-betabinomial(lmu="logit", lrho="logit", emu=list(), erho=list(),
- irho=NULL, method.init=1, shrinkage.init=0.95,
- nsimEIM=NULL, zero=2)
+betabinomial(lmu="logit", lrho="logit", emu=list(), erho=list(), irho=NULL,
+ method.init=1, shrinkage.init=0.95, nsimEIM=NULL, zero=2)
}
%- maybe also 'usage' for other objects documented here.
\arguments{
@@ -177,17 +176,17 @@ betabinomial(lmu="logit", lrho="logit", emu=list(), erho=list(),
}
\examples{
# Example 1
-N = 10; mu = 0.5; rho = 0.8
-y = rbetabin(n=100, size=N, prob=mu, rho=rho)
-fit = vglm(cbind(y,N-y) ~ 1, betabinomial, trace=TRUE)
+betabindat = data.frame(N = 10, mu = 0.5, rho = 0.8)
+betabindat = transform(betabindat,
+ y = rbetabin(n=100, size=N, prob=mu, rho=rho))
+fit = vglm(cbind(y,N-y) ~ 1, betabinomial, betabindat, trace=TRUE)
coef(fit, matrix=TRUE)
Coef(fit)
head(cbind(fit at y, weights(fit, type="prior")))
# Example 2
-fit = vglm(cbind(R,N-R) ~ 1, betabinomial, data=lirat,
- trace=TRUE, subset=N>1)
+fit = vglm(cbind(R,N-R)~1, betabinomial, lirat, trace=TRUE, subset=N>1)
coef(fit, matrix=TRUE)
Coef(fit)
t(fitted(fit))
@@ -215,8 +214,8 @@ smalldf = with(lirat, lirat[N>1,])
for(gp in 1:4) {
xx = with(smalldf, hb[grp==gp])
yy = with(smalldf, fitted(fit2)[grp==gp])
- o = order(xx)
- lines(xx[o], yy[o], col=gp)
+ ooo = order(xx)
+ lines(xx[ooo], yy[ooo], col=gp)
}
}
}
diff --git a/man/betaff.Rd b/man/betaff.Rd
index a25e703..ae58016 100644
--- a/man/betaff.Rd
+++ b/man/betaff.Rd
@@ -116,20 +116,20 @@ betaff(A=0, B=1,
}
\examples{
-y = rbeta(n <- 1000, shape1=exp(0), shape2=exp(1))
-fit = vglm(y ~ 1, betaff, trace = TRUE)
+betadat = data.frame(y = rbeta(nn <- 1000, shape1=exp(0), shape2=exp(1)))
+fit = vglm(y ~ 1, betaff, betadat, trace=TRUE)
coef(fit, matrix=TRUE)
Coef(fit) # Useful for intercept-only models
# General A and B, and with a covariate
-x = runif(n <- 1000)
-mu = logit(0.5-x, inverse=TRUE)
-prec = exp(3+x) # phi
-shape2 = prec * (1-mu)
-shape1 = mu * prec
-y = rbeta(n, shape1=shape1, shape2=shape2)
-Y = 5 + 8 * y # From 5 to 13, not 0 to 1
-fit = vglm(Y ~ x, betaff(A=5,B=13), trace=TRUE)
+betadat = transform(betadat, x = runif(nn))
+betadat = transform(betadat, mu = logit(0.5-x, inverse=TRUE),
+ prec = exp(3+x)) # prec == phi
+betadat = transform(betadat, shape2 = prec * (1-mu),
+ shape1 = mu * prec)
+betadat = transform(betadat, y = rbeta(nn, shape1=shape1, shape2=shape2))
+betadat = transform(betadat, Y = 5 + 8 * y) # From 5 to 13, not 0 to 1
+fit = vglm(Y ~ x, betaff(A=5, B=13), betadat, trace=TRUE)
coef(fit, mat=TRUE)
}
\keyword{models}
diff --git a/man/betageomUC.Rd b/man/betageomUC.Rd
index 52dcbb0..879c601 100644
--- a/man/betageomUC.Rd
+++ b/man/betageomUC.Rd
@@ -65,9 +65,8 @@ rbetageom(n, shape1, shape2)
\dontrun{
shape1 = 1; shape2 = 2; y = 0:30
proby = dbetageom(y, shape1, shape2, log=FALSE)
-plot(y, proby, type="h", col="blue", ylab="P[Y=y]",
- main=paste("Y ~ Beta-geometric(shape1=",shape1,", shape2=",shape2,")",
- sep=""))
+plot(y, proby, type="h", col="blue", ylab="P[Y=y]", main=paste(
+ "Y ~ Beta-geometric(shape1=",shape1,", shape2=",shape2,")", sep=""))
sum(proby)
}
}
diff --git a/man/betageometric.Rd b/man/betageometric.Rd
index bd40af9..9e3d37f 100644
--- a/man/betageometric.Rd
+++ b/man/betageometric.Rd
@@ -7,9 +7,9 @@
}
\usage{
-betageometric(lprob="logit", lshape="loge",
- eprob=list(), eshape=list(),
- iprob = NULL, ishape = 0.1,
+betageometric(lprob = "logit", lshape = "loge",
+ eprob = list(), eshape = list(),
+ iprob = NULL, ishape = 0.1,
moreSummation=c(2,100), tolerance=1.0e-10, zero=NULL)
}
%- maybe also 'usage' for other objects documented here.
@@ -113,16 +113,16 @@ betageometric(lprob="logit", lshape="loge",
}
\examples{
-y = 0:11; wts = c(227,123,72,42,21,31,11,14,6,4,7,28)
-fit = vglm(y ~ 1, fam=betageometric, weight=wts, trace=TRUE)
-fitg = vglm(y ~ 1, fam= geometric, weight=wts, trace=TRUE)
+bg.data = data.frame(y = 0:11, wts = c(227,123,72,42,21,31,11,14,6,4,7,28))
+fit = vglm(y ~ 1, fam=betageometric, bg.data, weight=wts, trace=TRUE)
+fitg = vglm(y ~ 1, fam= geometric, bg.data, weight=wts, trace=TRUE)
coef(fit, matrix=TRUE)
Coef(fit)
diag(vcov(fit, untrans=TRUE))^0.5
fit at misc$shape1
fit at misc$shape2
# Very strong evidence of a beta-geometric:
-1-pchisq(2*(logLik(fit)-logLik(fitg)), df=1)
+pchisq(2*(logLik(fit)-logLik(fitg)), df=1, lower.tail=FALSE)
}
\keyword{models}
\keyword{regression}
diff --git a/man/betanormUC.Rd b/man/betanormUC.Rd
index b0fcc4c..1feb3b8 100644
--- a/man/betanormUC.Rd
+++ b/man/betanormUC.Rd
@@ -22,14 +22,15 @@ rbetanorm(n, shape1, shape2, mean=0, sd=1)
\item{n}{number of observations.
Must be a positive integer of length 1.}
\item{shape1, shape2}{
- the two (positive) shape parameters of the standard
- beta distribution. They are called \code{a} and \code{b} in
+ the two (positive) shape parameters of the standard beta distribution.
+ They are called \code{a} and \code{b} respectively in
\code{\link[base:Special]{beta}}.
}
\item{mean, sd}{
the mean and standard deviation of the univariate
- normal distribution.
+ normal distribution
+ (\code{\link[stats:Normal]{Normal}}).
}
\item{log, log.p}{
@@ -38,16 +39,28 @@ rbetanorm(n, shape1, shape2, mean=0, sd=1)
}
\item{lower.tail}{
- Logical. If \code{TRUE} then the upper tail is returned, i.e., one minus
- the usual answer.
+ Logical. If \code{TRUE} then the upper tail is returned, i.e.,
+ one minus the usual answer.
}
+
}
\value{
\code{dbetanorm} gives the density,
\code{pbetanorm} gives the distribution function,
\code{qbetanorm} gives the quantile function, and
\code{rbetanorm} generates random deviates.
+
+}
+\references{
+
+
+ pp.146--152 of
+ Gupta, A. K. and Nadarajah, S. (2004)
+ \emph{Handbook of Beta Distribution and Its Applications},
+ New York: Marcel Dekker.
+
+
}
\author{ T. W. Yee }
\details{
@@ -74,8 +87,7 @@ lines(x, pbetanorm(x, shape1, shape2, m=m), col="red")
abline(h=0)
probs = seq(0.1, 0.9, by=0.1)
Q = qbetanorm(probs, shape1, shape2, m=m)
-lines(Q, dbetanorm(Q, shape1, shape2, m=m), col="purple",
- lty=3, type="h")
+lines(Q, dbetanorm(Q, shape1, shape2, m=m), col="purple", lty=3, type="h")
lines(Q, pbetanorm(Q, shape1, shape2, m=m), col="purple", lty=3, type="h")
abline(h=probs, col="purple", lty=3)
pbetanorm(Q, shape1, shape2, m=m) - probs # Should be all 0
diff --git a/man/betaprime.Rd b/man/betaprime.Rd
index 799e8b4..d9a3d3a 100644
--- a/man/betaprime.Rd
+++ b/man/betaprime.Rd
@@ -94,24 +94,26 @@ contains further information and examples.
\seealso{
\code{\link{betaff}}.
+
}
\examples{
-yb = rbeta(n <- 1000, shape1=exp(1), shape2=exp(3))
-y1 = (1-yb)/yb
-y2 = yb/(1-yb)
-y3 = rgamma(n, exp(3)) / rgamma(n, exp(2))
+nn = 1000
+betadat = data.frame(shape1 = exp(1), shape2 = exp(3))
+betadat = transform(betadat, yb = rbeta(nn, shape1, shape2))
+betadat = transform(betadat, y1 = (1-yb)/yb, y2 = yb/(1-yb),
+ y3 = rgamma(nn, exp(3)) / rgamma(nn, exp(2)))
-fit1 = vglm(y1 ~ 1, betaprime, trace=TRUE)
+fit1 = vglm(y1 ~ 1, betaprime, betadat, trace=TRUE)
coef(fit1, matrix=TRUE)
-fit2 = vglm(y2 ~ 1, betaprime, trace=TRUE)
+fit2 = vglm(y2 ~ 1, betaprime, betadat, trace=TRUE)
coef(fit2, matrix=TRUE)
-fit3 = vglm(y3 ~ 1, betaprime, trace=TRUE)
+fit3 = vglm(y3 ~ 1, betaprime, betadat, trace=TRUE)
coef(fit3, matrix=TRUE)
# Compare the fitted values
-mean(y3)
+with(betadat, mean(y3))
head(fitted(fit3))
Coef(fit3) # Useful for intercept-only models
}
diff --git a/man/binom2.or.Rd b/man/binom2.or.Rd
index e9e57f5..29b9c3e 100644
--- a/man/binom2.or.Rd
+++ b/man/binom2.or.Rd
@@ -12,8 +12,8 @@
\usage{
binom2.or(lmu = "logit", lmu1 = lmu, lmu2 = lmu, loratio = "loge",
emu=list(), emu1=emu, emu2=emu, eoratio=list(),
- imu1=NULL, imu2=NULL, ioratio = NULL,
- zero = 3, exchangeable = FALSE, tol = 0.001, morerobust=FALSE)
+ imu1=NULL, imu2=NULL, ioratio = NULL, zero = 3,
+ exchangeable = FALSE, tol = 0.001, morerobust=FALSE)
}
%- maybe also 'usage' for other objects documented here.
\arguments{
@@ -83,10 +83,10 @@ binom2.or(lmu = "logit", lmu1 = lmu, lmu2 = lmu, loratio = "loge",
equal 1 for a success and a 0 for a failure, and the odds ratio is often
written \eqn{\psi=p_{00}p_{11}/(p_{10}p_{01})}{psi=p00 p11 / (p10 p01)}.
The model is fitted by maximum likelihood estimation since the full
- likelihood is specified. The two binary responses are independent
- if and only if the odds ratio is unity, or equivalently, the log odds
- ratio is zero.
- Fisher scoring is implemented.
+ likelihood is specified.
+ The two binary responses are independent if and only if the odds ratio
+ is unity, or equivalently, the log odds ratio is zero. Fisher scoring
+ is implemented.
The default models \eqn{\eta_3}{eta3} as a single parameter only,
i.e., an intercept-only model, but this can be circumvented by setting
@@ -143,11 +143,13 @@ binom2.or(lmu = "logit", lmu1 = lmu, lmu2 = lmu, loratio = "loge",
}
\author{ Thomas W. Yee }
\note{
- The response should be either a 4-column matrix of counts (whose
- columns correspond to \eqn{(Y_1,Y_2)}{(Y1,Y2)} = (0,0), (0,1), (1,0),
+ The response should be either a 4-column matrix of counts
+ (whose columns correspond to \eqn{(Y_1,Y_2)}{(Y1,Y2)} = (0,0), (0,1), (1,0),
(1,1) respectively), or a two-column matrix where each column has two
distinct values.
The function \code{\link{rbinom2.or}} may be used to generate such data.
+ Successful convergence requires at least one case of each of the four
+ possible outcomes.
By default, a constant odds ratio is fitted because \code{zero=3}.
Set \code{zero=NULL} if you want the odds ratio to be modelled as a
@@ -189,7 +191,6 @@ fit = vglm(cbind(nBnW,nBW,BnW,BW) ~ Age, binom2.or(zero=NULL), coalminers)
fitted(fit)
summary(fit)
coef(fit, matrix=TRUE)
-
c(weights(fit, type="prior")) * fitted(fit) # Table 6.8
\dontrun{
diff --git a/man/binom2.orUC.Rd b/man/binom2.orUC.Rd
index 416c6c4..3dda3e4 100644
--- a/man/binom2.orUC.Rd
+++ b/man/binom2.orUC.Rd
@@ -18,8 +18,7 @@ rbinom2.or(n, mu1,
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)
+ colnames=c("00", "01", "10", "11"), ErrorCheck=TRUE)
}
%- maybe also 'usage' for other objects documented here.
@@ -100,7 +99,7 @@ dbinom2.or(mu1,
# Example 1
nn = 2000
ymat = rbinom2.or(n=nn, mu1=0.8, oratio=exp(2), exch=TRUE)
-(mytab = table(ymat[,1], ymat[,2]))
+(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)
diff --git a/man/binom2.rho.Rd b/man/binom2.rho.Rd
index 4edb6b2..50efcb4 100644
--- a/man/binom2.rho.Rd
+++ b/man/binom2.rho.Rd
@@ -8,9 +8,8 @@
}
\usage{
-binom2.rho(lrho = "rhobit", erho=list(),
- imu1 = NULL, imu2 = NULL, init.rho = NULL,
- zero = 3, exchangeable = FALSE, nsimEIM=NULL)
+binom2.rho(lrho = "rhobit", erho=list(), imu1 = NULL, imu2 = NULL,
+ init.rho = NULL, zero = 3, exchangeable = FALSE, nsimEIM=NULL)
}
%- maybe also 'usage' for other objects documented here.
\arguments{
@@ -131,8 +130,7 @@ contains further information and examples.
}
\examples{
coalminers = transform(coalminers, Age = (age - 42) / 5)
-fit = vglm(cbind(nBnW,nBW,BnW,BW) ~ Age, binom2.rho,
- data=coalminers, trace=TRUE)
+fit = vglm(cbind(nBnW,nBW,BnW,BW) ~ Age, binom2.rho, coalminers, trace=TRUE)
summary(fit)
coef(fit, matrix=TRUE)
}
diff --git a/man/binom2.rhoUC.Rd b/man/binom2.rhoUC.Rd
index be441fb..451bedb 100644
--- a/man/binom2.rhoUC.Rd
+++ b/man/binom2.rhoUC.Rd
@@ -95,7 +95,7 @@ dbinom2.rho(mu1,
nn = 2000
(myrho <- rhobit(2, inverse=TRUE))
ymat = rbinom2.rho(n=nn, mu1=0.8, rho=myrho, exch=TRUE)
-(mytab <- table(ymat[,1], ymat[,2]))
+(mytab = table(ymat[,1], ymat[,2], dnn=c("Y1","Y2")))
fit = vglm(ymat ~ 1, binom2.rho(exch=TRUE))
coef(fit, matrix=TRUE)
diff --git a/man/binomialff.Rd b/man/binomialff.Rd
index a1ab703..aed765f 100644
--- a/man/binomialff.Rd
+++ b/man/binomialff.Rd
@@ -9,15 +9,12 @@
}
\usage{
-binomialff(link = "logit", earg = list(),
- dispersion = 1, mv = FALSE, onedpar = !mv,
- parallel = FALSE, zero = NULL)
+binomialff(link = "logit", earg = list(), dispersion = 1, mv = FALSE,
+ onedpar = !mv, parallel = FALSE, zero = NULL)
}
%- maybe also 'usage' for other objects documented here.
\arguments{
- The notation \eqn{M} is used to denote the number of linear/additive
- predictors.
\item{link}{
Link function. See \code{\link{Links}} for more choices.
@@ -104,6 +101,10 @@ binomialff(link = "logit", earg = list(),
\emph{Numerical Issues in Statistical Computing for the Social
Scientist}, Hoboken, NJ: Wiley-Interscience.
+ Ridout, M. S. (1990)
+ Non-convergence of Fisher's method of scoring---a simple example.
+ \emph{GLIM Newsletter}, 20(6).
+
}
\author{ Thomas W. Yee }
@@ -116,6 +117,9 @@ binomialff(link = "logit", earg = list(),
you will need to specify \code{weights} because the number of trials
is needed.
+ The notation \eqn{M} is used to denote the number of linear/additive
+ predictors.
+
If \code{mv} is \code{TRUE}, then the matrix response can only be of
one format: a matrix of 1's and 0's (1=success).
@@ -131,6 +135,9 @@ binomialff(link = "logit", earg = list(),
% With the introduction of name spaces for the \pkg{VGAM} package,
% \code{"ff"} can be dropped for this family function.
+ Fisher scoring is used. This can sometimes fail to converge by oscillating between
+ successive iterations (Ridout, 1990). See the example below.
+
}
\seealso{
\code{\link{quasibinomialff}},
@@ -144,7 +151,8 @@ binomialff(link = "logit", earg = list(),
\code{\link{mbinomial}},
\code{\link{seq2binomial}},
\code{\link{amlbinomial}},
- \code{\link[stats:Binomial]{binomial}}.
+ \code{\link[stats:Binomial]{binomial}},
+ \pkg{safeBinaryRegression}.
}
\section{Warning }{
@@ -154,7 +162,8 @@ binomialff(link = "logit", earg = list(),
The maximum likelihood estimate will not exist if the data is
\emph{completely separable} or \emph{quasi-completely separable}.
- See Chapter 10 of Altman et al. (2004) for more details.
+ See Chapter 10 of Altman et al. (2004) for more details,
+ and \pkg{safeBinaryRegression}.
Yet to do: add a \code{sepcheck=TRUE}, say, argument to detect this
problem and give an appropriate warning.
@@ -168,9 +177,21 @@ fit = vgam(agaaus ~ poly(altitude, 2), binomialff(link=cloglog), hunua)
\dontrun{
with(hunua, plot(altitude, agaaus, col="blue", ylab="P(agaaus=1)",
main="Presence/absence of Agathis australis", las=1))
-o = with(hunua, order(altitude))
-with(hunua, lines(altitude[o], fitted(fit)[o], col="red", lwd=2))
-}
+ooo = with(hunua, order(altitude))
+with(hunua, lines(altitude[ooo], fitted(fit)[ooo], col="red", lwd=2)) }
+
+
+# Shows that Fisher scoring can sometime fail. See Ridout (1990).
+ridout = data.frame(v = c(1000, 100, 10), r = c(4, 3, 3), n = c(5, 5, 5))
+(ridout = transform(ridout, logv = log(v)))
+# The iterations oscillates between two local solutions:
+glm.fail = glm(r/n ~ offset(logv) + 1, weight=n,
+ binomial(link=cloglog), ridout, trace=TRUE)
+coef(glm.fail)
+# vglm()'s half-stepping ensures the MLE of -5.4007 is obtained:
+vglm.ok = vglm(r/n ~ offset(logv) + 1, weight=n,
+ binomialff(link=cloglog), ridout, trace=TRUE)
+coef(vglm.ok)
}
\keyword{models}
\keyword{regression}
diff --git a/man/bisa.Rd b/man/bisa.Rd
index 51ea7b7..c6b15b1 100644
--- a/man/bisa.Rd
+++ b/man/bisa.Rd
@@ -118,20 +118,23 @@ New York: Wiley.
}
\examples{
-x = runif(n <- 1000)
-y = rbisa(n, shape=exp(-0.5+x), scale=exp(1.5))
-fit = vglm(y ~ x, bisa(zero=2), trace=TRUE)
+nn <- 1000
+bisa1dat = data.frame(x = runif(nn))
+bisa1dat = transform(bisa1dat, shape=exp(-0.5+x), scale=exp(1.5))
+bisa1dat = transform(bisa1dat, y = rbisa(nn, shape, scale))
+fit = vglm(y ~ x, bisa(zero=2), bisa1dat, trace=TRUE)
coef(fit, matrix=TRUE)
\dontrun{
-y = rbisa(n=1000, shape=exp(-0.5), scale=exp(0.5))
-fit = vglm(y ~ 1, bisa, trace=TRUE)
-hist(y, prob=TRUE, ylim=c(0,0.5), col="lightblue")
+bisa2dat = data.frame(shape=exp(-0.5), scale=exp(0.5))
+bisa2dat = transform(bisa2dat, y = rbisa(nn, shape, scale))
+fit = vglm(y ~ 1, bisa, bisa2dat, trace=TRUE)
+with(bisa2dat, hist(y, prob=TRUE, ylim=c(0,0.5), col="lightblue"))
coef(fit, matrix=TRUE)
-mean(y)
+with(bisa2dat, mean(y))
head(fitted(fit))
-x = seq(0, max(y), len=200)
-lines(x, dbisa(x, Coef(fit)[1], Coef(fit)[2]), col="red", lwd=2)
+x = with(bisa2dat, seq(0, max(y), len=200))
+with(bisa2dat, lines(x, dbisa(x, Coef(fit)[1], Coef(fit)[2]), col="red", lwd=2))
}
}
\keyword{models}
diff --git a/man/borel.tanner.Rd b/man/borel.tanner.Rd
index 63bef95..9d13672 100644
--- a/man/borel.tanner.Rd
+++ b/man/borel.tanner.Rd
@@ -102,8 +102,8 @@ Boston: Birkhauser.
}
\examples{
-y = rbort(n <- 200)
-fit = vglm(y ~ 1, borel.tanner, trace=TRUE, crit="c")
+bortdata = data.frame(y = rbort(n <- 200))
+fit = vglm(y ~ 1, borel.tanner, bortdata, trace=TRUE, crit="c")
coef(fit, matrix=TRUE)
Coef(fit)
summary(fit)
diff --git a/man/brat.Rd b/man/brat.Rd
index bcf5588..02813bc 100644
--- a/man/brat.Rd
+++ b/man/brat.Rd
@@ -5,6 +5,7 @@
\description{
Fits a Bradley Terry model (intercept-only model) by maximum
likelihood estimation.
+
}
\usage{
brat(refgp = "last", refvalue = 1, init.alpha = 1)
@@ -18,35 +19,34 @@ brat(refgp = "last", refvalue = 1, init.alpha = 1)
}
\item{refvalue}{ Numeric. A positive value for the reference group. }
\item{init.alpha}{ Initial values for the \eqn{\alpha}{alpha}s.
- These are recycled to the appropriate length. }
+ These are recycled to the appropriate length.
+ }
+
}
\details{
- The Bradley Terry model involves \eqn{M+1} competitors who either
-win or lose against each other (no draws/ties allowed in this
-implementation--see \code{\link{bratt}} if there are ties).
-The probability that Competitor \eqn{i} beats Competitor \eqn{j} is
-\eqn{\alpha_i / (\alpha_i+\alpha_j)}{alpha_i / (alpha_i + alpha_j)},
-where all the \eqn{\alpha}{alpha}s are positive.
-Loosely, the \eqn{\alpha}{alpha}s can be thought of as the
-competitors' `abilities'.
-For identifiability, one of the \eqn{\alpha_i}{alpha_i} is set to a
-known value \code{refvalue}, e.g., 1.
-By default, this function chooses the last competitor to
-have this reference value.
-The data can be represented in the form of a
-\eqn{M+1} by \eqn{M+1} matrix of counts,
-where winners are the rows and losers are the columns.
-However, this is not the way the data should be inputted (see below).
+ The Bradley Terry model involves \eqn{M+1} competitors who
+ either win or lose against each other (no draws/ties allowed in
+ this implementation--see \code{\link{bratt}} if there are ties).
+ The probability that Competitor \eqn{i} beats Competitor \eqn{j}
+ is \eqn{\alpha_i / (\alpha_i+\alpha_j)}{alpha_i / (alpha_i +
+ alpha_j)}, where all the \eqn{\alpha}{alpha}s are positive. Loosely,
+ the \eqn{\alpha}{alpha}s can be thought of as the competitors'
+ `abilities'. For identifiability, one of the \eqn{\alpha_i}{alpha_i}
+ is set to a known value \code{refvalue}, e.g., 1. By default, this
+ function chooses the last competitor to have this reference value.
+ The data can be represented in the form of a \eqn{M+1} by \eqn{M+1}
+ matrix of counts, where winners are the rows and losers are the columns.
+ However, this is not the way the data should be inputted (see below).
-Excluding the reference value/group, this function chooses
-\eqn{\log(\alpha_j)}{log(alpha_j)} as the \eqn{M} linear predictors.
-The log link ensures that the \eqn{\alpha}{alpha}s are positive.
+ Excluding the reference value/group, this function chooses
+ \eqn{\log(\alpha_j)}{log(alpha_j)} as the \eqn{M} linear predictors.
+ The log link ensures that the \eqn{\alpha}{alpha}s are positive.
-The Bradley Terry model can be fitted by logistic regression, but this
-approach is not taken here. The Bradley Terry model can be fitted
-with covariates, e.g., a home advantage variable, but unfortunately,
-this lies outside the VGLM theoretical framework and therefore cannot
-be handled with this code.
+ The Bradley Terry model can be fitted by logistic regression, but this
+ approach is not taken here. The Bradley Terry model can be fitted
+ with covariates, e.g., a home advantage variable, but unfortunately,
+ this lies outside the VGLM theoretical framework and therefore cannot
+ be handled with this code.
}
\value{
@@ -68,33 +68,31 @@ than this function.
}
\author{ T. W. Yee }
\note{
-The function \code{\link{Brat}} is useful for coercing a \eqn{M+1}
-by \eqn{M+1} matrix of counts into a one-row matrix suitable for
-\code{brat}.
-Diagonal elements are skipped, and the usual S order of \code{c(a.matrix)}
-of elements is used. There should be no missing
-values apart from the diagonal elements of the square matrix.
-The matrix should have winners as the rows, and losers
-as the columns.
-In general, the response should be a 1-row matrix with \eqn{M(M+1)} columns.
+ The function \code{\link{Brat}} is useful for coercing a \eqn{M+1}
+ by \eqn{M+1} matrix of counts into a one-row matrix suitable
+ for \code{brat}. Diagonal elements are skipped, and the usual S
+ order of \code{c(a.matrix)} of elements is used. There should be no
+ missing values apart from the diagonal elements of the square matrix.
+ The matrix should have winners as the rows, and losers as the columns.
+ In general, the response should be a 1-row matrix with \eqn{M(M+1)}
+ columns.
-Only an intercept model is recommended with \code{brat}.
-It doesn't make
-sense really to include covariates because of the limited
-VGLM framework.
+ Only an intercept model is recommended with \code{brat}. It doesn't
+ make sense really to include covariates because of the limited VGLM
+ framework.
-Notationally, note that the \pkg{VGAM} family function \code{\link{brat}}
-has \eqn{M+1} contestants, while \code{bratt} has \eqn{M} contestants.
+ Notationally, note that the \pkg{VGAM} family function
+ \code{\link{brat}} has \eqn{M+1} contestants, while \code{bratt}
+ has \eqn{M} contestants.
}
\section{Warning }{
-Presently, the residuals are wrong, and the prior
-weights are not handled correctly.
-Ideally, the total number of counts should be the
-prior weights, after the response has been converted to
-proportions. This would make it similar to family
-functions such as \code{\link{multinomial}} and
-\code{\link{binomialff}}.
+ Presently, the residuals are wrong, and the prior weights are not
+ handled correctly. Ideally, the total number of counts should
+ be the prior weights, after the response has been converted to
+ proportions. This would make it similar to family functions such as
+ \code{\link{multinomial}} and \code{\link{binomialff}}.
+
}
\seealso{
@@ -105,7 +103,7 @@ functions such as \code{\link{multinomial}} and
}
\examples{
# citation statistics: being cited is a 'win'; citing is a 'loss'
-journal = c("Biometrika", "Comm Statist", "JASA", "JRSS-B")
+journal = c("Biometrika", "Comm.Statist", "JASA", "JRSS-B")
m = matrix(c( NA, 33, 320, 284,
730, NA, 813, 276,
498, 68, NA, 325,
diff --git a/man/bratt.Rd b/man/bratt.Rd
index e3b51bd..d9f7bde 100644
--- a/man/bratt.Rd
+++ b/man/bratt.Rd
@@ -25,36 +25,32 @@ bratt(refgp = "last", refvalue = 1, init.alpha = 1, i0 = 0.01)
\details{
There are several models that extend the ordinary Bradley Terry model
to handle ties. This family function implements one of these models.
- It involves \eqn{M} competitors who either
- win or lose or tie against each other.
- (If there are no draws/ties then use \code{\link{brat}}).
-The probability that Competitor \eqn{i} beats Competitor \eqn{j} is
-\eqn{\alpha_i / (\alpha_i+\alpha_j+\alpha_0)}{alpha_i / (alpha_i +
-alpha_j + alpha_0)},
-where all the \eqn{\alpha}{alpha}s are positive.
- The probability that Competitor \eqn{i} ties with Competitor \eqn{j} is
-\eqn{\alpha_0 / (\alpha_i+\alpha_j+\alpha_0)}{alpha_0 / (alpha_i +
-alpha_j + alpha_0)}.
- Loosely, the \eqn{\alpha}{alpha}s can be thought of as the
-competitors' `abilities', and \eqn{\alpha_0}{alpha_0} is an
-added parameter to model ties.
-For identifiability, one of the \eqn{\alpha_i}{alpha_i} is set to a
-known value \code{refvalue}, e.g., 1.
-By default, this function chooses the last competitor to
-have this reference value.
-The data can be represented in the form of a
-\eqn{M} by \eqn{M} matrix of counts,
-where winners are the rows and losers are the columns.
-However, this is not the way the data should be inputted (see below).
-
-Excluding the reference value/group, this function chooses
-\eqn{\log(\alpha_j)}{log(alpha_j)} as the first \eqn{M-1} linear predictors.
-The log link ensures that the \eqn{\alpha}{alpha}s are positive.
-The last linear predictor is \eqn{\log(\alpha_0)}{log(alpha_0)}.
-
-The Bradley Terry model can be fitted with covariates, e.g., a home
-advantage variable, but unfortunately, this lies outside the VGLM
-theoretical framework and therefore cannot be handled with this code.
+ It involves \eqn{M} competitors who either win or lose or tie against
+ each other. (If there are no draws/ties then use \code{\link{brat}}).
+ The probability that Competitor \eqn{i} beats Competitor \eqn{j} is
+ \eqn{\alpha_i / (\alpha_i+\alpha_j+\alpha_0)}{alpha_i / (alpha_i +
+ alpha_j + alpha_0)}, where all the \eqn{\alpha}{alpha}s are positive.
+ The probability that Competitor \eqn{i} ties with Competitor \eqn{j}
+ is \eqn{\alpha_0 / (\alpha_i+\alpha_j+\alpha_0)}{alpha_0 / (alpha_i +
+ alpha_j + alpha_0)}. Loosely, the \eqn{\alpha}{alpha}s can be thought
+ of as the competitors' `abilities', and \eqn{\alpha_0}{alpha_0}
+ is an added parameter to model ties. For identifiability, one of
+ the \eqn{\alpha_i}{alpha_i} is set to a known value \code{refvalue},
+ e.g., 1. By default, this function chooses the last competitor to
+ have this reference value. The data can be represented in the form of
+ a \eqn{M} by \eqn{M} matrix of counts, where winners are the rows and
+ losers are the columns. However, this is not the way the data should
+ be inputted (see below).
+
+ Excluding the reference value/group, this function
+ chooses \eqn{\log(\alpha_j)}{log(alpha_j)} as the first
+ \eqn{M-1} linear predictors. The log link ensures that the
+ \eqn{\alpha}{alpha}s are positive. The last linear predictor is
+ \eqn{\log(\alpha_0)}{log(alpha_0)}.
+
+ The Bradley Terry model can be fitted with covariates, e.g., a home
+ advantage variable, but unfortunately, this lies outside the VGLM
+ theoretical framework and therefore cannot be handled with this code.
}
\value{
@@ -72,28 +68,25 @@ theoretical framework and therefore cannot be handled with this code.
}
\author{ T. W. Yee }
\note{
-The function \code{\link{Brat}} is useful for coercing a \eqn{M}
-by \eqn{M} matrix of counts into a one-row matrix suitable for
-\code{bratt}.
-Diagonal elements are skipped, and the usual S order of \code{c(a.matrix)}
-of elements is used. There should be no missing
-values apart from the diagonal elements of the square matrix.
-The matrix should have winners as the rows, and losers
-as the columns.
-In general, the response should be a matrix with \eqn{M(M-1)} columns.
-
-Also, a symmetric matrix of ties should be passed into
-\code{\link{Brat}}. The diagonal of this matrix should be all
-\code{NA}s.
-
-Only an intercept model is recommended with \code{bratt}.
-It doesn't make
-sense really to include covariates because of the limited
-VGLM framework.
-
-Notationally, note that the \pkg{VGAM} family function \code{\link{brat}}
-has \eqn{M+1} contestants, while \code{bratt} has \eqn{M} contestants.
-
+ The function \code{\link{Brat}} is useful for coercing a \eqn{M}
+ by \eqn{M} matrix of counts into a one-row matrix suitable for
+ \code{bratt}. Diagonal elements are skipped, and the usual S
+ order of \code{c(a.matrix)} of elements is used. There should be no
+ missing values apart from the diagonal elements of the square matrix.
+ The matrix should have winners as the rows, and losers as the columns.
+ In general, the response should be a matrix with \eqn{M(M-1)} columns.
+
+ Also, a symmetric matrix of ties should be passed into
+ \code{\link{Brat}}. The diagonal of this matrix should be all
+ \code{NA}s.
+
+ Only an intercept model is recommended with \code{bratt}. It doesn't
+ make sense really to include covariates because of the limited VGLM
+ framework.
+
+ Notationally, note that the \pkg{VGAM} family function
+ \code{\link{brat}} has \eqn{M+1} contestants, while \code{bratt}
+ has \eqn{M} contestants.
}
@@ -104,7 +97,7 @@ has \eqn{M+1} contestants, while \code{bratt} has \eqn{M} contestants.
}
\examples{
# citation statistics: being cited is a 'win'; citing is a 'loss'
-journal = c("Biometrika", "Comm Statist", "JASA", "JRSS-B")
+journal = c("Biometrika", "Comm.Statist", "JASA", "JRSS-B")
m = matrix(c( NA, 33, 320, 284,
730, NA, 813, 276,
498, 68, NA, 325,
diff --git a/man/calibrate.qrrvglm.Rd b/man/calibrate.qrrvglm.Rd
index ff1449d..2299f13 100644
--- a/man/calibrate.qrrvglm.Rd
+++ b/man/calibrate.qrrvglm.Rd
@@ -114,6 +114,7 @@ Cambridge.
\code{\link{cao}}.
}
\examples{
+\dontrun{
hspider[,1:6] = scale(hspider[,1:6]) # Standardize the environmental variables
set.seed(123)
p1 = cqo(cbind(Pardlugu, Pardmont, Pardnigr, Pardpull, Zoraspin) ~
@@ -124,6 +125,7 @@ p1 = cqo(cbind(Pardlugu, Pardmont, Pardnigr, Pardpull, Zoraspin) ~
siteNos = 1:2 # Calibrate these sites
cp1 = calibrate(p1, new=data.frame(p1 at y[siteNos,]), trace=TRUE)
+}
\dontrun{
# Graphically compare the actual site scores with their calibrated values
diff --git a/man/calibrate.qrrvglm.control.Rd b/man/calibrate.qrrvglm.control.Rd
index 666b148..f93103e 100644
--- a/man/calibrate.qrrvglm.control.Rd
+++ b/man/calibrate.qrrvglm.control.Rd
@@ -9,8 +9,7 @@
}
\usage{
calibrate.qrrvglm.control(object, trace = FALSE, Method.optim = "BFGS",
- gridSize = if (Rank == 1) 9 else 5,
- varlvI = FALSE, ...)
+ gridSize = if (Rank == 1) 9 else 5, varlvI = FALSE, ...)
}
%- maybe also 'usage' for other objects documented here.
\arguments{
@@ -80,6 +79,7 @@ On constrained and unconstrained quadratic ordination.
\code{\link{Coef.qrrvglm}}.
}
\examples{
+\dontrun{
hspider[,1:6] = scale(hspider[,1:6]) # Needed when ITol = TRUE
set.seed(123)
p1 = cqo(cbind(Alopacce, Alopcune, Pardlugu, Pardnigr,
@@ -91,6 +91,7 @@ sort(p1 at misc$deviance.Bestof) # A history of all the iterations
siteNos = 1:2 # Calibrate these sites
cp1 = calibrate(p1, new=data.frame(p1 at y[siteNos,]), trace=TRUE)
+}
\dontrun{
# Graphically compare the actual site scores with their calibrated values
diff --git a/man/cao.Rd b/man/cao.Rd
index 2af4486..975e8fa 100644
--- a/man/cao.Rd
+++ b/man/cao.Rd
@@ -19,10 +19,6 @@ cao(formula, family, data = list(),
}
%- maybe also 'usage' for other objects documented here.
\arguments{
- The arguments of \code{cao} are a mixture of those from
- \code{\link{vgam}} and \code{\link{cqo}}, but with some extras
- in \code{\link{cao.control}}. Currently, not all of the following
- arguments work properly.
\item{formula}{
a symbolic description of the model to be fit. The RHS of the
@@ -153,6 +149,12 @@ cao(formula, family, data = list(),
}
}
\details{
+ The arguments of \code{cao} are a mixture of those from
+ \code{\link{vgam}} and \code{\link{cqo}}, but with some extras
+ in \code{\link{cao.control}}. Currently, not all of the
+ arguments work properly.
+
+
CAO can be loosely be thought of as the result of fitting generalized
additive models (GAMs) to several responses (e.g., species) against
a very small number of latent variables. Each latent variable is a
@@ -163,6 +165,7 @@ cao(formula, family, data = list(),
estimation. It is often a good idea to apply \code{\link[base]{scale}}
to each explanatory variable first.
+
For each response (e.g., species), each latent variable is smoothed
by a cubic smoothing spline, thus CAO is data-driven. If each smooth
were a quadratic then CAO would simplify to \emph{constrained quadratic
@@ -173,9 +176,11 @@ cao(formula, family, data = list(),
\code{cao} by specifying \code{df1.nl=0}, however it is more efficient
to use \code{\link{rrvglm}}.
+
Currently, only \code{Rank=1} is implemented, and only
\code{Norrr = ~1} models are handled.
+
% Poisson and binary responses are implemented (viz.,
% \code{\link{poissonff}}, \code{\link{binomialff}}), and
% dispersion parameters for these must be assumed known. Hence using
@@ -183,6 +188,7 @@ cao(formula, family, data = list(),
% currently fail. Also, currently, only \code{Norrr = ~ 1} models are
% handled.
+
With binomial data, the default formula is
\deqn{logit(P[Y_s=1]) = \eta_s = f_s(\nu), \ \ \ s=1,2,\ldots,S}{%
logit(P[Y_s=1]) = eta_s = f_s(\nu), \ \ \ s=1,2,\ldots,S}
@@ -198,11 +204,13 @@ cao(formula, family, data = list(),
A \code{\link{cloglog}} link may be preferable over a
\code{\link{logit}} link.
+
With Poisson count data, the formula is
\deqn{\log(E[Y_s]) = \eta_s = f_s(\nu)}{%
log(E[Y_s]) = eta_s = f_s(\nu)}
which models the mean response as an additive models on the log scale.
+
The fitted latent variables (site scores) are scaled to have
unit variance. The concept of a tolerance is undefined for
CAO models, but the optima and maxima are defined. The generic
@@ -211,6 +219,7 @@ cao(formula, family, data = list(),
\code{\link{Max}} will return a \code{NA}. Inference for CAO models
is currently undeveloped.
+
}
\value{
An object of class \code{"cao"}
@@ -237,6 +246,7 @@ Constrained additive ordination.
= TRUE} is a good idea, as well as running it on a simple random sample
of the data set instead.
+
Sometimes the IRLS algorithm does not converge within the FORTRAN
code. This results in warnings being issued. In particular, if an
error code of 3 is issued, then this indicates the IRLS algorithm has
@@ -244,12 +254,14 @@ Constrained additive ordination.
the nonlinear degrees of freedom so that the curves become more or
less flexible, respectively.
+
}
\section{Warning }{
CAO is very costly to compute. With version 0.7-8 it took 28 minutes on
a fast machine. I hope to look at ways of speeding things up in the
future.
+
Use \code{\link[base:Random]{set.seed}} just prior to calling
\code{cao()} to make your results reproducible.
The reason for this is finding the optimal
@@ -261,13 +273,16 @@ Constrained additive ordination.
progressively more important as the nonlinear degrees of freedom of
the smooths increase.
+
% The code is a little fragile at this stage, so the function might
% hang/lock up in the microsoft Windows version.
+
Currently the dispersion parameter for a
\code{\link{gaussianff}} CAO model is estimated slightly differently
and may be slightly biassed downwards (usually a little too small).
+
}
\seealso{
@@ -285,8 +300,9 @@ Constrained additive ordination.
\code{\link{gamma2}},
\code{\link{gaussianff}},
\code{\link[base:Random]{set.seed}},
- \code{gam}.
-}
+ \code{\link[gam]{gam}}.
+
+}
\examples{
\dontrun{
diff --git a/man/cao.control.Rd b/man/cao.control.Rd
index ee094e8..2871fb9 100644
--- a/man/cao.control.Rd
+++ b/man/cao.control.Rd
@@ -10,39 +10,18 @@
}
\usage{
-cao.control(Rank=1, all.knots = FALSE,
- criterion="deviance",
- Cinit=NULL,
- Crow1positive=TRUE,
- epsilon = 1.0e-05,
- Etamat.colmax = 10,
- GradientFunction=FALSE,
- iKvector = 0.1,
- iShape = 0.1,
- Norrr = ~ 1,
- SmallNo = 5.0e-13,
- Use.Init.Poisson.QO=TRUE,
- Bestof = if(length(Cinit)) 1 else 10,
- maxitl = 40,
- method.init = 1,
- bf.epsilon = 1.0e-7,
- bf.maxit = 40,
- Maxit.optim = 250,
- optim.maxit = 20,
- SD.sitescores = 1.0,
- SD.Cinit = 0.02,
- trace = TRUE,
- df1.nl = 2.5, df2.nl = 2.5,
+cao.control(Rank=1, all.knots = FALSE, criterion="deviance", Cinit=NULL,
+ Crow1positive=TRUE, epsilon = 1.0e-05, Etamat.colmax = 10,
+ GradientFunction=FALSE, iKvector = 0.1, iShape = 0.1,
+ Norrr = ~ 1, SmallNo = 5.0e-13, Use.Init.Poisson.QO=TRUE,
+ Bestof = if (length(Cinit)) 1 else 10, maxitl = 40,
+ method.init = 1, bf.epsilon = 1.0e-7, bf.maxit = 40,
+ Maxit.optim = 250, optim.maxit = 20, SD.sitescores = 1.0,
+ SD.Cinit = 0.02, trace = TRUE, df1.nl = 2.5, df2.nl = 2.5,
spar1 = 0, spar2 = 0, ...)
}
%- maybe also 'usage' for other objects documented here.
\arguments{
- Many of these arguments are identical to \code{\link{qrrvglm.control}}.
- Here, \eqn{R} is the \code{Rank}, \eqn{M} is the number
- of additive predictors, and \eqn{S} is the number of responses
- (species).
- Thus \eqn{M=S} for binomial and Poisson responses, and
- \eqn{M=2S} for the negative binomial and 2-parameter gamma distributions.
\item{Rank}{
The numerical rank \eqn{R} of the model, i.e., the number of latent
@@ -250,6 +229,14 @@ cao.control(Rank=1, all.knots = FALSE,
\item{\dots}{ Ignored at present. }
}
\details{
+ Many of these arguments are identical to \code{\link{qrrvglm.control}}.
+ Here, \eqn{R} is the \code{Rank}, \eqn{M} is the number
+ of additive predictors, and \eqn{S} is the number of responses
+ (species).
+ Thus \eqn{M=S} for binomial and Poisson responses, and
+ \eqn{M=2S} for the negative binomial and 2-parameter gamma distributions.
+
+
Allowing the smooths too much flexibility means the CAO optimization
problem becomes more difficult to solve. This is because the number
of local solutions increases as the nonlinearity of the smooths
@@ -338,7 +325,7 @@ persp(ap1, label=TRUE, col=1:4)
%% Parscale = 1,
% SmallNo = 5e-13,
% Use.Init.Poisson.QO = TRUE,
-% Bestof = if(length(Cinit)) 1 else 10, maxitl = 40,
+% Bestof = if (length(Cinit)) 1 else 10, maxitl = 40,
% bf.epsilon = 1.0e-7, bf.maxit = 40,
% Maxit.optim = 250, optim.maxit = 20,
%% se.fit = FALSE,
diff --git a/man/cardioid.Rd b/man/cardioid.Rd
index 48ed8b2..881d3c7 100644
--- a/man/cardioid.Rd
+++ b/man/cardioid.Rd
@@ -8,7 +8,7 @@
}
\usage{
cardioid(lmu="elogit", lrho="elogit",
- emu=if(lmu=="elogit") list(min=0, max=2*pi) else list(),
+ emu =if(lmu=="elogit") list(min=0, max=2*pi) else list(),
erho=if(lmu=="elogit") list(min=-0.5, max=0.5) else list(),
imu=NULL, irho=0.3, nsimEIM=100, zero=NULL)
}
@@ -95,11 +95,11 @@ Singapore: World Scientific.
}
\examples{
-y = rcard(n=1000, mu=4, rho=0.45)
-fit = vglm(y ~ 1, cardioid, trace=TRUE)
+carddata = data.frame(y = rcard(n=1000, mu=4, rho=0.45))
+fit = vglm(y ~ 1, cardioid, carddata, trace=TRUE)
coef(fit, matrix=TRUE)
Coef(fit)
-c(mean(y), fitted(fit)[1,])
+c(with(carddata, mean(y)), head(fitted(fit),1))
summary(fit)
}
\keyword{models}
diff --git a/man/cauchit.Rd b/man/cauchit.Rd
index 0173dc0..1763547 100644
--- a/man/cauchit.Rd
+++ b/man/cauchit.Rd
@@ -114,13 +114,13 @@ y = seq(-4, 4, length=100)
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"
+ 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) {
+ 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)
@@ -131,14 +131,14 @@ for(d in 0:1) {
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"
+ 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) {
+ 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)
diff --git a/man/cauchy.Rd b/man/cauchy.Rd
index 7a5c1be..e3e0f44 100644
--- a/man/cauchy.Rd
+++ b/man/cauchy.Rd
@@ -133,18 +133,21 @@ Observed versus expected Fisher information.
}
\examples{
# Both location and scale parameters unknown
-x = runif(n <- 1000)
-y = rcauchy(n, loc=exp(1+0.5*x), scale=exp(1))
-fit = vglm(y ~ x, cauchy(lloc="loge"), trace=TRUE)
+nn <- 1000
+cdata1 = data.frame(x = runif(nn))
+cdata1 = transform(cdata1, loc=exp(1+0.5*x), scale=exp(1))
+cdata1 = transform(cdata1, y = rcauchy(nn, loc, scale))
+fit = vglm(y ~ x, cauchy(lloc="loge"), cdata1, trace=TRUE)
coef(fit, matrix=TRUE)
head(fitted(fit)) # Location estimates
summary(fit)
# Location parameter unknown
set.seed(123)
-x = runif(n <- 500)
-y = rcauchy(n, loc=1+5*x, scale=0.4)
-fit = vglm(y ~ x, cauchy1(scale=0.4), trace=TRUE, crit="c")
+cdata2 = data.frame(x = runif(nn <- 500))
+cdata2 = transform(cdata2, loc=1+0.5*x, scale=0.4)
+cdata2 = transform(cdata2, y = rcauchy(nn, loc, scale))
+fit = vglm(y ~ x, cauchy1(scale=0.4), cdata2, trace=TRUE, crit="c")
coef(fit, matrix=TRUE)
}
\keyword{models}
diff --git a/man/ccoef-methods.Rd b/man/ccoef-methods.Rd
index 537ff8f..3fc8d28 100644
--- a/man/ccoef-methods.Rd
+++ b/man/ccoef-methods.Rd
@@ -30,8 +30,8 @@
\item{object}{
The object from which the constrained coefficients are
extracted.
-
}
+
}
}
\keyword{methods}
diff --git a/man/ccoef.Rd b/man/ccoef.Rd
index 75d44a7..b46ebea 100644
--- a/man/ccoef.Rd
+++ b/man/ccoef.Rd
@@ -77,6 +77,7 @@ Constrained additive ordination.
}
\examples{
+\dontrun{
set.seed(111) # This leads to the global solution
hspider[,1:6] = scale(hspider[,1:6]) # Standardized environmental vars
p1 = cqo(cbind(Alopacce, Alopcune, Alopfabr, Arctlute, Arctperi,
@@ -86,6 +87,7 @@ p1 = cqo(cbind(Alopacce, Alopcune, Alopfabr, Arctlute, Arctperi,
fam = quasipoissonff, data = hspider, Crow1positive=FALSE)
ccoef(p1)
}
+}
\keyword{models}
\keyword{regression}
diff --git a/man/cenpoisson.Rd b/man/cenpoisson.Rd
index 2ec0238..09194e1 100644
--- a/man/cenpoisson.Rd
+++ b/man/cenpoisson.Rd
@@ -33,7 +33,7 @@ cenpoisson(link = "loge", earg = list(), imu = NULL)
Often a table of Poisson counts has an entry \emph{J+} meaning
\eqn{\ge J}.
This family function is similar to \code{\link{poissonff}} but handles
- such censored data. The input requires \code{\link{Surv}}.
+ such censored data. The input requires \code{\link{SurvS4}}.
Only a univariate response is allowed.
The Newton-Raphson algorithm is used.
@@ -55,7 +55,7 @@ cenpoisson(link = "loge", earg = list(), imu = NULL)
\note{
The function \code{\link{poissonff}} should be used
when there are no censored observations.
- Also, \code{NA}s are not permitted with \code{\link{Surv}},
+ Also, \code{NA}s are not permitted with \code{\link{SurvS4}},
nor is \code{type="counting"}.
}
@@ -76,23 +76,22 @@ cenpoisson(link = "loge", earg = list(), imu = NULL)
}
\seealso{
- \code{\link{Surv}},
+ \code{\link{SurvS4}},
\code{\link{poissonff}},
\code{\link{Links}}.
}
\examples{
# Example 1: right censored data
-set.seed(123)
+set.seed(123); U = 20
y = rpois(n <- 100, exp(3))
-U = 20
cy = pmin(U, y)
-rcensored = y >= U
+rcensored = (y >= U)
table(cy)
table(rcensored)
status = ifelse(rcensored, 0, 1)
-table(i <- print(Surv(cy, status))) # Check; U+ means >= U
-fit = vglm(Surv(cy, status) ~ 1, cenpoisson, trace=TRUE)
+table(ii <- print(SurvS4(cy, status))) # Check; U+ means >= U
+fit = vglm(SurvS4(cy, status) ~ 1, cenpoisson, trace=TRUE)
coef(fit, mat=TRUE)
table(print(fit at y)) # Another check; U+ means >= U
@@ -100,18 +99,17 @@ table(print(fit at y)) # Another check; U+ means >= U
# Example 2: left censored data
L = 15
cy = pmax(L, y)
-lcensored = y < L # Note y < L, not cy == L or y <= L
+lcensored = (y < L) # Note y < L, not cy == L or y <= L
table(cy)
table(lcensored)
status = ifelse(lcensored, 0, 1)
-table(i <- print(Surv(cy, status, type="left"))) # Check
-fit = vglm(Surv(cy, status, type="left") ~ 1, cenpoisson, trace=TRUE)
+table(ii <- print(SurvS4(cy, status, type="left"))) # Check
+fit = vglm(SurvS4(cy, status, type="left") ~ 1, cenpoisson, trace=TRUE)
coef(fit, mat=TRUE)
# Example 3: interval censored data
-Lvec = rep(L, len=n)
-Uvec = rep(U, len=n)
+Lvec = rep(L, len=n); Uvec = rep(U, len=n)
icensored = Lvec <= y & y < Uvec # Neither lcensored or rcensored
table(icensored)
status = rep(3, n) # 3 means interval censored
@@ -122,9 +120,9 @@ Lvec[icensored] = Lvec[icensored] - 1
Uvec[icensored] = Uvec[icensored] - 1
Lvec[lcensored] = Lvec[lcensored] # Remains unchanged
Lvec[rcensored] = Uvec[rcensored] # Remains unchanged
-table(i <- print(Surv(Lvec, Uvec, status, type="interval"))) # Check
+table(ii <- print(SurvS4(Lvec, Uvec, status, type="interval"))) # Check
-fit = vglm(Surv(Lvec, Uvec, status, type="interval") ~ 1,
+fit = vglm(SurvS4(Lvec, Uvec, status, type="interval") ~ 1,
cenpoisson, trace=TRUE)
coef(fit, mat=TRUE)
table(print(fit at y)) # Another check
@@ -135,9 +133,9 @@ index = (1:n)[icensored]
index = head(index, 4)
status[index] = 1 # actual or uncensored value
Lvec[index] = y[index]
-table(i <- print(Surv(Lvec, Uvec, status, type="interval"))) # Check
+table(ii <- print(SurvS4(Lvec, Uvec, status, type="interval"))) # Check
-fit = vglm(Surv(Lvec, Uvec, status, type="interval") ~ 1,
+fit = vglm(SurvS4(Lvec, Uvec, status, type="interval") ~ 1,
cenpoisson, trace=TRUE, crit="c")
coef(fit, mat=TRUE)
table(print(fit at y)) # Another check
diff --git a/man/cgumbel.Rd b/man/cgumbel.Rd
index 7bc2cdc..6fc868a 100644
--- a/man/cgumbel.Rd
+++ b/man/cgumbel.Rd
@@ -9,9 +9,8 @@
}
\usage{
-cgumbel(llocation="identity", lscale = "loge",
- elocation = list(), escale = list(), iscale=NULL,
- mean=TRUE, percentiles=NULL, zero=2)
+cgumbel(llocation = "identity", lscale = "loge", elocation = list(),
+ escale = list(), iscale=NULL, mean=TRUE, percentiles=NULL, zero=2)
}
%- maybe also 'usage' for other objects documented here.
\arguments{
diff --git a/man/chest.Rd b/man/chestnz.Rd
similarity index 91%
rename from man/chest.Rd
rename to man/chestnz.Rd
index 0aad154..0bd9fe4 100644
--- a/man/chest.Rd
+++ b/man/chestnz.Rd
@@ -1,11 +1,11 @@
-\name{chest}
-\alias{chest}
+\name{chestnz}
+\alias{chestnz}
\docType{data}
\title{ Chest Pain in NZ Adults Data}
\description{
Presence/absence of chest pain in 10186 New Zealand adults.
}
-\usage{data(chest)}
+\usage{data(chestnz)}
\format{
A data frame with 73 rows and the following 5 variables.
\describe{
@@ -33,7 +33,7 @@
}
\examples{
fit = vgam(cbind(nolnor, nolr,lnor,lr) ~ s(age, c(4,3)),
- binom2.or(exchan=TRUE, zero=NULL), data = chest)
+ binom2.or(exchan=TRUE, zero=NULL), data = chestnz)
coef(fit, matrix=TRUE)
\dontrun{
plot(fit, which.cf=2, se=TRUE)
diff --git a/man/chisq.Rd b/man/chisq.Rd
index 427f607..dfebed4 100644
--- a/man/chisq.Rd
+++ b/man/chisq.Rd
@@ -53,10 +53,10 @@ New York: Wiley-Interscience, Third edition.
\code{\link{normal1}}.
}
\examples{
-y = rchisq(n=200, df=exp(2))
-fit = vglm(y ~ 1, chisq)
+cdata = data.frame(x = runif(nn <- 1000))
+cdata = transform(cdata, y = rchisq(nn, df=exp(2 - x)))
+fit = vglm(y ~ x, chisq, cdata, trace=TRUE)
coef(fit, matrix=TRUE)
-Coef(fit)
}
\keyword{models}
\keyword{regression}
diff --git a/man/cloglog.Rd b/man/cloglog.Rd
index 7d086f2..1414308 100644
--- a/man/cloglog.Rd
+++ b/man/cloglog.Rd
@@ -83,6 +83,11 @@ cloglog(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}.
+ Changing 1s to 0s and 0s to 1s in the response means that effectively
+ a loglog link is fitted. That is, tranform \eqn{y} by \eqn{1-y}.
+ That's why only one of \code{\link{cloglog}}
+ and \code{loglog} is written.
+
With constrained ordination (e.g., \code{\link{cqo}} and
\code{\link{cao}}) used with \code{\link{binomialff}}, a complementary
log-log link function is preferred over the default \code{\link{logit}}
@@ -121,6 +126,7 @@ legend(0.1, 4, c("logit", "probit", "cloglog", "cauchit"),
col=c("limegreen","purple","chocolate", "tan"), lwd=2)
}
+\dontrun{
# This example shows that a cloglog link is preferred over the logit
n = 500; p = 5; S = 3; Rank = 1 # Species packing model:
mydata = rcqo(n, p, S, EqualTol=TRUE, ESOpt=TRUE, EqualMax=TRUE,
@@ -133,6 +139,7 @@ fitl = cqo(attr(mydata, "formula"), ITol=TRUE, data=mydata,
# Compare the fitted models (cols 1 and 3) with the truth (col 2)
cbind(ccoef(fitc), attr(mydata, "ccoefficients"), ccoef(fitl))
}
+}
\keyword{math}
\keyword{models}
\keyword{regression}
diff --git a/man/cnormal1.Rd b/man/cnormal1.Rd
index 5ac6981..11ac633 100644
--- a/man/cnormal1.Rd
+++ b/man/cnormal1.Rd
@@ -73,17 +73,17 @@ cnormal1(lmu="identity", lsd="loge", imethod=1, zero=2)
}
\examples{
-n = 1000
-x = runif(n)
-ystar = rnorm(n, mean=100 + 15 * x, sd=exp(3)) # True values
+cdata = data.frame(x = runif(nn <- 1000)) # ystar are true values
+cdata = transform(cdata, ystar = rnorm(nn, mean=100 + 15 * x, sd=exp(3)))
\dontrun{hist(ystar)}
-L = runif(n, 80, 90) # Lower censoring points
-U = runif(n, 130, 140) # Upper censoring points
-y = pmax(L, ystar) # Left censored
-y = pmin(U, y) # Right censored
+L = runif(nn, 80, 90) # Lower censoring points
+U = runif(nn, 130, 140) # Upper censoring points
+cdata = transform(cdata, y = pmax(L, ystar)) # Left censored
+cdata = transform(cdata, y = pmin(U, y)) # Right censored
\dontrun{hist(y)}
-extra = list(leftcensored = ystar < L, rightcensored = ystar > U)
-fit = vglm(y ~ x, cnormal1(zero=2), trace=TRUE, extra=extra)
+extra = list(leftcensored = with(cdata, ystar < L),
+ rightcensored = with(cdata, ystar > U))
+fit = vglm(y ~ x, cnormal1(zero=2), cdata, trace=TRUE, extra=extra)
coef(fit, matrix=TRUE)
Coef(fit)
names(fit at extra)
diff --git a/man/cqo.Rd b/man/cqo.Rd
index b1ac355..e70c210 100644
--- a/man/cqo.Rd
+++ b/man/cqo.Rd
@@ -19,10 +19,6 @@ cqo(formula, family, data = list(), weights = NULL, subset = NULL,
}
%- maybe also 'usage' for other objects documented here.
\arguments{
- In this documentation, \eqn{M} is the number of linear predictors,
- \eqn{S} is the number of responses (species). Then
- \eqn{M=S} for Poisson and binomial species data,
- and \eqn{M=2S} for negative binomial and gamma distributed species data.
\item{formula}{ a symbolic description of the model to be fit.
The RHS of the formula is applied to each linear predictor. Different
@@ -182,6 +178,7 @@ cqo(formula, family, data = list(), weights = NULL, subset = NULL,
in order to maximize the log-likelihood function, or equivalently,
minimize the deviance.
+
The central formula (for Poisson and binomial species data) is
given by
\deqn{\eta = B_1^T x_1 + A \nu +
@@ -202,6 +199,7 @@ cqo(formula, family, data = list(), weights = NULL, subset = NULL,
in \code{\link{qrrvglm.control}}, e.g., the argument \code{Norrr}
specifies which variables comprise \eqn{x_1}{x_1}.
+
Theoretically, the four most popular \pkg{VGAM} family functions
to be used with \code{cqo} correspond to the Poisson, binomial,
normal, and negative binomial distributions. The latter is a
@@ -212,6 +210,7 @@ cqo(formula, family, data = list(), weights = NULL, subset = NULL,
Those beginning with \code{"quasi"} have dispersion parameters that
are estimated for each species.
+
%the negative binomial by \code{\link{negbinomial}}, and the normal by
%\code{gaussianff}.
@@ -219,6 +218,7 @@ cqo(formula, family, data = list(), weights = NULL, subset = NULL,
%strongly recommended over \code{\link{negbinomial}}; the latter is
%\emph{very} sensitive to departures from the model assumptions.
+
For initial values, the function \code{.Init.Poisson.QO} should
work reasonably well if the data is Poisson with species having equal
tolerances. It can be quite good on binary data too. Otherwise the
@@ -231,6 +231,13 @@ cqo(formula, family, data = list(), weights = NULL, subset = NULL,
so that CQO is extended to \emph{constrained additive ordination}
(CAO) when \eqn{R=1}. See \code{\link{cao}} for more details.
+
+ In this documentation, \eqn{M} is the number of linear predictors,
+ \eqn{S} is the number of responses (species). Then
+ \eqn{M=S} for Poisson and binomial species data,
+ and \eqn{M=2S} for negative binomial and gamma distributed species data.
+
+
}
\value{
An object of class \code{"qrrvglm"}.
@@ -412,112 +419,6 @@ contains further information and examples.
# Example 1; Fit an unequal tolerances model to the hunting spiders data
hspider[,1:6]=scale(hspider[,1:6]) # Standardize the environmental variables
set.seed(1234)
-p1ut = cqo(cbind(Alopacce, Alopcune, Alopfabr, Arctlute, Arctperi,
- Auloalbi, Pardlugu, Pardmont, Pardnigr, Pardpull,
- Trocterr, Zoraspin) ~
- WaterCon + BareSand + FallTwig + CoveMoss + CoveHerb + ReflLux,
- fam=poissonff, data=hspider, Crow1positive=FALSE, ITol=FALSE)
-sort(p1ut at misc$deviance.Bestof) # A history of all the iterations
-if(deviance(p1ut) > 1177) stop("suboptimal fit obtained")
-
-\dontrun{
-S = ncol(p1ut at y) # Number of species
-clr = (1:(S+1))[-7] # omits yellow
-lvplot(p1ut, y=TRUE, lcol=clr, pch=1:S, pcol=clr, las=1) # ordination diagram
-legend("topright", leg=colnames(p1ut at y), col=clr,
- pch=1:S, merge=TRUE, bty="n", lty=1:S, lwd=2)
-}
-(cp = Coef(p1ut))
-
-(a = cp at lv[cp at lvOrder]) # The ordered site scores along the gradient
-# Names of the ordered sites along the gradient:
-rownames(cp at lv)[cp at lvOrder]
-(a = (cp at Optimum)[,cp at OptimumOrder]) # The ordered optima along the gradient
-a = a[!is.na(a)] # Delete the species that is not unimodal
-names(a) # Names of the ordered optima along the gradient
-
-\dontrun{
-trplot(p1ut, whichSpecies=1:3, log="xy", type="b", lty=1, lwd=2,
- col=c("blue","red","green"), label=TRUE) -> ii # trajectory plot
-legend(0.00005, 0.3, paste(ii$species[,1], ii$species[,2], sep=" and "),
- lwd=2, lty=1, col=c("blue","red","green"))
-abline(a=0, b=1, lty="dashed")
-
-S = ncol(p1ut at y) # Number of species
-clr = (1:(S+1))[-7] # omits yellow
-persp(p1ut, col=clr, label=TRUE, las=1) # perspective plot
-}
-
-# Example 2: A rank-2 equal tolerances CQO model with Poisson data
-# This example is numerically fraught.
-set.seed(555)
-p2 = cqo(cbind(Alopacce, Alopcune, Alopfabr, Arctlute, Arctperi,
- Auloalbi, Pardlugu, Pardmont, Pardnigr, Pardpull,
- Trocterr, Zoraspin) ~
- WaterCon + BareSand + FallTwig + CoveMoss + CoveHerb + ReflLux,
- fam=poissonff, data=hspider, Crow1positive=FALSE,
-# ITol=FALSE, EqualTol=TRUE,
- Rank=2, Bestof=1, isdlv=c(2.1,0.9))
-sort(p2 at misc$deviance.Bestof) # A history of all the iterations
-if(deviance(p2) > 1127) stop("suboptimal fit obtained")
-\dontrun{
-lvplot(p2, ellips=FALSE, label=TRUE, xlim=c(-3,4),
- C=TRUE, Ccol="brown", sites=TRUE, scol="grey",
- pcol="blue", pch="+", chull=TRUE, ccol="grey")
-}
-
-
-# Example 3: species packing model with presence/absence data
-set.seed(2345)
-n = 200; p = 5; S = 5
-mydata = rcqo(n, p, S, fam="binomial", hiabundance=4,
- EqualTol=TRUE, ESOpt=TRUE, EqualMax=TRUE)
-myform = attr(mydata, "formula")
-set.seed(1234)
-b1et = cqo(myform, fam=binomialff(mv=TRUE, link="cloglog"), data=mydata)
-sort(b1et at misc$deviance.Bestof) # A history of all the iterations
-\dontrun{
-lvplot(b1et, y=TRUE, lcol=1:S, pch=1:S, pcol=1:S, las=1)
-}
-Coef(b1et)
-
-# Compare the fitted model with the 'truth'
-cbind(truth=attr(mydata, "ccoefficients"), fitted=ccoef(b1et))
-
-
-# Example 4: Plot the deviance residuals for diagnostic purposes
-set.seed(1234)
-p1et = cqo(cbind(Alopacce, Alopcune, Alopfabr, Arctlute, Arctperi,
- Auloalbi, Pardlugu, Pardmont, Pardnigr, Pardpull,
- Trocterr, Zoraspin) ~
- WaterCon + BareSand + FallTwig + CoveMoss + CoveHerb + ReflLux,
- fam=poissonff, data=hspider, ITol=TRUE, trace=FALSE)
-sort(p1et at misc$deviance.Bestof) # A history of all the iterations
-if(deviance(p1et) > 1586) stop("suboptimal fit obtained")
-S = ncol(p1et at y)
-par(mfrow=c(3,4))
-for(ii in 1:S) {
- tempdata = data.frame(lv1 = c(lv(p1et)), sppCounts = p1et at y[,ii])
- tempdata = transform(tempdata, myOffset = -0.5 * lv1^2)
-
-# For species ii, refit the model to get the deviance residuals
- fit1 = vglm(sppCounts ~ offset(myOffset) + lv1, fam=poissonff,
- data=tempdata, trace=FALSE)
-
-# For checking: this should be 0
- print("max(abs(c(Coef(p1et)@B1[1,ii], Coef(p1et)@A[ii,1]) - coef(fit1)))")
- print( max(abs(c(Coef(p1et)@B1[1,ii], Coef(p1et)@A[ii,1]) - coef(fit1))) )
-
-# # Plot the deviance residuals
- devresid = resid(fit1, type = "deviance")
- predvalues = predict(fit1) + fit1 at offset
- oo = with(tempdata, order(lv1))
-\dontrun{
- with(tempdata, plot(lv1, predvalues + devresid, col="darkgreen",
- xlab="lv1", ylab="", main=colnames(p1et at y)[ii]))
- with(tempdata, lines(lv1[oo], predvalues[oo], col="blue"))
-}
-}
}
\keyword{models}
\keyword{regression}
diff --git a/man/cratio.Rd b/man/cratio.Rd
index 75dc87e..50b75dd 100644
--- a/man/cratio.Rd
+++ b/man/cratio.Rd
@@ -12,10 +12,6 @@ cratio(link = "logit", earg = list(),
}
%- maybe also 'usage' for other objects documented here.
\arguments{
- In the following, the response \eqn{Y} is assumed to be a factor
- with ordered values \eqn{1,2,\dots,M+1}, so that
- \eqn{M} is the number of linear/additive predictors
- \eqn{\eta_j}{eta_j}.
\item{link}{
Link function applied to the \eqn{M} continuation ratio probabilities.
@@ -51,18 +47,26 @@ cratio(link = "logit", earg = list(),
}
}
\details{
+ In this help file the response \eqn{Y} is assumed to be a factor
+ with ordered values \eqn{1,2,\dots,M+1}, so that
+ \eqn{M} is the number of linear/additive predictors
+ \eqn{\eta_j}{eta_j}.
+
+
There are a number of definitions for the \emph{continuation ratio}
in the literature. To make life easier, in the \pkg{VGAM} package,
we use \emph{continuation} ratios and \emph{stopping} ratios
(see \code{\link{sratio}}).
Stopping ratios deal with quantities such as
\code{logit(P[Y=j|Y>=j])}.
+
}
\value{
An object of class \code{"vglmff"} (see \code{\link{vglmff-class}}).
The object is used by modelling functions such as \code{\link{vglm}},
\code{\link{rrvglm}}
and \code{\link{vgam}}.
+
}
\references{
Agresti, A. (2002)
@@ -76,6 +80,14 @@ New York: Springer-Verlag.
McCullagh, P. and Nelder, J. A. (1989)
\emph{Generalized Linear Models}, 2nd ed. London: Chapman & Hall.
+
+Yee, T. W. (2010)
+The \pkg{VGAM} package for categorical data analysis.
+\emph{Journal of Statistical Software},
+\bold{32}, 1--34.
+\url{http://www.jstatsoft.org/v32/i10/}.
+
+
Documentation accompanying the \pkg{VGAM} package at
\url{http://www.stat.auckland.ac.nz/~yee}
contains further information and examples.
@@ -98,11 +110,11 @@ contains further information and examples.
the regression coefficients for \code{x1} and \code{x2} to be
equal; those of the intercepts and \code{x3} would be different.
-
}
\section{Warning }{
No check is made to verify that the response is ordinal;
see \code{\link[base:factor]{ordered}}.
+
}
\seealso{
@@ -115,6 +127,7 @@ contains further information and examples.
\code{\link{probit}},
\code{\link{cloglog}},
\code{\link{cauchit}}.
+
}
\examples{
diff --git a/man/cumulative.Rd b/man/cumulative.Rd
index cd97b41..1a8d6f8 100644
--- a/man/cumulative.Rd
+++ b/man/cumulative.Rd
@@ -9,21 +9,14 @@
}
\usage{
-cumulative(link = "logit", earg = list(),
- parallel = FALSE, reverse = FALSE,
- mv = FALSE, intercept.apply = FALSE)
+cumulative(link = "logit", earg = list(), parallel = FALSE,
+ reverse = FALSE, mv = FALSE, intercept.apply = FALSE)
}
%scumulative(link="logit", earg = list(),
% lscale="loge", escale = list(),
% parallel=FALSE, sparallel=TRUE, reverse=FALSE, iscale = 1)
%- maybe also 'usage' for other objects documented here.
\arguments{
- In the following, the response \eqn{Y} is assumed to be a factor
- with ordered values \eqn{1,2,\dots,J+1}.
- Hence \eqn{M} is the number of linear/additive predictors
- \eqn{\eta_j}{eta_j};
- for \code{cumulative()} \eqn{M=J}.
-% and for \code{scumulative()} \eqn{M=2J}.
\item{link}{
Link function applied to the \eqn{J} cumulative probabilities.
@@ -38,6 +31,7 @@ cumulative(link = "logit", earg = list(),
% See \code{\link{Links}} for more choices.
%
% }
+
\item{earg}{
List. Extra argument for the link function.
See \code{earg} in \code{\link{Links}} for general information.
@@ -63,9 +57,9 @@ cumulative(link = "logit", earg = list(),
By default, the cumulative probabilities used are
\eqn{P(Y\leq 1)}{P(Y<=1)}, \eqn{P(Y\leq 2)}{P(Y<=2)},
\dots, \eqn{P(Y\leq J)}{P(Y<=J)}.
- If \code{reverse} is \code{TRUE}, then
+ If \code{reverse} is \code{TRUE} then
\eqn{P(Y\geq 2)}{P(Y>=2)}, \eqn{P(Y\geq 3)}{P(Y>=3)}, \dots,
- \eqn{P(Y\geq J+1)}{P(Y>=J+1)} will be used.
+ \eqn{P(Y\geq J+1)}{P(Y>=J+1)} are used.
This should be set to \code{TRUE} for \code{link=}
\code{\link{golf}},
@@ -99,13 +93,21 @@ cumulative(link = "logit", earg = list(),
% }
}
\details{
+ In this help file the response \eqn{Y} is assumed to be a factor
+ with ordered values \eqn{1,2,\dots,J+1}.
+ Hence \eqn{M} is the number of linear/additive predictors
+ \eqn{\eta_j}{eta_j};
+ for \code{cumulative()} one has \eqn{M=J}.
+% and for \code{scumulative()} \eqn{M=2J}.
+
+
This \pkg{VGAM} family function fits the class of
- cumulative link models to (hopefully) an ordinal response.
- By default, the non-parallel cumulative logit model is fitted, i.e.,
+ \emph{cumulative link models} to (hopefully) an ordinal response.
+ By default, the \emph{non-parallel} cumulative logit model is fitted, i.e.,
\deqn{\eta_j = logit(P[Y \leq j])}{%
eta_j = logit(P[Y<=j])}
- where \eqn{j=1,2,\dots,M} and
- the \eqn{\eta_j}{eta_j} are not constrained to be parallel.
+ where \eqn{j=1,2,\dots,M} and
+ the \eqn{\eta_j}{eta_j} are not constrained to be parallel.
This is also known as the \emph{non-proportional odds model}.
If the logit link is replaced by a complementary log-log link
(\code{\link{cloglog}}) then
@@ -132,7 +134,6 @@ cumulative(link = "logit", earg = list(),
\value{
An object of class \code{"vglmff"} (see \code{\link{vglmff-class}}).
The object is used by modelling functions such as \code{\link{vglm}},
- \code{\link{rrvglm}}
and \code{\link{vgam}}.
}
@@ -141,9 +142,9 @@ Agresti, A. (2002)
\emph{Categorical Data Analysis},
2nd ed. New York: Wiley.
-Dobson, A. J. (2001)
+Dobson, A. J. and Barnett, A. (2008)
\emph{An Introduction to Generalized Linear Models},
-2nd ed. Boca Raton: Chapman & Hall/CRC Press.
+3rd ed. Boca Raton: Chapman & Hall/CRC Press.
McCullagh, P. and Nelder, J. A. (1989)
\emph{Generalized Linear Models}, 2nd ed. London: Chapman & Hall.
@@ -152,14 +153,24 @@ Simonoff, J. S. (2003)
\emph{Analyzing Categorical Data},
New York: Springer-Verlag.
+
+Yee, T. W. (2010)
+The \pkg{VGAM} package for categorical data analysis.
+\emph{Journal of Statistical Software},
+\bold{32}, 1--34.
+\url{http://www.jstatsoft.org/v32/i10/}.
+
+
Yee, T. W. and Wild, C. J. (1996)
Vector generalized additive models.
\emph{Journal of the Royal Statistical Society, Series B, Methodological},
\bold{58}, 481--493.
-Documentation accompanying the \pkg{VGAM} package at
-\url{http://www.stat.auckland.ac.nz/~yee}
-contains further information and examples.
+
+Further information and examples on categorical data analysis
+by the \pkg{VGAM} package can be found at
+\url{http://www.stat.auckland.ac.nz/~yee/VGAM/doc/categorical.pdf}.
+
}
\author{ Thomas W. Yee }
@@ -174,7 +185,6 @@ contains further information and examples.
\code{\link{acat}},
\code{\link{cratio}},
\code{\link{sratio}}.
-
For a nominal (unordered) factor response, the multinomial
logit model (\code{\link{multinomial}}) is more appropriate.
@@ -206,6 +216,15 @@ contains further information and examples.
\code{etatstart}.
See the example below.
+ To fit the proportional odds model one can use the
+ \pkg{VGAM} family function \code{\link{propodds}}.
+ Note that \code{propodds(reverse)} is equivalent to
+ \code{cumulative(parallel=TRUE, reverse=reverse)} (which is equivalent to
+ \code{cumulative(parallel=TRUE, reverse=reverse, link="logit")}).
+ It is for convenience only. A call to \code{cumulative()} is preferred
+ since it reminds the user that a parallelism assumption is made, as
+ well as being a lot more flexible.
+
% In the future, this family function may be renamed to
% ``\code{cups}'' (for \bold{cu}mulative \bold{p}robabilitie\bold{s})
@@ -221,6 +240,8 @@ contains further information and examples.
}
\seealso{
+ \code{\link{propodds}},
+ \code{\link{prplot}},
\code{\link{margeff}},
\code{\link{acat}},
\code{\link{cratio}},
@@ -252,14 +273,13 @@ constraints(fit) # Constraint matrices
fit2 = vgam(cbind(normal, mild, severe) ~ s(let, df=2),
cumulative(reverse=TRUE), pneumo)
\dontrun{
-plot(fit2, se=TRUE, overlay=TRUE, lcol=1:2, scol=1:2)
-}
+plot(fit2, se=TRUE, overlay=TRUE, lcol=1:2, scol=1:2) }
# Check the proportional odds assumption with a LRT ----------
(fit3 = vglm(cbind(normal, mild, severe) ~ let,
cumulative(parallel=FALSE, reverse=TRUE), pneumo))
-1 - pchisq(2*(logLik(fit3)-logLik(fit)),
- df=length(coef(fit3))-length(coef(fit)))
+pchisq(2*(logLik(fit3)-logLik(fit)),
+ df=length(coef(fit3))-length(coef(fit)), lower.tail=FALSE)
# A factor() version of fit ----------------------------------
# This is in long format (cf. wide format above)
diff --git a/man/dagum.Rd b/man/dagum.Rd
index c20330c..6aee66f 100644
--- a/man/dagum.Rd
+++ b/man/dagum.Rd
@@ -104,9 +104,9 @@ while estimates for \eqn{a} and \eqn{p} can be considered unbiased for
}
\examples{
-y = rdagum(n=3000, 4, 6, 2)
-fit = vglm(y ~ 1, dagum, trace=TRUE)
-fit = vglm(y ~ 1, dagum(init.a=2.1), trace=TRUE, crit="c")
+ddata = data.frame(y = rdagum(n=3000, 4, 6, 2))
+fit = vglm(y ~ 1, dagum, ddata, trace=TRUE)
+fit = vglm(y ~ 1, dagum(init.a=2.1), ddata, trace=TRUE, crit="c")
coef(fit, mat=TRUE)
Coef(fit)
summary(fit)
diff --git a/man/dcnormal1.Rd b/man/dcnormal1.Rd
index a1ac9b7..0078669 100644
--- a/man/dcnormal1.Rd
+++ b/man/dcnormal1.Rd
@@ -94,8 +94,8 @@ c(sd(mu.save), sd(sd.save))
}
# Data from Sarhan and Greenberg (1962); MLEs are mu=9.2606, sd=1.3754
-strontium90 = c(8.2, 8.4, 9.1, 9.8, 9.9)
-fit = vglm(strontium90 ~ 1, dcnormal1(r1=2, r2=3, isd=6), trace=TRUE)
+strontium90 = data.frame(y = c(8.2, 8.4, 9.1, 9.8, 9.9))
+fit = vglm(y ~ 1, dcnormal1(r1=2, r2=3, isd=6), strontium90, trace=TRUE)
coef(fit, matrix=TRUE)
Coef(fit)
}
diff --git a/man/deplot.lmscreg.Rd b/man/deplot.lmscreg.Rd
index 6c1bda4..6fad0c3 100644
--- a/man/deplot.lmscreg.Rd
+++ b/man/deplot.lmscreg.Rd
@@ -7,8 +7,7 @@
associated with a LMS quantile regression.
}
\usage{
-deplot.lmscreg(object, newdata = NULL,
- x0, y.arg, plot.it = TRUE, ...)
+deplot.lmscreg(object, newdata = NULL, x0, y.arg, plot.it = TRUE, ...)
}
%- maybe also 'usage' for other objects documented here.
\arguments{
@@ -83,6 +82,6 @@ head(a at post$deplot$y)
head(a at post$deplot$density)
}
}
-\keyword{hplot}
+\keyword{graphs}
\keyword{models}
\keyword{regression}
diff --git a/man/dexpbinomial.Rd b/man/dexpbinomial.Rd
index e5232f0..35b931a 100644
--- a/man/dexpbinomial.Rd
+++ b/man/dexpbinomial.Rd
@@ -9,9 +9,8 @@
}
\usage{
-dexpbinomial(lmean="logit", ldispersion="logit",
- emean=list(), edispersion=list(),
- idispersion=0.25, zero=2)
+dexpbinomial(lmean="logit", ldispersion="logit", emean=list(),
+ edispersion=list(), idispersion=0.25, zero=2)
}
%- maybe also 'usage' for other objects documented here.
\arguments{
diff --git a/man/dirichlet.Rd b/man/dirichlet.Rd
index 67322e8..423337e 100644
--- a/man/dirichlet.Rd
+++ b/man/dirichlet.Rd
@@ -11,10 +11,6 @@ dirichlet(link = "loge", earg=list(), parallel = FALSE, zero=NULL)
}
%- maybe also 'usage' for other objects documented here.
\arguments{
- In the following, the response is assumed to be a \eqn{M}-column
- matrix with positive values and whose rows each sum to unity. Such
- data can be thought of as compositional data.
- There are \eqn{M} linear/additive predictors \eqn{\eta_j}{eta_j}.
\item{link}{
Link function applied to each of the \eqn{M} (positive) shape
@@ -34,6 +30,12 @@ dirichlet(link = "loge", earg=list(), parallel = FALSE, zero=NULL)
}
}
\details{
+ In this help file the response is assumed to be a \eqn{M}-column
+ matrix with positive values and whose rows each sum to unity.
+ Such data can be thought of as compositional data.
+ There are \eqn{M} linear/additive predictors \eqn{\eta_j}{eta_j}.
+
+
The Dirichlet distribution is commonly used to model compositional
data, including applications in genetics.
Suppose \eqn{(Y_1,\ldots,Y_{M})^T}{(Y_1,\ldots,Y_M)^T} is
diff --git a/man/erf.Rd b/man/erf.Rd
index e0d3c82..6980a57 100644
--- a/man/erf.Rd
+++ b/man/erf.Rd
@@ -17,38 +17,42 @@ erf(x)
\deqn{Erf(x) = \frac{2}{\sqrt{\pi}} \int_0^x \exp(-t^2) dt}{%
Erf(x) = (2/sqrt(pi)) int_0^x exp(-t^2) dt}
so that it is closely related to \code{\link[stats:Normal]{pnorm}}.
+
}
\value{
Returns the value of the function evaluated at \code{x}.
+
}
\references{
+
Abramowitz, M. and Stegun, I. A. (1972)
\emph{Handbook of Mathematical Functions with Formulas,
Graphs, and Mathematical Tables},
New York: Dover Publications Inc.
+
}
\author{ T. W. Yee}
\note{
Some authors omit the term \eqn{2/\sqrt{\pi}}{2/sqrt(pi)} from the
definition of \eqn{Erf(x)}. Although defined for complex
- arguments, this function only works for real
- arguments.
+ arguments, this function only works for real arguments.
The \emph{complementary error function} \eqn{erfc(x)} is defined
as \eqn{1-erf(x)}, and is implemented by \code{erfc}.
+
}
\seealso{
\code{\link[stats:Normal]{pnorm}}.
+
}
\examples{
\dontrun{
-x = seq(-3, 3, len=200)
-plot(x, erf(x), type="l", col="red", las=1, lwd=2,
- main="red is erf(x), blue is pnorm(x)")
-abline(v=0, h=0, lty="dashed", col="black")
-lines(x, pnorm(x), col="blue", lty="dotted", lwd=2)
-}
+curve(erf, -3, 3, col="red", ylab="", las=1)
+curve(pnorm, -3, 3, add=TRUE, col="blue", lty="dotted", lwd=2)
+abline(v=0, h=0, lty="dashed")
+legend("topleft", c("erf(x)", "pnorm(x)"), col=c("red", "blue"),
+ lty=c("solid", "dotted"), lwd=1:2) }
}
\keyword{math}
diff --git a/man/erlang.Rd b/man/erlang.Rd
index f8449de..20ced3e 100644
--- a/man/erlang.Rd
+++ b/man/erlang.Rd
@@ -83,13 +83,14 @@ New York: Wiley-Interscience, Third edition.
\seealso{
\code{\link{gamma2.ab}},
\code{\link{exponential}}.
+
}
\examples{
-n = 200; rate = 8
-y = rep(0, n)
-for(i in 1:3)
- y = y + rexp(n, rate=rate)
-fit = vglm(y ~ 1, erlang(shape=3), trace=TRUE)
+rate = exp(2); myshape = 3
+edata = data.frame(y = rep(0, nn <- 1000))
+for(ii in 1:myshape)
+ edata = transform(edata, y = y + rexp(nn, rate=rate))
+fit = vglm(y ~ 1, erlang(shape=myshape), edata, trace=TRUE)
coef(fit, matrix=TRUE)
Coef(fit) # Answer = 1/rate
1/rate
diff --git a/man/expexp.Rd b/man/expexp.Rd
index 09cb265..f11fe48 100644
--- a/man/expexp.Rd
+++ b/man/expexp.Rd
@@ -8,10 +8,8 @@
}
\usage{
-expexp(lshape = "loge", lscale = "loge",
- eshape=list(), escale=list(),
- ishape = 1.1, iscale = NULL,
- tolerance = 1.0e-6, zero = NULL)
+expexp(lshape = "loge", lscale = "loge", eshape=list(), escale=list(),
+ ishape = 1.1, iscale = NULL, tolerance = 1.0e-6, zero = NULL)
}
%- maybe also 'usage' for other objects documented here.
\arguments{
diff --git a/man/expexp1.Rd b/man/expexp1.Rd
index 4ceb407..0bf7692 100644
--- a/man/expexp1.Rd
+++ b/man/expexp1.Rd
@@ -87,11 +87,11 @@ expexp1(lscale = "loge", escale=list(), iscale = NULL, ishape = 1)
}
\examples{
# Ball bearings data (number of million revolutions before failure)
-bbearings = c(17.88, 28.92, 33.00, 41.52, 42.12, 45.60,
+bbearings = data.frame(y = c(17.88, 28.92, 33.00, 41.52, 42.12, 45.60,
48.80, 51.84, 51.96, 54.12, 55.56, 67.80, 68.64, 68.64,
68.88, 84.12, 93.12, 98.64, 105.12, 105.84, 127.92,
-128.04, 173.40)
-fit = vglm(bbearings ~ 1, expexp1(ishape=4), trace=TRUE,
+128.04, 173.40))
+fit = vglm(y ~ 1, expexp1(ishape=4), bbearings, trace=TRUE,
maxit=50, checkwz=FALSE)
coef(fit, matrix=TRUE)
Coef(fit) # Authors get c(0.0314, 5.2589) with log-lik -112.9763
@@ -100,10 +100,10 @@ logLik(fit)
# Failure times of the airconditioning system of an airplane
-acplane = c(23, 261, 87, 7, 120, 14, 62, 47,
+acplane = data.frame(y = c(23, 261, 87, 7, 120, 14, 62, 47,
225, 71, 246, 21, 42, 20, 5, 12, 120, 11, 3, 14,
-71, 11, 14, 11, 16, 90, 1, 16, 52, 95)
-fit = vglm(acplane ~ 1, expexp1(ishape=0.8), trace=TRUE,
+71, 11, 14, 11, 16, 90, 1, 16, 52, 95))
+fit = vglm(y ~ 1, expexp1(ishape=0.8), acplane, trace=TRUE,
maxit=50, checkwz=FALSE)
coef(fit, matrix=TRUE)
Coef(fit) # Authors get c(0.0145, 0.8130) with log-lik -152.264
diff --git a/man/exponential.Rd b/man/exponential.Rd
index dc0a026..107c2e2 100644
--- a/man/exponential.Rd
+++ b/man/exponential.Rd
@@ -72,22 +72,20 @@ New York: Wiley-Interscience, Third edition.
\code{\link{poissonff}},
\code{\link{mix2exp}},
\code{\link{freund61}}.
+
}
\examples{
-nn = 100
-x1 = runif(nn) - 0.5
-x2 = runif(nn) - 0.5
-eta = 0.2 - 0.7 * x1 + 1.9 * x2
-rate = exp(eta)
-y = rexp(nn, rate=rate)
-stem(y)
-fit = vglm(y ~ x1 + x2, exponential, trace=TRUE, crit="c") # slower
-fit = vglm(y ~ x1 + x2, exponential(exp=FALSE), trace=TRUE, crit="c") # faster
-coef(fit)
-coef(fit, mat=TRUE)
-Coef(fit)
-summary(fit)
+edata = data.frame(x2 = runif(nn <- 100) - 0.5)
+edata = transform(edata, x3 = runif(nn) - 0.5)
+edata = transform(edata, eta = 0.2 - 0.7 * x2 + 1.9 * x3)
+edata = transform(edata, rate = exp(eta))
+edata = transform(edata, y = rexp(nn, rate=rate))
+with(edata, stem(y))
+fit.slow = vglm(y ~ x2 + x3, exponential, edata, trace=TRUE, crit="c")
+fit.fast = vglm(y ~ x2 + x3, exponential(exp=FALSE), edata, trace=TRUE, crit="c")
+coef(fit.slow, mat=TRUE)
+summary(fit.slow)
}
\keyword{models}
\keyword{regression}
diff --git a/man/felix.Rd b/man/felix.Rd
index bf9a09e..3bc4f03 100644
--- a/man/felix.Rd
+++ b/man/felix.Rd
@@ -62,8 +62,8 @@ Boston: Birkhauser.
}
\examples{
-y = 2*rpois(n <- 200, 1) + 1 # Not real data!
-fit = vglm(y ~ 1, felix, trace=TRUE, crit="c")
+fdata = data.frame(y = 2*rpois(n=200, 1) + 1) # Not real data!
+fit = vglm(y ~ 1, felix, fdata, trace=TRUE, crit="c")
coef(fit, matrix=TRUE)
Coef(fit)
summary(fit)
diff --git a/man/fff.Rd b/man/fff.Rd
index bfb857e..6276f7c 100644
--- a/man/fff.Rd
+++ b/man/fff.Rd
@@ -6,7 +6,7 @@
Maximum likelihood estimation of the (2-parameter) F distribution.
}
\usage{
-fff(link="loge", earg=list(), idf1=NULL, idf2=NULL,
+fff(link="loge", earg=list(), idf1=NULL, idf2=NULL, nsimEIM=100,
method.init=1, zero=NULL)
}
%- maybe also 'usage' for other objects documented here.
@@ -28,6 +28,10 @@ fff(link="loge", earg=list(), idf1=NULL, idf2=NULL,
The default is to choose each value internally.
}
+ \item{nsimEIM}{
+ See \code{\link{CommonVGAMffArguments}} for more information.
+
+ }
\item{method.init}{
Initialization method. Either the value 1 or 2.
If both fail try setting values for \code{idf1} and \code{idf2}.
@@ -49,17 +53,22 @@ fff(link="loge", earg=list(), idf1=NULL, idf2=NULL,
This function treats these degrees of freedom as \emph{positive reals}
rather than integers.
The mean of the distribution is
- \eqn{df2/(df2-2)} provided \eqn{df2>2}, and its variance is
+ \eqn{df2/(df2-2)} provided \eqn{df2>2},
+ and its variance is
\eqn{2 df2^2 (df1+df2-2)/(df1 (df2-2)^2 (df2-4))}{2*df2^2*(df1+df2-2)/
(df1*(df2-2)^2*(df2-4))} provided \eqn{df2>4}.
The estimated mean is returned as the fitted values.
Although the F distribution can be defined to accommodate a
non-centrality parameter \code{ncp}, it is assumed zero here.
+ Actually it shouldn't be too difficult to handle any known \code{ncp}; something
+ to do in the short future.
+
}
\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{
Evans, M., Hastings, N. and Peacock, B. (2000)
@@ -70,44 +79,31 @@ New York: Wiley-Interscience, Third edition.
\author{ T. W. Yee }
\section{Warning}{
Numerical problems will occur when the estimates of the parameters
- are too low.
-}
-
-\note{
- This family function uses the BFGS quasi-Newton update formula for the
- working weight matrices. Consequently the estimated variance-covariance
- matrix may be inaccurate or simply wrong! The standard errors must be
- therefore treated with caution; these are computed in functions such
- as \code{vcov()} and \code{summary()}.
+ are too low or too high.
}
+
+%\note{
+% This family function uses the BFGS quasi-Newton update formula for the
+% working weight matrices. Consequently the estimated variance-covariance
+% matrix may be inaccurate or simply wrong! The standard errors must be
+% therefore treated with caution; these are computed in functions such
+% as \code{vcov()} and \code{summary()}.
+%
+%}
\seealso{
\code{\link[stats:Fdist]{FDist}}.
}
\examples{
-x = runif(n <- 4000)
+x = runif(n <- 2000)
df1 = exp(2+0.5*x)
df2 = exp(2-0.5*x)
y = rf(n, df1, df2)
fit = vglm(y ~ x, fff, trace=TRUE)
-fit = vglm(y ~ x, fff(link="logoff", earg=list(offset=0.5)), trace=TRUE)
coef(fit, matrix=TRUE)
-Coef(fit)
-vcov(fit) # caution needed!
}
\keyword{models}
\keyword{regression}
-%# Another simpler example
-%set.seed(123)
-%df1 = exp(2)
-%df2 = exp(2)
-%y = rf(n <- 1000, df1, df2)
-%fit1 = vglm(y ~ 1, fff, trace=TRUE)
-%fit2 = vglm(y ~ 1, fff(link="logoff", earg=list(offset=0.5)), trace=TRUE)
-%vcov(fit1) # caution needed!
-%vcov(fit2) # caution needed!
-
-
diff --git a/man/fgm.Rd b/man/fgm.Rd
index fe98313..7d8254d 100644
--- a/man/fgm.Rd
+++ b/man/fgm.Rd
@@ -9,8 +9,7 @@
}
\usage{
-fgm(lapar="rhobit", earg=list(), iapar=NULL,
- method.init=1, nsimEIM=200)
+fgm(lapar="rhobit", earg=list(), iapar=NULL, method.init=1, nsimEIM=200)
}
%- maybe also 'usage' for other objects documented here.
\arguments{
diff --git a/man/fisk.Rd b/man/fisk.Rd
index 4b941d0..5bd85a9 100644
--- a/man/fisk.Rd
+++ b/man/fisk.Rd
@@ -7,9 +7,8 @@
Fisk distribution.
}
\usage{
-fisk(link.a = "loge", link.scale = "loge",
- earg.a=list(), earg.scale=list(),
- init.a = NULL, init.scale = NULL, zero = NULL)
+fisk(link.a = "loge", link.scale = "loge", earg.a=list(),
+ earg.scale=list(), init.a = NULL, init.scale = NULL, zero = NULL)
}
%- maybe also 'usage' for other objects documented here.
\arguments{
diff --git a/man/fnormal1.Rd b/man/fnormal1.Rd
index fdf86ae..fa86f07 100644
--- a/man/fnormal1.Rd
+++ b/man/fnormal1.Rd
@@ -6,14 +6,11 @@
Fits a (generalized) folded (univariate) normal distribution.
}
\usage{
-fnormal1(lmean="identity", lsd="loge", emean=list(), esd=list(),
- imean=NULL, isd=NULL, a1=1, a2=1, nsimEIM=500,
- method.init=1, zero=NULL)
+fnormal1(lmean="identity", lsd="loge", emean=list(), esd=list(), imean=NULL,
+ isd=NULL, a1=1, a2=1, nsimEIM=500, method.init=1, zero=NULL)
}
%- maybe also 'usage' for other objects documented here.
\arguments{
- See \code{\link{CommonVGAMffArguments}} for general information about
- many of these arguments.
\item{lmean, lsd}{
Link functions for the mean and standard
@@ -48,6 +45,7 @@ fnormal1(lmean="identity", lsd="loge", emean=list(), esd=list(),
normal distribution}. That is, the sign has not been recorded; only
the magnitude has been measured.
+
More generally, suppose \eqn{X} is normal with mean \code{mean} and
standard deviation \code{sd}.
Let \eqn{Y=\max(a_1 X, -a_2 X)}{Y=max(a1*X, -a2*X)}
@@ -58,6 +56,7 @@ fnormal1(lmean="identity", lsd="loge", emean=list(), esd=list(),
The ordinary folded normal distribution corresponds to the
special case \eqn{a_1 = a_2 = 1}{a1 = a2 = 1}.
+
The probability density function of the ordinary folded normal distribution
can be written
\code{dnorm(y, mean, sd) + dnorm(y, -mean, sd)} for
@@ -75,6 +74,7 @@ fnormal1(lmean="identity", lsd="loge", emean=list(), esd=list(),
Here, \eqn{\Phi()}{Phi} is the cumulative distribution function of a
standard normal (\code{\link[stats:Normal]{pnorm}}).
+
}
\value{
An object of class \code{"vglmff"} (see \code{\link{vglmff-class}}).
@@ -97,6 +97,10 @@ fnormal1(lmean="identity", lsd="loge", emean=list(), esd=list(),
Reasonably good initial values are needed.
Fisher scoring using simulation is implemented.
+
+ See \code{\link{CommonVGAMffArguments}} for general information about
+ many of these arguments.
+
}
\section{Warning }{
diff --git a/man/frechet.Rd b/man/frechet.Rd
index 6d56d57..99570d5 100644
--- a/man/frechet.Rd
+++ b/man/frechet.Rd
@@ -10,11 +10,9 @@
}
\usage{
-frechet2(location=0, lscale="loge", lshape="loglog",
- escale = list(), eshape = list(),
- iscale=NULL, ishape=3, zero=NULL)
-frechet3(anchor=NULL, ldifference="loge",
- lscale="loge", lshape="loglog",
+frechet2(location=0, lscale="loge", lshape="loglog", escale = list(),
+ eshape = list(), iscale=NULL, ishape=3, zero=NULL)
+frechet3(anchor=NULL, ldifference="loge", lscale="loge", lshape="loglog",
edifference=list(), escale = list(), eshape = list(),
ilocation=NULL, iscale=NULL, ishape=3, zero=NULL,
effpos = .Machine$double.eps^0.75)
diff --git a/man/freund61.Rd b/man/freund61.Rd
index b8c1279..dd90243 100644
--- a/man/freund61.Rd
+++ b/man/freund61.Rd
@@ -9,9 +9,8 @@
}
\usage{
-freund61(la="loge", lap="loge", lb="loge", lbp="loge",
- ia=NULL, iap=NULL, ib=NULL, ibp=NULL,
- independent=FALSE, zero=NULL)
+freund61(la="loge", lap="loge", lb="loge", lbp="loge", ia=NULL, iap=NULL,
+ ib=NULL, ibp=NULL, independent=FALSE, zero=NULL)
}
%- maybe also 'usage' for other objects documented here.
\arguments{
@@ -174,7 +173,7 @@ summary(fit)
fit2 = vglm(ymat ~ 1, fam=freund61(indep=TRUE), trace=TRUE)
coef(fit2, matrix=TRUE)
constraints(fit2)
-1 - pchisq(2*(logLik(fit)-logLik(fit2)), df=2) # p-value
+pchisq(2*(logLik(fit)-logLik(fit2)), df=2, lower.tail=FALSE) # p-value
}
\keyword{models}
\keyword{regression}
diff --git a/man/fsqrt.Rd b/man/fsqrt.Rd
index afd22d1..61971c0 100644
--- a/man/fsqrt.Rd
+++ b/man/fsqrt.Rd
@@ -105,13 +105,13 @@ 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"
+ 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) {
+ 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)
@@ -124,13 +124,13 @@ for(d in 0) {
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"
+ 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) {
+ 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)
diff --git a/man/gamma1.Rd b/man/gamma1.Rd
index 163f420..acd9333 100644
--- a/man/gamma1.Rd
+++ b/man/gamma1.Rd
@@ -70,8 +70,8 @@ New York: Wiley-Interscience, Third edition.
}
\examples{
-y = rgamma(n=100, shape= exp(3))
-fit = vglm(y ~ 1, gamma1, trace=TRUE, crit="c")
+gdata = data.frame(y = rgamma(n=100, shape= exp(3)))
+fit = vglm(y ~ 1, gamma1, gdata, trace=TRUE, crit="c")
coef(fit, matrix=TRUE)
Coef(fit)
summary(fit)
diff --git a/man/gamma2.Rd b/man/gamma2.Rd
index 12a4f02..4d37ed6 100644
--- a/man/gamma2.Rd
+++ b/man/gamma2.Rd
@@ -8,10 +8,8 @@
}
\usage{
-gamma2(lmu = "loge", lshape = "loge",
- emu = list(), eshape = list(),
- method.init = 1, deviance.arg = FALSE,
- ishape = NULL, zero = -2)
+gamma2(lmu = "loge", lshape = "loge", emu = list(), eshape = list(),
+ method.init = 1, deviance.arg = FALSE, ishape = NULL, zero = -2)
}
%- maybe also 'usage' for other objects documented here.
\arguments{
@@ -149,18 +147,16 @@ McCullagh, P. and Nelder, J. A. (1989)
}
\examples{
# Essentially a 1-parameter gamma
-y = rgamma(n <- 100, shape= exp(1))
-fit1 = vglm(y ~ 1, gamma1, trace=TRUE, crit="c")
-fit2 = vglm(y ~ 1, gamma2, trace=TRUE, crit="c")
-coef(fit1, matrix=TRUE)
-Coef(fit1)
+gdata = data.frame(y = rgamma(n=100, shape= exp(1)))
+fit1 = vglm(y ~ 1, gamma1, gdata)
+fit2 = vglm(y ~ 1, gamma2, gdata, trace=TRUE, crit="c")
coef(fit2, matrix=TRUE)
Coef(fit2)
# Essentially a 2-parameter gamma
-y = rgamma(n <- 500, rate=exp(1), shape=exp(2))
-fit2 = vglm(y ~ 1, gamma2, trace=TRUE, crit="c")
+gdata = data.frame(y = rgamma(n=500, rate=exp(1), shape=exp(2)))
+fit2 = vglm(y ~ 1, gamma2, gdata, trace=TRUE, crit="c")
coef(fit2, matrix=TRUE)
Coef(fit2)
summary(fit2)
diff --git a/man/gamma2.ab.Rd b/man/gamma2.ab.Rd
index ee5aa0c..98f095c 100644
--- a/man/gamma2.ab.Rd
+++ b/man/gamma2.ab.Rd
@@ -6,8 +6,7 @@
by maximum likelihood estimation.
}
\usage{
-gamma2.ab(lrate = "loge", lshape = "loge",
- erate=list(), eshape=list(),
+gamma2.ab(lrate = "loge", lshape = "loge", erate=list(), eshape=list(),
irate=NULL, ishape=NULL, expected = TRUE, zero = 2)
}
%- maybe also 'usage' for other objects documented here.
@@ -103,18 +102,16 @@ gamma2.ab(lrate = "loge", lshape = "loge",
}
\examples{
# Essentially a 1-parameter gamma
-y = rgamma(n <- 100, shape= exp(1))
-fit1 = vglm(y ~ 1, gamma1, trace=TRUE, crit="c")
-fit2 = vglm(y ~ 1, gamma2.ab, trace=TRUE, crit="c")
-coef(fit1, matrix=TRUE)
-Coef(fit1)
+gdata = data.frame(y = rgamma(n <- 100, shape= exp(1)))
+fit1 = vglm(y ~ 1, gamma1, gdata, trace=TRUE)
+fit2 = vglm(y ~ 1, gamma2.ab, gdata, trace=TRUE, crit="c")
coef(fit2, matrix=TRUE)
Coef(fit2)
# Essentially a 2-parameter gamma
-y = rgamma(n <- 500, rate=exp(1), shape=exp(2))
-fit2 = vglm(y ~ 1, gamma2.ab, trace=TRUE, crit="c")
+gdata = data.frame(y = rgamma(n=500, rate=exp(1), shape=exp(2)))
+fit2 = vglm(y ~ 1, gamma2.ab, gdata, trace=TRUE, crit="c")
coef(fit2, matrix=TRUE)
Coef(fit2)
summary(fit2)
diff --git a/man/gammahyp.Rd b/man/gammahyp.Rd
index ebaed2c..3fa60fd 100644
--- a/man/gammahyp.Rd
+++ b/man/gammahyp.Rd
@@ -69,12 +69,12 @@ Asymptotics and the theory of inference.
\code{\link{exponential}}.
}
\examples{
-x = runif(n <- 1000)
-theta = exp(-2+x)
-y1 = rexp(n, rate=exp(-theta)/theta)
-y2 = 1 + rexp(n, rate=theta)
-fit = vglm(cbind(y1,y2) ~ x, fam=gammahyp(expected=TRUE), trace=TRUE)
-fit = vglm(cbind(y1,y2) ~ x, fam=gammahyp, trace=TRUE, crit="coef")
+gdata = data.frame(x = runif(nn <- 1000))
+gdata = transform(gdata, theta = exp(-2+x))
+gdata = transform(gdata, y1 = rexp(nn, rate=exp(-theta)/theta),
+ y2 = rexp(nn, rate=theta) + 1)
+fit = vglm(cbind(y1,y2) ~ x, fam=gammahyp(expected=TRUE), gdata)
+fit = vglm(cbind(y1,y2) ~ x, fam=gammahyp, gdata, trace=TRUE, crit="coef")
coef(fit, matrix=TRUE)
Coef(fit)
head(fitted(fit))
diff --git a/man/garma.Rd b/man/garma.Rd
index f8b313e..888ce10 100644
--- a/man/garma.Rd
+++ b/man/garma.Rd
@@ -6,20 +6,16 @@
Fits GARMA models to time series data.
}
\usage{
-garma(link = c("identity", "loge", "reciprocal",
- "logit", "probit", "cloglog", "cauchit"),
- earg=list(),
- p.ar.lag = 1, q.lag.ma = 0,
+garma(link = "identity", earg=list(), p.ar.lag = 1, q.lag.ma = 0,
coefstart = NULL, step = 1)
}
%- maybe also 'usage' for other objects documented here.
\arguments{
\item{link}{
Link function applied to the mean response.
- By default, the first choice is used, which is suitable for
- continuous responses.
+ The default is suitable for continuous responses.
The link \code{\link{loge}} should be chosen if the data are counts.
- The links \code{\link{logit}}, \code{\link{probit}},
+ Links such as \code{\link{logit}}, \code{\link{probit}},
\code{\link{cloglog}},
\code{\link{cauchit}} are suitable for binary responses.
@@ -177,7 +173,7 @@ interspike = c(68, 41, 82, 66, 101, 66, 57, 41, 27, 78,
spikenum = seq(interspike)
bvalue = 0.1 # .Machine$double.xmin # Boundary value
fit = vglm(interspike ~ 1, trace=TRUE,
- garma("loge", earg=list(bvalue=bvalue), p=2, coef=c(4,.3,.4)))
+ garma("loge", earg=list(bvalue=bvalue), p=2, coef=c(4,.3,.4)))
summary(fit)
coef(fit, matrix=TRUE)
Coef(fit) # A bug here
diff --git a/man/gaussianff.Rd b/man/gaussianff.Rd
index 632ba7d..866f49d 100644
--- a/man/gaussianff.Rd
+++ b/man/gaussianff.Rd
@@ -120,16 +120,16 @@ gaussianff(dispersion = 0, parallel = FALSE, zero = NULL)
}
\examples{
-d = data.frame(x = sort(runif(n <- 40)))
-d = transform(d, y1 = 1 + 2*x + rnorm(n, sd=0.1),
- y2 = 3 + 4*x + rnorm(n, sd=0.1),
- y3 = 7 + 4*x + rnorm(n, sd=0.1))
-fit = vglm(cbind(y1,y2) ~ x, gaussianff, data=d)
+mydat = data.frame(x = sort(runif(n <- 40)))
+mydat = transform(mydat, y1 = 1 + 2*x + rnorm(n, sd=0.1),
+ y2 = 3 + 4*x + rnorm(n, sd=0.1),
+ y3 = 7 + 4*x + rnorm(n, sd=0.1))
+fit = vglm(cbind(y1,y2) ~ x, gaussianff, data=mydat)
coef(fit, matrix=TRUE)
# For comparison:
-coef( lmfit <- lm(y1 ~ x, data=d))
-coef(glmfit <- glm(y2 ~ x, data=d, gaussian))
+coef( lmfit <- lm(y1 ~ x, data=mydat))
+coef(glmfit <- glm(y2 ~ x, data=mydat, gaussian))
vcov(fit)
vcov(lmfit)
@@ -137,7 +137,7 @@ t(weights(fit, type="prior")) # Unweighted observations
head(weights(fit, type="working")) # Identity matrices
# Reduced-rank VLM (rank-1)
-fit2 = rrvglm(cbind(y1,y2,y3) ~ x, gaussianff, data=d)
+fit2 = rrvglm(cbind(y1,y2,y3) ~ x, gaussianff, data=mydat)
Coef(fit2)
}
\keyword{models}
diff --git a/man/genbetaII.Rd b/man/genbetaII.Rd
index 2f560d3..c7c141d 100644
--- a/man/genbetaII.Rd
+++ b/man/genbetaII.Rd
@@ -117,10 +117,10 @@ More improvements could be made here.
}
\examples{
-y = rsinmad(n=3000, 4, 6, 2) # Not very good data!
-fit = vglm(y ~ 1, genbetaII, trace=TRUE)
+gdata = data.frame(y = rsinmad(n=3000, 4, 6, 2)) # Not very good data!
+fit = vglm(y ~ 1, genbetaII, gdata, trace=TRUE)
fit = vglm(y ~ 1, genbetaII(init.p=1.0, init.a=4, init.sc=7, init.q=2.3),
- trace=TRUE, crit="c")
+ gdata, trace=TRUE, crit="c")
coef(fit, mat=TRUE)
Coef(fit)
summary(fit)
diff --git a/man/genpoisson.Rd b/man/genpoisson.Rd
index 63fa548..3186a36 100644
--- a/man/genpoisson.Rd
+++ b/man/genpoisson.Rd
@@ -109,12 +109,14 @@ New York: Marcel Dekker.
}
\examples{
-n = 200
-x = runif(n)
-y = rpois(n, lam=exp(2-x))
-fit = vglm(y ~ x, genpoisson(zero=1), trace=TRUE)
+gdata = data.frame(x = runif(nn <- 200))
+gdata = transform(gdata, y = rpois(nn, exp(2-x))) # Ordinary Poisson data
+fit = vglm(y ~ x, genpoisson(zero=1), gdata, trace=TRUE)
coef(fit, matrix=TRUE)
summary(fit)
}
\keyword{models}
\keyword{regression}
+
+% yettodo: see csda 2009, 53(9): 3478--3489.
+
diff --git a/man/geometric.Rd b/man/geometric.Rd
index f1d9963..ce0c55a 100644
--- a/man/geometric.Rd
+++ b/man/geometric.Rd
@@ -6,7 +6,7 @@
Maximum likelihood estimation for the geometric distribution.
}
\usage{
-geometric(link = "logit", earg=list(), expected = TRUE)
+geometric(link = "logit", earg=list(), expected = TRUE, method.init = 1)
}
%- maybe also 'usage' for other objects documented here.
\arguments{
@@ -26,6 +26,13 @@ geometric(link = "logit", earg=list(), expected = TRUE)
Fisher scoring is used if \code{expected = TRUE}, else Newton-Raphson.
}
+ \item{method.init}{
+ An integer with value \code{1} or \code{2} or \code{3} which
+ specifies the initialization method for the probability.
+ If failure to converge occurs try another value.
+
+ }
+
}
\details{
A random variable \eqn{Y} has a 1-parameter geometric distribution
@@ -63,17 +70,17 @@ geometric(link = "logit", earg=list(), expected = TRUE)
\code{\link[stats]{Geometric}},
\code{\link{betageometric}},
\code{\link{rbetageom}}.
+
}
\examples{
-x1 = runif(n <- 1000) - 0.5
-x2 = runif(n) - 0.5
-x3 = runif(n) - 0.5
-eta = 0.2 - 0.7 * x1 + 1.9 * x2
-prob = logit(eta, inverse=TRUE)
-y = rgeom(n, prob)
-table(y)
-fit = vglm(y ~ x1 + x2 + x3, geometric, trace=TRUE, crit="coef")
-coef(fit)
+gdata = data.frame(x2 = runif(nn <- 1000) - 0.5)
+gdata = transform(gdata, x3 = runif(nn) - 0.5,
+ x4 = runif(nn) - 0.5)
+gdata = transform(gdata, eta = 1.0 - 1.0 * x2 + 2.0 * x3)
+gdata = transform(gdata, prob = logit(eta, inverse=TRUE))
+gdata = transform(gdata, y = rgeom(nn, prob))
+with(gdata, table(y))
+fit = vglm(y ~ x2 + x3 + x4, geometric, gdata, trace=TRUE)
coef(fit, mat=TRUE)
summary(fit)
}
diff --git a/man/gev.Rd b/man/gev.Rd
index 552ebc0..59192db 100644
--- a/man/gev.Rd
+++ b/man/gev.Rd
@@ -11,15 +11,15 @@
\usage{
gev(llocation = "identity", lscale = "loge", lshape = "logoff",
elocation = list(), escale = list(),
- eshape = if(lshape=="logoff") list(offset=0.5) else
- if(lshape=="elogit") list(min=-0.5, max=0.5) else list(),
+ eshape = if (lshape=="logoff") list(offset=0.5) else
+ if (lshape=="elogit") list(min=-0.5, max=0.5) else list(),
percentiles = c(95, 99), iscale=NULL, ishape = NULL,
method.init = 1, gshape=c(-0.45, 0.45), tolshape0=0.001,
giveWarning=TRUE, zero = 3)
egev(llocation = "identity", lscale = "loge", lshape = "logoff",
elocation = list(), escale = list(),
- eshape = if(lshape=="logoff") list(offset=0.5) else
- if(lshape=="elogit") list(min=-0.5, max=0.5) else list(),
+ eshape = if (lshape=="logoff") list(offset=0.5) else
+ if (lshape=="elogit") list(min=-0.5, max=0.5) else list(),
percentiles = c(95, 99), iscale=NULL, ishape = NULL,
method.init=1, gshape=c(-0.45, 0.45), tolshape0=0.001,
giveWarning=TRUE, zero = 3)
@@ -179,6 +179,7 @@ egev(llocation = "identity", lscale = "loge", lshape = "logoff",
An object of class \code{"vglmff"} (see \code{\link{vglmff-class}}).
The object is used by modelling functions such as \code{\link{vglm}},
and \code{\link{vgam}}.
+
}
\references{
Yee, T. W. and Stephenson, A. G. (2007)
@@ -242,8 +243,7 @@ egev(llocation = "identity", lscale = "loge", lshape = "logoff",
\examples{
# Multivariate example
-y = as.matrix(venice[,paste("r", 1:10, sep="")])
-fit1 = vgam(y[,1:2] ~ s(year, df=3), gev(zero=2:3), venice, trace=TRUE)
+fit1 = vgam(cbind(r1,r2) ~ s(year, df=3), gev(zero=2:3), venice, trace=TRUE)
coef(fit1, matrix=TRUE)
head(fitted(fit1))
\dontrun{
@@ -253,12 +253,11 @@ plot(fit1, se=TRUE, lcol="blue", scol="forestgreen",
with(venice, matplot(year, y[,1:2], ylab="Sea level (cm)", col=1:2,
main="Highest 2 annual sea levels", cex.main=0.8))
with(venice, lines(year, fitted(fit1)[,1], lty="dashed", col="blue"))
-legend("topleft", lty="dashed", col="blue", "Fitted 95 percentile")
-}
+legend("topleft", lty="dashed", col="blue", "Fitted 95 percentile") }
# Univariate example
-(fit = vglm(maxtemp ~ 1, egev, data=oxtemp, trace=TRUE))
+(fit = vglm(maxtemp ~ 1, egev, oxtemp, trace=TRUE))
head(fitted(fit))
coef(fit, mat=TRUE)
Coef(fit)
diff --git a/man/ggamma.Rd b/man/ggamma.Rd
index 6e08fd5..8518ee0 100644
--- a/man/ggamma.Rd
+++ b/man/ggamma.Rd
@@ -113,19 +113,17 @@ Rayleigh \eqn{f(y;c\sqrt{2},2,1)}{f(y;c sqrt(2),2,1)} where \eqn{c>0}.
}
\examples{
-k = exp(-1)
-Scale = exp(1)
-y = rgamma(n=1000, shape=k, scale=Scale)
-fit = vglm(y ~ 1, ggamma, trace=TRUE)
+k = exp(-1); Scale = exp(1)
+gdata = data.frame(y = rgamma(n=1000, shape=k, scale=Scale))
+fit = vglm(y ~ 1, ggamma, gdata, trace=TRUE)
coef(fit, matrix=TRUE)
# Another example
-x = runif(n <- 5000)
-Scale = exp(1)
-d = exp(0 + 1.2*x)
-k = exp(-1 + 2*x)
-y = rggamma(n, scale=Scale, d=d, k=k)
-fit = vglm(y ~ x, ggamma(zero=1, iscal=6), trace=TRUE)
+gdata = data.frame(x = runif(nn <- 5000))
+gdata = transform(gdata, Scale = exp(1), d = exp(0 + 1.2*x), k = exp(-1 + 2*x))
+gdata = transform(gdata, y = rggamma(nn, scale=Scale, d=d, k=k))
+fit = vglm(y ~ x, ggamma(zero=1, iscal=6), gdata, trace=TRUE)
+fit = vglm(y ~ x, ggamma(zero=1), gdata, trace=TRUE, maxit=50)
coef(fit, matrix=TRUE)
}
\keyword{models}
diff --git a/man/golf.Rd b/man/golf.Rd
index 2d93dac..365ce4e 100644
--- a/man/golf.Rd
+++ b/man/golf.Rd
@@ -129,23 +129,21 @@ plot(p, y., type="l", col="blue",
# Another example
-nn = 1000
-x2 = sort(runif(nn))
-x3 = runif(nn)
-mymu = exp( 3 + 1 * x2 - 2 * x3)
+gdata = data.frame(x2 = sort(runif(nn <- 1000)))
+gdata = transform(gdata, x3 = runif(nn))
+gdata = transform(gdata, mymu = exp( 3 + 1 * x2 - 2 * x3))
lambda = 4
-y1 = rgamma(nn, shape=lambda, scale=mymu/lambda)
+gdata = transform(gdata, y1 = rgamma(nn, shape=lambda, scale=mymu/lambda))
cutpoints = c(-Inf, 10, 20, Inf)
-cuty = Cut(y1, breaks=cutpoints)
+gdata = transform(gdata, cuty = Cut(y1, breaks=cutpoints))
\dontrun{
par(mfrow=c(1,1), las=1)
-plot(x2, x3, col=cuty, pch=as.character(cuty))
-}
-table(cuty) / sum(table(cuty))
+with(gdata, plot(x2, x3, col=cuty, pch=as.character(cuty))) }
+with(gdata, table(cuty) / sum(table(cuty)))
fit = vglm(cuty ~ x2 + x3, fam = cumulative(link="golf",
reverse=TRUE, parallel=TRUE, intercept.apply=TRUE,
mv=TRUE, earg=list(cutpoint=cutpoints[2:3], lambda=lambda)),
- trace=TRUE)
+ gdata, trace=TRUE)
head(fit at y)
head(fitted(fit))
head(predict(fit))
diff --git a/man/gpd.Rd b/man/gpd.Rd
index 38838df..dbbc92e 100644
--- a/man/gpd.Rd
+++ b/man/gpd.Rd
@@ -8,10 +8,9 @@
}
\usage{
-gpd(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,
+gpd(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, method.init=1, zero=2)
}
@@ -215,8 +214,8 @@ gpd(threshold = 0, lscale = "loge", lshape = "logoff",
\examples{
# Simulated data from an exponential distribution (xi=0)
threshold = 0.5
-y = threshold + rexp(n=3000, rate=2)
-fit = vglm(y ~ 1, gpd(threshold=threshold), trace=TRUE)
+gdata = data.frame(y = threshold + rexp(n=3000, rate=2))
+fit = vglm(y ~ 1, gpd(threshold=threshold), gdata, trace=TRUE)
head(fitted(fit))
coef(fit, matrix=TRUE) # xi should be close to 0
Coef(fit)
@@ -225,36 +224,34 @@ summary(fit)
fit at extra$threshold # Note the threshold is stored here
# Check the 90 percentile
-i = fit at y < fitted(fit)[1,"90\%"]
-100*table(i)/sum(table(i)) # Should be 90%
+ii = fit at y < fitted(fit)[1,"90\%"]
+100*table(ii)/sum(table(ii)) # Should be 90%
# Check the 95 percentile
-i = fit at y < fitted(fit)[1,"95\%"]
-100*table(i)/sum(table(i)) # Should be 95%
+ii = fit at y < fitted(fit)[1,"95\%"]
+100*table(ii)/sum(table(ii)) # Should be 95%
\dontrun{
plot(fit at y, col="blue", las=1, main="Fitted 90\% and 95\% quantiles")
-matlines(1:length(fit at y), fitted(fit), lty=2:3, lwd=2)
-}
+matlines(1:length(fit at y), fitted(fit), lty=2:3, lwd=2) }
# Another example
-nn = 2000; threshold = 0; x = runif(nn)
+threshold = 0
+gdata = data.frame(x = runif(nn <- 2000))
xi = exp(-0.8)-0.5
-y = rgpd(nn, scale=exp(1+0.2*x), shape=xi)
-fit = vglm(y ~ x, gpd(threshold), trace=TRUE)
+gdata = transform(gdata, y = rgpd(nn, scale=exp(1+0.1*x), shape=xi))
+fit = vglm(y ~ x, gpd(threshold), gdata, trace=TRUE)
coef(fit, matrix=TRUE)
-\dontrun{
-# Nonparametric fits
-yy = y + rnorm(nn, sd=0.1)
-fit1 = vgam(yy ~ s(x), gpd(threshold), trace=TRUE) # Not so recommended
+\dontrun{ # Nonparametric fits
+gdata = transform(gdata, yy = y + rnorm(nn, sd=0.1))
+fit1 = vgam(yy ~ s(x), gpd(threshold), gdata, trace=TRUE) # Not so recommended
par(mfrow=c(2,1))
-plot(fit1, se=TRUE, scol="blue")
-fit2 = vglm(yy ~ bs(x), gpd(threshold), trace=TRUE) # More recommended
-plotvgam(fit2, se=TRUE, scol="blue")
-}
+plotvgam(fit1, se=TRUE, scol="blue")
+fit2 = vglm(yy ~ bs(x), gpd(threshold), gdata, trace=TRUE) # More recommended
+plotvgam(fit2, se=TRUE, scol="blue") }
}
\keyword{models}
\keyword{regression}
diff --git a/man/gumbel.Rd b/man/gumbel.Rd
index 9eff7c3..d803997 100644
--- a/man/gumbel.Rd
+++ b/man/gumbel.Rd
@@ -9,14 +9,12 @@
}
\usage{
-gumbel(llocation = "identity", lscale = "loge",
- elocation = list(), escale = list(),
- iscale = NULL, R = NA, percentiles = c(95, 99), mpv = FALSE,
- zero = NULL)
-egumbel(llocation = "identity", lscale = "loge",
- elocation = list(), escale = list(),
- iscale = NULL, R = NA, percentiles = c(95, 99), mpv = FALSE,
- zero = NULL)
+gumbel(llocation = "identity", lscale = "loge", elocation = list(),
+ escale = list(), iscale = NULL, R = NA, percentiles = c(95, 99),
+ mpv = FALSE, zero = NULL)
+egumbel(llocation = "identity", lscale = "loge", elocation = list(),
+ escale = list(), iscale = NULL, R = NA, percentiles = c(95, 99),
+ mpv = FALSE, zero = NULL)
}
%- maybe also 'usage' for other objects documented here.
\arguments{
@@ -183,17 +181,17 @@ egumbel(llocation = "identity", lscale = "loge",
\examples{
# Example 1: Simulated data
-y = rgumbel(n=1000, loc = 100, scale=exp(1))
-fit = vglm(y ~ 1, egumbel(perc=NULL), trace=TRUE)
+gdata = data.frame(y = rgumbel(n=1000, loc = 100, scale=exp(1)))
+fit = vglm(y ~ 1, egumbel(perc=NULL), gdata, trace=TRUE)
coef(fit, matrix=TRUE)
Coef(fit)
head(fitted(fit))
-mean(y)
+with(gdata, mean(y))
# Example 2: Venice data
(fit = vglm(cbind(r1,r2,r3,r4,r5) ~ year, data=venice,
- gumbel(R=365, mpv=TRUE), trace=TRUE))
+ gumbel(R=365, mpv=TRUE), trace=TRUE))
head(fitted(fit))
coef(fit, mat=TRUE)
vcov(summary(fit))
diff --git a/man/gumbelIbiv.Rd b/man/gumbelIbiv.Rd
index a1a6ff2..25899e2 100644
--- a/man/gumbelIbiv.Rd
+++ b/man/gumbelIbiv.Rd
@@ -80,13 +80,13 @@ Hoboken, N.J.: Wiley-Interscience.
\seealso{
\code{\link{morgenstern}}.
+
}
\examples{
-n = 1000
-ymat = cbind(rexp(n), rexp(n))
-\dontrun{plot(ymat)}
-fit = vglm(ymat ~ 1, fam=gumbelIbiv, trace=TRUE)
-fit = vglm(ymat ~ 1, fam=gumbelIbiv, trace=TRUE, crit="coef")
+nn = 1000
+gdata = data.frame(y1 = rexp(nn), y2 = rexp(nn))
+\dontrun{with(gdata, plot(cbind(y1,y2)))}
+fit = vglm(cbind(y1,y2) ~ 1, fam=gumbelIbiv, gdata, trace=TRUE)
coef(fit, matrix=TRUE)
Coef(fit)
head(fitted(fit))
diff --git a/man/hspider.Rd b/man/hspider.Rd
index 00861d2..749c67f 100644
--- a/man/hspider.Rd
+++ b/man/hspider.Rd
@@ -58,14 +58,14 @@ str(hspider)
# Fit a rank-1 Poisson CQO
set.seed(111) # This leads to the global solution
hspider[,1:6]=scale(hspider[,1:6]) # Standardize the environmental variables
-p1 = cqo(cbind(Alopacce, Alopcune, Alopfabr, Arctlute, Arctperi, Auloalbi,
- Pardlugu, Pardmont, Pardnigr, Pardpull, Trocterr, Zoraspin) ~
- WaterCon + BareSand + FallTwig + CoveMoss + CoveHerb + ReflLux,
- fam = poissonff, data = hspider, Crow1posit=FALSE)
-nos = ncol(p1 at y)
-lvplot(p1, y=TRUE, lcol=1:nos, pch=1:nos, pcol=1:nos)
-Coef(p1)
-summary(p1)
+# vvv p1 = cqo(cbind(Alopacce, Alopcune, Alopfabr, Arctlute, Arctperi, Auloalbi,
+# vvv Pardlugu, Pardmont, Pardnigr, Pardpull, Trocterr, Zoraspin) ~
+# vvv WaterCon + BareSand + FallTwig + CoveMoss + CoveHerb + ReflLux,
+# vvv fam = poissonff, data = hspider, Crow1posit=FALSE)
+# vvv nos = ncol(p1 at y)
+# vvv lvplot(p1, y=TRUE, lcol=1:nos, pch=1:nos, pcol=1:nos)
+# vvv Coef(p1)
+# vvv summary(p1)
diff --git a/man/hzeta.Rd b/man/hzeta.Rd
index 61dfc16..58a8676 100644
--- a/man/hzeta.Rd
+++ b/man/hzeta.Rd
@@ -4,6 +4,7 @@
\title{ Haight's Zeta Family Function }
\description{
Estimating the parameter of Haight's Zeta function.
+
}
\usage{
hzeta(link = "loglog", earg=list(), ialpha = NULL, nsimEIM=100)
@@ -73,14 +74,15 @@ hzeta(link = "loglog", earg=list(), ialpha = NULL, nsimEIM=100)
\code{\link{zeta}},
\code{\link{zetaff}},
\code{\link{loglog}}.
+
}
\examples{
alpha = exp(exp(-0.1)) # The parameter
-y = rhzeta(n=1000, alpha) # Generate some hzeta random variates
-fit = vglm(y ~ 1, hzeta, trace = TRUE, crit="c")
-coef(fit, matrix=TRUE)
+hdata = data.frame(y = rhzeta(n = 1000, alpha))
+fit = vglm(y ~ 1, hzeta, hdata, trace = TRUE, crit = "c")
+coef(fit, matrix = TRUE)
Coef(fit) # Useful for intercept-only models; should be same as alpha
-c(mean(y), fitted(fit)[1,])
+c(with(hdata, mean(y)), head(fitted(fit), 1))
summary(fit)
}
\keyword{models}
diff --git a/man/hzetaUC.Rd b/man/hzetaUC.Rd
index 3822d8c..b4d8d6c 100644
--- a/man/hzetaUC.Rd
+++ b/man/hzetaUC.Rd
@@ -69,6 +69,7 @@ rhzeta(n, alpha)
\code{\link{hzeta}},
\code{\link{zeta}},
\code{\link{zetaff}}.
+
}
\examples{
dhzeta(1:20, 2.1)
diff --git a/man/iam.Rd b/man/iam.Rd
index 01d7c8d..2fa71e6 100644
--- a/man/iam.Rd
+++ b/man/iam.Rd
@@ -104,18 +104,14 @@ iam(j, k, M, hbw = M, both = FALSE, diagonal = TRUE)
iam(1, 2, M=3) # The 4th column represents element (1,2) of a 3x3 matrix
iam(NULL, NULL, M=3, both=TRUE) # Return the row and column indices
-
dirichlet()@weight
-
M = 4
temp1 = iam(NA, NA, M=M, both=TRUE)
mat1 = matrix(NA, M, M)
mat1[cbind(temp1$row, temp1$col)] = 1:length(temp1$row)
mat1 # More commonly used
-
-M = 4
temp2 = iam(NA, NA, M=M, both=TRUE, diagonal=FALSE)
mat2 = matrix(NA, M, M)
mat2[cbind(temp2$row, temp2$col)] = 1:length(temp2$row)
diff --git a/man/identity.Rd b/man/identity.Rd
index 1c25f30..e294679 100644
--- a/man/identity.Rd
+++ b/man/identity.Rd
@@ -89,6 +89,7 @@ nidentity(theta, earg = list(), inverse = FALSE, deriv = 0,
\code{\link{logit}},
\code{\link{probit}},
\code{\link{powl}}.
+
}
\examples{
identity((-5):5)
diff --git a/man/inv.gaussianff.Rd b/man/inv.gaussianff.Rd
index c7a287f..0e51810 100644
--- a/man/inv.gaussianff.Rd
+++ b/man/inv.gaussianff.Rd
@@ -8,8 +8,7 @@
}
\usage{
-inv.gaussianff(lmu="loge", llambda="loge",
- emu=list(), elambda=list(),
+inv.gaussianff(lmu="loge", llambda="loge", emu=list(), elambda=list(),
ilambda=1, zero=NULL)
}
%- maybe also 'usage' for other objects documented here.
diff --git a/man/invparalogistic.Rd b/man/invparalogistic.Rd
index 139af16..9bf5564 100644
--- a/man/invparalogistic.Rd
+++ b/man/invparalogistic.Rd
@@ -8,7 +8,7 @@
}
\usage{
invparalogistic(link.a = "loge", link.scale = "loge",
- earg.a=list(), earg.scale=list(),
+ earg.a=list(), earg.scale=list(),
init.a = 1, init.scale = NULL, zero = NULL)
}
%- maybe also 'usage' for other objects documented here.
diff --git a/man/kumar.Rd b/man/kumar.Rd
index 4371579..826e48a 100644
--- a/man/kumar.Rd
+++ b/man/kumar.Rd
@@ -8,9 +8,8 @@
}
\usage{
-kumar(lshape1="loge", lshape2="loge",
- eshape1=list(), eshape2=list(),
- ishape1=NULL, ishape2=NULL, nsimEIM=500, zero=NULL)
+kumar(lshape1 = "loge", lshape2 = "loge", eshape1 = list(), eshape2 = list(),
+ ishape1 = NULL, ishape2 = NULL, nsimEIM = 500, zero = NULL)
}
%- maybe also 'usage' for other objects documented here.
\arguments{
@@ -36,7 +35,7 @@ kumar(lshape1="loge", lshape2="loge",
}
\details{
The Kumaraswamy distribution has density function
- \deqn{f(y;a=shape1,b=shape2) =
+ \deqn{f(y;a = shape1,b = shape2) =
a b y^{a-1} (1-y^{a})^{b-1}}{%
a*b*y^(a-1)*(1-y^a)^(b-1)}
where \eqn{0 < y < 1} and the two shape parameters,
@@ -74,10 +73,10 @@ kumar(lshape1="loge", lshape2="loge",
}
\examples{
shape1 = exp(1); shape2 = exp(2);
-y = rkumar(n <- 1000, shape1, shape2)
-fit = vglm(y ~ 1, kumar, trace =TRUE)
-c(mean(y), fitted(fit)[1])
-coef(fit, matrix=TRUE)
+kdata = data.frame(y = rkumar(n = 1000, shape1, shape2))
+fit = vglm(y ~ 1, kumar, kdata, trace = TRUE)
+c(with(kdata, mean(y)), head(fitted(fit),1))
+coef(fit, matrix = TRUE)
Coef(fit)
summary(fit)
}
diff --git a/man/laplace.Rd b/man/laplace.Rd
index f9ffcae..22b2cd1 100644
--- a/man/laplace.Rd
+++ b/man/laplace.Rd
@@ -8,10 +8,8 @@
}
\usage{
-laplace(llocation="identity", lscale="loge",
- elocation=list(), escale=list(),
- ilocation=NULL, iscale=NULL,
- method.init=1, zero=2)
+laplace(llocation="identity", lscale="loge", elocation=list(),
+ escale=list(), ilocation=NULL, iscale=NULL, method.init=1, zero=2)
}
%- maybe also 'usage' for other objects documented here.
\arguments{
@@ -102,15 +100,15 @@ Boston: Birkhauser.
}
\examples{
-y = rlaplace(n <- 100, loc=2, scale=exp(1))
-fit = vglm(y ~ 1, laplace, trace=TRUE, crit="l")
+lddat = data.frame(y = rlaplace(nn <- 100, loc=2, scale=exp(1)))
+fit = vglm(y ~ 1, laplace, lddat, trace=TRUE, crit="l")
coef(fit, matrix=TRUE)
Coef(fit)
-median(y)
+with(lddat, median(y))
-x = runif(n <- 1001)
-y = rlaplace(n, loc=2, scale=exp(-1+1*x))
-fit = vglm(y ~ x, laplace(iloc=0.2, meth=2, zero=1), trace=TRUE)
+lddat = data.frame(x = runif(nn <- 1001))
+lddat = transform(lddat, y = rlaplace(nn, loc=2, scale=exp(-1+1*x)))
+fit = vglm(y ~ x, laplace(iloc=0.2, meth=2, zero=1), lddat, trace=TRUE)
coef(fit, matrix=TRUE)
}
\keyword{models}
diff --git a/man/laplaceUC.Rd b/man/laplaceUC.Rd
index ce038b5..d55dc35 100644
--- a/man/laplaceUC.Rd
+++ b/man/laplaceUC.Rd
@@ -84,10 +84,8 @@ loc # population mean
var(y)
2 * b^2 # population variance
-
\dontrun{
-x = seq(-5, 5, by=0.01)
-loc = 0; b = 1.5
+loc = 0; b = 1.5; x = seq(-5, 5, by=0.01)
plot(x, dlaplace(x, loc, b), type="l", col="blue", ylim=c(0,1),
main="Blue is density, red is cumulative distribution function",
sub="Purple are 5,10,...,95 percentiles", las=1, ylab="")
@@ -96,8 +94,7 @@ lines(qlaplace(seq(0.05,0.95,by=0.05), loc, b),
dlaplace(qlaplace(seq(0.05,0.95,by=0.05), loc, b), loc, b),
col="purple", lty=3, type="h")
lines(x, plaplace(x, loc, b), type="l", col="red")
-abline(h=0, lty=2)
-}
+abline(h=0, lty=2) }
plaplace(qlaplace(seq(0.05,0.95,by=0.05), loc, b), loc, b)
}
diff --git a/man/leipnik.Rd b/man/leipnik.Rd
index f39fc6b..a0c4fca 100644
--- a/man/leipnik.Rd
+++ b/man/leipnik.Rd
@@ -8,9 +8,8 @@
}
\usage{
-leipnik(lmu = "logit", llambda = "loge",
- emu=list(), elambda=list(),
- imu = NULL, ilambda = NULL)
+leipnik(lmu = "logit", llambda = "loge", emu=list(),
+ elambda=list(), imu = NULL, ilambda = NULL)
}
%- maybe also 'usage' for other objects documented here.
\arguments{
@@ -92,14 +91,15 @@ leipnik(lmu = "logit", llambda = "loge",
\seealso{
\code{\link{mccullagh89}}.
+
}
\examples{
-y = rnorm(n=2000, mean=0.5, sd=0.1) # Not good data
-fit = vglm(y ~ 1, leipnik(ilambda=1), tr=TRUE, checkwz=FALSE)
+ldat = data.frame(y = rnorm(n=2000, mean=0.5, sd=0.1)) # Not good data
+fit = vglm(y ~ 1, leipnik(ilambda=1), ldat, tr=TRUE, checkwz=FALSE)
fit = vglm(y ~ 1, leipnik(ilambda=1,llam=logoff, elam=list(offset=1)),
- trace=TRUE, cri="coef")
+ ldat, trace=TRUE, cri="coef")
head(fitted(fit))
-mean(y)
+with(ldat, mean(y))
summary(fit)
coef(fit, matrix=TRUE)
Coef(fit)
diff --git a/man/lerch.Rd b/man/lerch.Rd
index 36e4e59..13588ce 100644
--- a/man/lerch.Rd
+++ b/man/lerch.Rd
@@ -33,7 +33,7 @@ lerch(x, s, v, tolerance=1.0e-10, iter=100)
\deqn{\Phi(x,s,v) = \sum_{n=0}^{\infty} \frac{x^n}{(n+v)^s}}{%
Phi(x,s,v) = sum_{n=0}^{infty} x^n / (n+v)^s}
where \eqn{|x|<1} and
- \eqn{v \neq 0, -1, -2, \ldots}{v != 0, -1, -2, \ldots}.
+ \eqn{v \neq 0, -1, -2, \ldots}{v != 0, -1, -2, ...}.
Actually, \eqn{x} may be complex but this function only works
for real \eqn{x}.
The algorithm used is based on the relation
@@ -92,8 +92,7 @@ lerch(x, s, v, tolerance=1.0e-10, iter=100)
}
\examples{
\dontrun{
-x = seq(-1.1, 1.1, len=201)
-s=2; v=1
+s=2; v=1; x = seq(-1.1, 1.1, len=201)
plot(x, lerch(x, s=s, v=v), type="l", col="red", las=1,
main=paste("lerch(x, s=",s,", v=",v,")",sep=""))
abline(v=0, h=1, lty="dashed")
diff --git a/man/levy.Rd b/man/levy.Rd
index e0cc917..6ac6df4 100644
--- a/man/levy.Rd
+++ b/man/levy.Rd
@@ -84,18 +84,17 @@ levy(delta = NULL, link.gamma = "loge", earg=list(),
}
\examples{
-n = 1000
+nn = 1000; delta = 0
mygamma = 1 # log link ==> 0 is the answer
-delta = 0
-y = delta + mygamma / rnorm(n)^2 # This is Levy(mygamma, delta)
+ldat = data.frame(y = delta + mygamma/rnorm(nn)^2) # Levy(mygamma, delta)
# Cf. Table 1.1 of Nolan for Levy(1,0)
-sum(y > 1) / length(y) # Should be 0.6827
-sum(y > 2) / length(y) # Should be 0.5205
+with(ldat, sum(y > 1) / length(y)) # Should be 0.6827
+with(ldat, sum(y > 2) / length(y)) # Should be 0.5205
-fit = vglm(y ~ 1, levy(delta=delta), trace=TRUE) # 1 parameter
+fit = vglm(y ~ 1, levy(delta=delta), ldat, trace=TRUE) # 1 parameter
fit = vglm(y ~ 1, levy(idelta=delta, igamma=mygamma),
- trace=TRUE) # 2 parameters
+ ldat, trace=TRUE) # 2 parameters
coef(fit, matrix=TRUE)
Coef(fit)
summary(fit)
diff --git a/man/lgammaUC.Rd b/man/lgammaUC.Rd
index 8e5c6cd..7388d8b 100644
--- a/man/lgammaUC.Rd
+++ b/man/lgammaUC.Rd
@@ -65,10 +65,8 @@ London: Imperial College Press.
}
\examples{
\dontrun{
+loc = 1; Scale = 1.5; k = 1.4
x = seq(-3.2, 5, by=0.01)
-loc = 1
-Scale = 1.5
-k = 1.4
plot(x, dlgamma(x, loc, Scale, k), type="l", col="blue", ylim=c(0,1),
main="Blue is density, red is cumulative distribution function",
sub="Purple are 5,10,...,95 percentiles", las=1, ylab="")
diff --git a/man/lgammaff.Rd b/man/lgammaff.Rd
index 67ec548..48c292a 100644
--- a/man/lgammaff.Rd
+++ b/man/lgammaff.Rd
@@ -115,18 +115,17 @@ New York: Wiley.
\code{\link[base:Special]{lgamma}}.
}
\examples{
-y = rlgamma(n <- 100, k=exp(1))
-fit = vglm(y ~ 1, lgammaff, trace=TRUE, crit="c")
+ldat = data.frame(y = rlgamma(nn <- 100, k=exp(1)))
+fit = vglm(y ~ 1, lgammaff, ldat, trace=TRUE, crit="c")
summary(fit)
coef(fit, matrix=TRUE)
Coef(fit)
-# Another example
-x = runif(n <- 5000)
-loc = -1 + 2*x
-Scale = exp(1+x)
-y = rlgamma(n, loc=loc, scale=Scale, k=exp(0))
-fit = vglm(y ~ x, lgamma3ff(zero=3), trace=TRUE, crit="c")
+ldat = data.frame(x = runif(nn <- 5000)) # Another example
+ldat = transform(ldat, loc = -1 + 2*x,
+ Scale = exp(1+x))
+ldat = transform(ldat, y = rlgamma(nn, loc=loc, scale=Scale, k=exp(0)))
+fit = vglm(y ~ x, lgamma3ff(zero=3), ldat, trace=TRUE, crit="c")
coef(fit, matrix=TRUE)
}
\keyword{models}
diff --git a/man/lino.Rd b/man/lino.Rd
index 471994c..2563e80 100644
--- a/man/lino.Rd
+++ b/man/lino.Rd
@@ -111,16 +111,16 @@ lino(lshape1="loge", lshape2="loge", llambda="loge",
}
\examples{
-y = rbeta(n=1000, exp(0.5), exp(1)) # Standard beta distribution
-fit = vglm(y ~ 1, lino, trace=TRUE)
+ldat1 = data.frame(y = rbeta(n=1000, exp(0.5), exp(1))) # ~ standard beta
+fit = vglm(y ~ 1, lino, ldat1, trace=TRUE)
coef(fit, mat=TRUE)
Coef(fit)
head(fitted(fit))
summary(fit)
# Nonstandard beta distribution
-y = rlino(n=1000, shape1=2, shape2=3, lambda=exp(1))
-fit = vglm(y ~ 1, lino(lshape1=identity, lshape2=identity, ilambda=10))
+ldat2 = data.frame(y = rlino(n=1000, shape1=2, shape2=3, lambda=exp(1)))
+fit = vglm(y~1, lino(lshape1=identity, lshape2=identity, ilamb=10), ldat2)
coef(fit, mat=TRUE)
}
\keyword{models}
diff --git a/man/linoUC.Rd b/man/linoUC.Rd
index c697610..324555e 100644
--- a/man/linoUC.Rd
+++ b/man/linoUC.Rd
@@ -60,9 +60,7 @@ rlino(n, shape1, shape2, lambda=1)
}
\examples{
\dontrun{
-lambda = 0.4
-shape1 = exp(1.3)
-shape2 = exp(1.3)
+lambda = 0.4; shape1 = exp(1.3); shape2 = exp(1.3)
x = seq(0.0, 1.0, len=101)
plot(x, dlino(x, shape1=shape1, shape2=shape2, lambda=lambda),
type="l", col="blue", las=1, ylab="",
diff --git a/man/lirat.Rd b/man/lirat.Rd
index e248d4a..8230931 100644
--- a/man/lirat.Rd
+++ b/man/lirat.Rd
@@ -58,7 +58,6 @@ are accounted for.
\dontrun{
# cf. Figure 3 of Moore and Tsiatis (1991)
with(lirat, plot(hb, R/N, pch=as.character(grp), col=grp, las=1,
- xlab="Hemoglobin level", ylab="Proportion Dead"))
-}
+ xlab="Hemoglobin level", ylab="Proportion Dead")) }
}
\keyword{datasets}
diff --git a/man/lms.bcg.Rd b/man/lms.bcg.Rd
index aa47dbb..11df4c3 100644
--- a/man/lms.bcg.Rd
+++ b/man/lms.bcg.Rd
@@ -9,13 +9,11 @@
\usage{
lms.bcg(percentiles = c(25, 50, 75), zero = c(1,3),
llambda="identity", lmu="identity", lsigma = "loge",
- elambda=list(), emu=list(), esigma=list(),
- dfmu.init=4, dfsigma.init=2,
- ilambda = 1, isigma = NULL)
+ elambda=list(), emu=list(), esigma=list(), dfmu.init=4,
+ dfsigma.init=2, ilambda = 1, isigma = NULL)
}
%- maybe also 'usage' for other objects documented here.
\arguments{
- In the following, \eqn{n} is the number of (independent) observations.
\item{percentiles}{
A numerical vector containing values between 0 and 100,
@@ -71,7 +69,8 @@ lms.bcg(percentiles = c(25, 50, 75), zero = c(1,3),
}
\item{ilambda}{
Initial value for lambda.
- If necessary, it is recycled to be a vector of length \eqn{n}.
+ If necessary, it is recycled to be a vector of length \eqn{n}
+ where \eqn{n} is the number of (independent) observations.
}
\item{isigma}{
@@ -183,12 +182,11 @@ qtplot(fit, percentiles=c(5,50,90,99), main="Quantiles",
# Density plot
ygrid = seq(15, 43, len=100) # BMI ranges
par(mfrow=c(1,1), lwd=2)
-a = deplot(fit, x0=20, y=ygrid, xlab="BMI", col="black",
- main="Density functions at Age = 20 (black), 42 (red) and 55 (blue)")
-a
-a = deplot(fit, x0=42, y=ygrid, add=TRUE, llty=2, col="red")
-a = deplot(fit, x0=55, y=ygrid, add=TRUE, llty=4, col="blue", Attach=TRUE)
-a at post$deplot # Contains density function values
+(aa = deplot(fit, x0=20, y=ygrid, xlab="BMI", col="black",
+ main="Density functions at Age = 20 (black), 42 (red) and 55 (blue)"))
+aa = deplot(fit, x0=42, y=ygrid, add=TRUE, llty=2, col="red")
+aa = deplot(fit, x0=55, y=ygrid, add=TRUE, llty=4, col="blue", Attach=TRUE)
+aa at post$deplot # Contains density function values
}
}
\keyword{models}
diff --git a/man/lms.bcn.Rd b/man/lms.bcn.Rd
index 4feb61a..bdc97ed 100644
--- a/man/lms.bcn.Rd
+++ b/man/lms.bcn.Rd
@@ -9,13 +9,11 @@
\usage{
lms.bcn(percentiles = c(25, 50, 75), zero = c(1,3),
llambda="identity", lmu="identity", lsigma = "loge",
- elambda=list(), emu=list(), esigma=list(),
- dfmu.init=4, dfsigma.init=2,
- ilambda = 1, isigma = NULL)
+ elambda=list(), emu=list(), esigma=list(), dfmu.init=4,
+ dfsigma.init=2, ilambda = 1, isigma = NULL)
}
%- maybe also 'usage' for other objects documented here.
\arguments{
- In the following, \eqn{n} is the number of (independent) observations.
\item{percentiles}{
A numerical vector containing values between 0 and 100,
@@ -72,7 +70,8 @@ lms.bcn(percentiles = c(25, 50, 75), zero = c(1,3),
}
\item{ilambda}{
Initial value for lambda.
- If necessary, it is recycled to be a vector of length \eqn{n}.
+ If necessary, it is recycled to be a vector of length \eqn{n}
+ where \eqn{n} is the number of (independent) observations.
}
\item{isigma}{
@@ -169,12 +168,11 @@ qtplot(fit, percentiles=c(5,50,90,99), main="Quantiles",
# Density plot
ygrid = seq(15, 43, len=100) # BMI ranges
par(mfrow=c(1,1), lwd=2)
-a = deplot(fit, x0=20, y=ygrid, xlab="BMI", col="black",
- main="Density functions at Age = 20 (black), 42 (red) and 55 (blue)")
-a
-a = deplot(fit, x0=42, y=ygrid, add=TRUE, llty=2, col="red")
-a = deplot(fit, x0=55, y=ygrid, add=TRUE, llty=4, col="blue", Attach=TRUE)
-a at post$deplot # Contains density function values
+(aa = deplot(fit, x0=20, y=ygrid, xlab="BMI", col="black",
+ main="Density functions at Age = 20 (black), 42 (red) and 55 (blue)"))
+aa = deplot(fit, x0=42, y=ygrid, add=TRUE, llty=2, col="red")
+aa = deplot(fit, x0=55, y=ygrid, add=TRUE, llty=4, col="blue", Attach=TRUE)
+aa at post$deplot # Contains density function values
}
}
\keyword{models}
diff --git a/man/lms.yjn.Rd b/man/lms.yjn.Rd
index fad6935..e0baed6 100644
--- a/man/lms.yjn.Rd
+++ b/man/lms.yjn.Rd
@@ -21,7 +21,6 @@ lms.yjn2(percentiles=c(25,50,75), zero=c(1,3),
}
%- maybe also 'usage' for other objects documented here.
\arguments{
- In the following, \eqn{n} is the number of (independent) observations.
\item{percentiles}{
A numerical vector containing values between 0 and 100,
@@ -62,7 +61,8 @@ lms.yjn2(percentiles=c(25,50,75), zero=c(1,3),
}
\item{ilambda}{
Initial value for lambda.
- If necessary, it is recycled to be a vector of length \eqn{n}.
+ If necessary, it is recycled to be a vector of length \eqn{n}
+ where \eqn{n} is the number of (independent) observations.
}
\item{isigma}{
@@ -207,12 +207,11 @@ qtplot(fit, percentiles=c(5,50,90,99), main="Quantiles",
# Density plot
ygrid = seq(15, 43, len=100) # BMI ranges
par(mfrow=c(1,1), lwd=2)
-a = deplot(fit, x0=20, y=ygrid, xlab="BMI", col="black",
- main="Density functions at Age = 20 (black), 42 (red) and 55 (blue)")
-a
-a = deplot(fit, x0=42, y=ygrid, add=TRUE, llty=2, col="red")
-a = deplot(fit, x0=55, y=ygrid, add=TRUE, llty=4, col="blue", Attach=TRUE)
-with(a at post, deplot) # Contains density function values; == a at post$deplot
+(aa = deplot(fit, x0=20, y=ygrid, xlab="BMI", col="black",
+ main="Density functions at Age = 20 (black), 42 (red) and 55 (blue)"))
+aa = deplot(fit, x0=42, y=ygrid, add=TRUE, llty=2, col="red")
+aa = deplot(fit, x0=55, y=ygrid, add=TRUE, llty=4, col="blue", Attach=TRUE)
+with(aa at post, deplot) # Contains density function values; == a at post$deplot
}
}
\keyword{models}
diff --git a/man/logUC.Rd b/man/logUC.Rd
index d439962..d117f5b 100644
--- a/man/logUC.Rd
+++ b/man/logUC.Rd
@@ -88,7 +88,6 @@ prob = 0.8; x = 1:10
plot(x, dlog(x, prob=prob), type="h", ylim=0:1,
sub="prob=0.8", las=1, col="blue", ylab="Probability",
main="Logarithmic distribution: blue=density; red=distribution function")
-lines(x+0.1, plog(x, prob=prob), col="red", lty=3, type="h")
-}
+lines(x+0.1, plog(x, prob=prob), col="red", lty=3, type="h") }
}
\keyword{distribution}
diff --git a/man/logff.Rd b/man/logff.Rd
index f774086..a110b16 100644
--- a/man/logff.Rd
+++ b/man/logff.Rd
@@ -4,6 +4,7 @@
\title{ Logarithmic Distribution }
\description{
Estimating the (single) parameter of the logarithmic distribution.
+
}
\usage{
logff(link = "logit", earg=list(), init.c = NULL)
@@ -47,6 +48,7 @@ logff(link = "logit", earg=list(), init.c = NULL)
}
\references{
+
Chapter 7 of
Johnson N. L., Kemp, A. W. and Kotz S. (2005)
\emph{Univariate Discrete Distributions},
@@ -58,9 +60,7 @@ Evans, M., Hastings, N. and Peacock, B. (2000)
\emph{Statistical Distributions},
New York: Wiley-Interscience, Third edition.
-Documentation accompanying the \pkg{VGAM} package at
-\url{http://www.stat.auckland.ac.nz/~yee}
-contains further information and examples.
+
}
\author{ T. W. Yee }
\note{
@@ -79,16 +79,28 @@ contains further information and examples.
\code{\link[base:Log]{log}},
\code{\link{loge}},
\code{\link{logoff}}.
+
}
\examples{
-y = rlog(n=1000, prob=logit(0.2, inverse=TRUE))
-fit = vglm(y ~ 1, logff, trace=TRUE, crit="c")
+ldat = data.frame(y = rlog(n=1000, prob=logit(0.2, inverse=TRUE)))
+fit = vglm(y ~ 1, logff, ldat, trace=TRUE, crit="c")
coef(fit, matrix=TRUE)
Coef(fit)
-\dontrun{hist(y, prob=TRUE, breaks=seq(0.5, max(y)+0.5, by=1), border="blue")
-x = seq(1, max(y), by=1)
-lines(x, dlog(x, Coef(fit)[1]), col="red", type="h", lwd=2)
-}
+\dontrun{with(ldat,
+ hist(y, prob=TRUE, breaks=seq(0.5, max(y)+0.5, by=1), border="blue"))
+x = seq(1, with(ldat, max(y)), by=1)
+with(ldat, lines(x, dlog(x, Coef(fit)[1]), col="red", type="h", lwd=2)) }
+
+
+# Example: Corbet (1943) butterfly Malaya data
+corbet = data.frame(nindiv = 1:24,
+ ofreq = c(118, 74, 44, 24, 29, 22, 20, 19, 20, 15, 12,
+ 14, 6, 12, 6, 9, 9, 6, 10, 10, 11, 5, 3, 3))
+fit = vglm(nindiv ~ 1, logff, data=corbet, weights=ofreq)
+coef(fit, matrix=TRUE)
+chat = Coef(fit)["c"]
+pdf2 = dlog(x=with(corbet, nindiv), prob=chat)
+print(with(corbet, cbind(nindiv, ofreq, fitted=pdf2*sum(ofreq))), dig=1)
}
\keyword{models}
\keyword{regression}
diff --git a/man/logistic.Rd b/man/logistic.Rd
index dcf9286..f836c51 100644
--- a/man/logistic.Rd
+++ b/man/logistic.Rd
@@ -127,17 +127,15 @@ A note on Deriving the Information Matrix for a Logistic Distribution,
}
\examples{
# location unknown, scale known
-n = 500
-x = runif(n)
-y = rlogis(n, loc=1+5*x, scale=4)
-fit = vglm(y ~ x, logistic1(scale=4), trace=TRUE, crit="c")
+lodat1 = data.frame(x = runif(nn <- 500))
+lodat1 = transform(lodat1, y = rlogis(nn, loc=1+5*x, scale=4))
+fit = vglm(y ~ x, logistic1(scale=4), lodat1, trace=TRUE, crit="c")
coef(fit, matrix=TRUE)
# Both location and scale unknown
-n = 2000
-x = runif(n)
-y = rlogis(n, loc=1+5*x, scale=exp(0+1*x))
-fit = vglm(y ~ x, logistic2)
+lodat2 = data.frame(x = runif(nn <- 2000))
+lodat2 = transform(lodat2, y = rlogis(nn, loc=1+5*x, scale=exp(0+1*x)))
+fit = vglm(y ~ x, logistic2, lodat2)
coef(fit, matrix=TRUE)
vcov(fit)
summary(fit)
diff --git a/man/logit.Rd b/man/logit.Rd
index cae427c..d3fe51f 100644
--- a/man/logit.Rd
+++ b/man/logit.Rd
@@ -156,13 +156,13 @@ 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"
+ 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) {
+ 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)
@@ -175,13 +175,13 @@ for(d in 0) {
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"
+ main = if (d == 0) "Some inverse probability link functions"
else "First derivative")
lines(y, logit(y, deriv=d, inverse=TRUE), col="limegreen", lwd=2)
lines(y, probit(y, deriv=d, inverse=TRUE), col="purple", lwd=2)
lines(y, cloglog(y, deriv=d, inverse=TRUE), col="chocolate", lwd=2)
lines(y, cauchit(y, deriv=d, inverse=TRUE), col="tan", lwd=2)
- if(d==0) {
+ 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)
diff --git a/man/loglapUC.Rd b/man/loglapUC.Rd
index d65f2ac..11609d2 100644
--- a/man/loglapUC.Rd
+++ b/man/loglapUC.Rd
@@ -86,8 +86,8 @@ Log-Laplace distributions.
}
\examples{
-x = seq(-0.2, 5, by=0.01)
loc = 0; sigma = exp(0.5); kappa = 1
+x = seq(-0.2, 5, by=0.01)
\dontrun{
plot(x, dloglap(x, loc, sigma, kappa=kappa), type="l", col="blue",
main="Blue is density, red is cumulative distribution function",
diff --git a/man/loglaplace.Rd b/man/loglaplace.Rd
index add24cc..dbf4617 100644
--- a/man/loglaplace.Rd
+++ b/man/loglaplace.Rd
@@ -17,8 +17,7 @@
loglaplace1(tau = NULL, llocation = "loge", elocation = list(),
ilocation = NULL, kappa = sqrt(tau/(1 - tau)), Scale.arg = 1,
shrinkage.init = 0.95, parallelLocation = FALSE, digt = 4,
- dfmu.init = 3, rep0 = 0.5,
- minquantile = 0, maxquantile = Inf,
+ dfmu.init = 3, rep0 = 0.5, minquantile = 0, maxquantile = Inf,
method.init = 1, zero = NULL)
logitlaplace1(tau = NULL, llocation = "logit", elocation = list(),
ilocation = NULL, kappa = sqrt(tau/(1 - tau)),
diff --git a/man/loglinb2.Rd b/man/loglinb2.Rd
index 5c64641..d7ee1dc 100644
--- a/man/loglinb2.Rd
+++ b/man/loglinb2.Rd
@@ -4,9 +4,11 @@
\title{ Loglinear Model for Two Binary Responses }
\description{
Fits a loglinear model to two binary responses.
+
}
\usage{
loglinb2(exchangeable = FALSE, zero = NULL)
+
}
%- maybe also 'usage' for other objects documented here.
\arguments{
@@ -15,6 +17,7 @@ loglinb2(exchangeable = FALSE, zero = NULL)
be equal. Should be set \code{TRUE} for ears, eyes, etc. data. }
\item{zero}{ Which linear/additive predictor is modelled as an
intercept only? A \code{NULL} means none of them. }
+
}
\details{
The model is
@@ -76,10 +79,10 @@ contains further information and examples.
\code{\link{loglinb3}}.
}
\examples{
-coalminers = transform(coalminers, age=(age-42)/5)
+coalminers = transform(coalminers, Age=(age-42)/5)
# Get the n x 4 matrix of counts
-temp = vglm(cbind(nBnW,nBW,BnW,BW) ~ age, binom2.or, coalminers)
+temp = vglm(cbind(nBnW,nBW,BnW,BW) ~ Age, binom2.or, coalminers)
counts = round(c(weights(temp, type="prior")) * temp at y)
# Create a n x 2 matrix response for loglinb2()
@@ -89,10 +92,10 @@ matof1 = matrix(1, nrow(counts), 1)
newminers = data.frame(bln = kronecker(matof1, bwmat[,1]),
wheeze = kronecker(matof1, bwmat[,2]),
wt = c(t(counts)),
- age = with(coalminers, rep(age, rep(4, length(age)))))
+ Age = with(coalminers, rep(age, rep(4, length(age)))))
newminers = newminers[with(newminers, wt) > 0,]
-fit = vglm(cbind(bln,wheeze) ~ age, loglinb2, wei=wt, data=newminers)
+fit = vglm(cbind(bln,wheeze) ~ Age, loglinb2, wei=wt, data=newminers)
coef(fit, mat=TRUE) # Same! (at least for the log odds-ratio)
summary(fit)
diff --git a/man/loglinb3.Rd b/man/loglinb3.Rd
index 7e424c8..8d45a3f 100644
--- a/man/loglinb3.Rd
+++ b/man/loglinb3.Rd
@@ -4,6 +4,7 @@
\title{ Loglinear Model for Three Binary Responses }
\description{
Fits a loglinear model to three binary responses.
+
}
\usage{
loglinb3(exchangeable = FALSE, zero = NULL)
@@ -15,6 +16,7 @@ loglinb3(exchangeable = FALSE, zero = NULL)
be equal. }
\item{zero}{ Which linear/additive predictor is modelled as an
intercept only? A \code{NULL} means none. }
+
}
\details{
The model is \eqn{P(Y_1=y_1,Y_2=y_2,Y_3=y_3) =}{P(Y1=y1,Y2=y2,Y3=y3) =}
@@ -77,6 +79,7 @@ contains further information and examples.
\seealso{
\code{\link{loglinb2}},
\code{\link{hunua}}.
+
}
\examples{
fit = vglm(cbind(cyadea,beitaw,kniexc) ~ altitude, loglinb3, data=hunua)
diff --git a/man/loglog.Rd b/man/loglog.Rd
index ad381e7..32f2f0d 100644
--- a/man/loglog.Rd
+++ b/man/loglog.Rd
@@ -87,6 +87,7 @@ loglog(theta, earg = list(), inverse = FALSE, deriv = 0,
\code{\link{Links}},
\code{\link{loge}},
\code{\link{logoff}}.
+
}
\examples{
x = seq(0.8, 1.5, by=0.1)
diff --git a/man/lognormal.Rd b/man/lognormal.Rd
index 93510c2..d543496 100644
--- a/man/lognormal.Rd
+++ b/man/lognormal.Rd
@@ -105,23 +105,21 @@ Hoboken, NJ: Wiley-Interscience.
}
\examples{
-y = rlnorm(n <- 1000, meanlog=1.5, sdlog=exp(-0.8))
-fit = vglm(y ~ 1, lognormal, trace=TRUE)
+lndat = data.frame(y = rlnorm(nn <- 1000, meanlog=1.5, sdlog=exp(-0.8)))
+fit = vglm(y ~ 1, lognormal, lndat, trace=TRUE)
coef(fit, mat=TRUE)
Coef(fit)
-x = runif(n <- 1000)
-y = rlnorm(n, mean=0.5, sd=exp(x))
-fit = vglm(y ~ x, lognormal(zero=1), trace=TRUE, crit="c")
+lndat2 = data.frame(x = runif(nn <- 1000))
+lndat2 = transform(lndat2, y = rlnorm(nn, mean=0.5, sd=exp(x)))
+fit = vglm(y ~ x, lognormal(zero=1), lndat2, trace=TRUE, crit="c")
coef(fit, mat=TRUE)
Coef(fit)
lambda = 4
-y = lambda + rlnorm(n <- 1000, mean=1.5, sd=exp(-0.8))
-fit = vglm(y ~ 1, lognormal3, trace=TRUE)
-fit = vglm(y ~ 1, lognormal3, trace=TRUE, crit="c")
+lndat3 = data.frame(y = lambda + rlnorm(n=1000, mean=1.5, sd=exp(-0.8)))
+fit = vglm(y ~ 1, lognormal3, lndat3, trace=TRUE, crit="c")
coef(fit, mat=TRUE)
-Coef(fit)
summary(fit)
}
\keyword{models}
diff --git a/man/logoff.Rd b/man/logoff.Rd
index 55bc609..278e11e 100644
--- a/man/logoff.Rd
+++ b/man/logoff.Rd
@@ -31,6 +31,7 @@ logoff(theta, earg = list(offset=0), inverse = FALSE, deriv = 0,
\item{tag}{ Used for labelling the linear/additive predictor in the
\code{initialize} slot of a \code{\link{vglmff-class}} object.
Contains a little more information if \code{TRUE}. }
+
}
\details{
The log-offset link function is very commonly used for parameters that
@@ -64,6 +65,7 @@ logoff(theta, earg = list(offset=0), inverse = FALSE, deriv = 0,
\references{
McCullagh, P. and Nelder, J. A. (1989)
\emph{Generalized Linear Models}, 2nd ed. London: Chapman & Hall.
+
}
\author{ Thomas W. Yee }
@@ -83,8 +85,7 @@ logoff(theta, earg = list(offset=0), inverse = FALSE, deriv = 0,
\dontrun{
logoff(seq(-0.2, 0.5, by=0.1))
logoff(seq(-0.2, 0.5, by=0.1), earg=list(offset=0.5))
-log(seq(-0.2, 0.5, by=0.1) + 0.5)
-}
+log(seq(-0.2, 0.5, by=0.1) + 0.5) }
}
\keyword{math}
\keyword{models}
diff --git a/man/lomax.Rd b/man/lomax.Rd
index f39ad74..af1c244 100644
--- a/man/lomax.Rd
+++ b/man/lomax.Rd
@@ -7,9 +7,8 @@
Lomax distribution.
}
\usage{
-lomax(link.scale = "loge", link.q = "loge",
- earg.scale=list(), earg.q=list(),
- init.scale = NULL, init.q = 1, zero = NULL)
+lomax(link.scale = "loge", link.q = "loge", earg.scale=list(),
+ earg.q=list(), init.scale = NULL, init.q = 1, zero = NULL)
}
%- maybe also 'usage' for other objects documented here.
\arguments{
@@ -94,9 +93,8 @@ default value is not \code{NULL}.
}
\examples{
-y = rlomax(n=2000, 6, 2)
-fit = vglm(y ~ 1, lomax, trace=TRUE)
-fit = vglm(y ~ 1, lomax, trace=TRUE, crit="c")
+lodat = data.frame(y = rlomax(n=2000, 6, 2))
+fit = vglm(y ~ 1, lomax, lodat, trace=TRUE, crit="c")
coef(fit, mat=TRUE)
Coef(fit)
summary(fit)
diff --git a/man/lqnorm.Rd b/man/lqnorm.Rd
index 39ccf6d..8e324c9 100644
--- a/man/lqnorm.Rd
+++ b/man/lqnorm.Rd
@@ -105,12 +105,12 @@ lqnorm(qpower=2, link="identity", earg=list(),
\examples{
set.seed(123)
-d = data.frame(x = sort(runif(n <- 10 )))
+ldat = data.frame(x = sort(runif(nn <- 10 )))
realfun = function(x) 4 + 5*x
-d = transform(d, y = realfun(x) + rnorm(n, sd=exp(1)))
+ldat = transform(ldat, y = realfun(x) + rnorm(nn, sd=exp(1)))
# Make the first observation an outlier
-d = transform(d, y = c(4*y[1], y[-1]), x=c(-1, x[-1]))
-fit = vglm(y ~ x, fam = lqnorm(qpower=1.2), data=d)
+ldat = transform(ldat, y = c(4*y[1], y[-1]), x=c(-1, x[-1]))
+fit = vglm(y ~ x, fam = lqnorm(qpower=1.2), data=ldat)
coef(fit, matrix=TRUE)
head(fitted(fit))
fit at misc$qpower
@@ -118,13 +118,12 @@ fit at misc$objectiveFunction
\dontrun{
# Graphical check
-with(d, plot(x, y, main=paste("LS=red, lqnorm=blue (qpower = ",
+with(ldat, plot(x, y, main=paste("LS=red, lqnorm=blue (qpower = ",
fit at misc$qpower, "), truth=black", sep=""), col="blue"))
-it = lm(y ~ x, data=d)
-with(d, lines(x, fitted(fit), col="blue"))
-with(d, lines(x, it$fitted, col="red"))
-with(d, lines(x, realfun(x), col="black"))
-}
+lmfit = lm(y ~ x, data=ldat)
+with(ldat, lines(x, fitted(fit), col="blue"))
+with(ldat, lines(x, lmfit$fitted, col="red"))
+with(ldat, lines(x, realfun(x), col="black")) }
}
\keyword{models}
\keyword{regression}
diff --git a/man/lv.Rd b/man/lv.Rd
index 9ea197f..3aa6db5 100644
--- a/man/lv.Rd
+++ b/man/lv.Rd
@@ -68,11 +68,9 @@ Constrained additive ordination.
hspider[,1:6] = scale(hspider[,1:6]) # Standardized environmental vars
set.seed(123)
p1 = cao(cbind(Pardlugu, Pardmont, Pardnigr, Pardpull, Zoraspin) ~
- WaterCon + BareSand + FallTwig +
- CoveMoss + CoveHerb + ReflLux,
- family = poissonff, data = hspider,
- Rank = 1, df1.nl = c(Zoraspin=2.5, 3),
- Bestof = 3, Crow1positive = TRUE)
+ WaterCon + BareSand + FallTwig + CoveMoss + CoveHerb + ReflLux,
+ family = poissonff, data = hspider, Rank = 1, df1.nl =
+ c(Zoraspin=2.5, 3), Bestof = 3, Crow1positive = TRUE)
var(lv(p1)) # Scaled to unit variance # Scaled to unit variance
c(lv(p1)) # Estimated site scores
diff --git a/man/lvplot.qrrvglm.Rd b/man/lvplot.qrrvglm.Rd
index 9b0d348..8594edc 100644
--- a/man/lvplot.qrrvglm.Rd
+++ b/man/lvplot.qrrvglm.Rd
@@ -286,24 +286,27 @@ canonical Gaussian ordination.
\examples{
set.seed(123)
-x2 = rnorm(n <- 200) # Has mean 0 (needed when ITol=TRUE)
-x3 = rnorm(n) # Has mean 0 (needed when ITol=TRUE)
-x4 = rnorm(n) # Has mean 0 (needed when ITol=TRUE)
-lv1 = x2 + x3 - 2*x4
-lv2 = -x2 + x3 + 0*x4 # lv2 is weakly correlated with lv1
-lambda1 = exp(6 - 0.5 * (lv1-0)^2 - 0.5 * (lv2-0)^2)
-lambda2 = exp(5 - 0.5 * (lv1-1)^2 - 0.5 * (lv2-1)^2)
-lambda3 = exp(5 - 0.5 * (lv1+2)^2 - 0.5 * (lv2-0)^2)
-spp1 = rpois(n, lambda1)
-spp2 = rpois(n, lambda2)
-spp3 = rpois(n, lambda3)
+nn = 200
+cdat = data.frame(x2 = rnorm(nn), # Has mean 0 (needed when ITol=TRUE)
+ x3 = rnorm(nn), # Has mean 0 (needed when ITol=TRUE)
+ x4 = rnorm(nn)) # Has mean 0 (needed when ITol=TRUE)
+cdat = transform(cdat, lv1 = x2 + x3 - 2*x4,
+ lv2 = -x2 + x3 + 0*x4)
+# Nb. lv2 is weakly correlated with lv1
+cdat = transform(cdat, lambda1 = exp(6 - 0.5 * (lv1-0)^2 - 0.5 * (lv2-0)^2),
+ lambda2 = exp(5 - 0.5 * (lv1-1)^2 - 0.5 * (lv2-1)^2),
+ lambda3 = exp(5 - 0.5 * (lv1+2)^2 - 0.5 * (lv2-0)^2))
+cdat = transform(cdat, spp1 = rpois(nn, lambda1),
+ spp2 = rpois(nn, lambda2),
+ spp3 = rpois(nn, lambda3))
set.seed(111)
-p2 = cqo(cbind(spp1,spp2,spp3) ~ x2 + x3 + x4, poissonff,
- Rank=2, ITolerances=TRUE,
- Crow1positive=c(TRUE,FALSE)) # deviance = 505.81
-if(deviance(p2) > 506) stop("suboptimal fit obtained")
-sort(p2 at misc$deviance.Bestof) # A history of the fits
-Coef(p2)
+# vvv p2 = cqo(cbind(spp1,spp2,spp3) ~ x2 + x3 + x4, poissonff,
+# vvv data = cdat,
+# vvv Rank=2, ITolerances=TRUE,
+# vvv Crow1positive=c(TRUE,FALSE)) # deviance = 505.81
+# vvv if (deviance(p2) > 506) stop("suboptimal fit obtained")
+# vvv sort(p2 at misc$deviance.Bestof) # A history of the fits
+# vvv Coef(p2)
\dontrun{
lvplot(p2, sites=TRUE, spch="*", scol="darkgreen", scex=1.5,
@@ -311,14 +314,13 @@ lvplot(p2, sites=TRUE, spch="*", scol="darkgreen", scex=1.5,
adj=-0.5, pcol="blue", pcex=1.3, las=1,
C=TRUE, Cadj=c(-.3,-.3,1), Clwd=2, Ccex=1.4, Ccol="red",
main=paste("Contours at Abundance=140 with",
- "convex hull of the site scores"))
-}
-var(lv(p2)) # A diagonal matrix, i.e., uncorrelated latent variables
-var(lv(p2, varlvI=TRUE)) # Identity matrix
-Tol(p2)[,,1:2] # Identity matrix
-Tol(p2, varlvI=TRUE)[,,1:2] # A diagonal matrix
+ "convex hull of the site scores")) }
+# vvv var(lv(p2)) # A diagonal matrix, i.e., uncorrelated latent variables
+# vvv var(lv(p2, varlvI=TRUE)) # Identity matrix
+# vvv Tol(p2)[,,1:2] # Identity matrix
+# vvv Tol(p2, varlvI=TRUE)[,,1:2] # A diagonal matrix
}
\keyword{models}
\keyword{regression}
-\keyword{hplot}
+\keyword{graphs}
diff --git a/man/lvplot.rrvglm.Rd b/man/lvplot.rrvglm.Rd
index ff11405..ca7ea36 100644
--- a/man/lvplot.rrvglm.Rd
+++ b/man/lvplot.rrvglm.Rd
@@ -145,19 +145,18 @@ Reduced-rank vector generalized linear models.
\code{\link{rrvglm.control}}.
}
\examples{
-n = nrow(pneumo) # x1, x2 and x3 are some unrelated covariates
+nn = nrow(pneumo) # x1, x2 and x3 are some unrelated covariates
pneumo = transform(pneumo, slet=scale(log(exposure.time)),
- x1 = rnorm(n), x2 = rnorm(n), x3 = rnorm(n))
+ x1 = rnorm(nn), x2 = rnorm(nn), x3 = rnorm(nn))
fit = rrvglm(cbind(normal, mild, severe) ~ slet + x1 + x2 + x3,
- multinomial, pneumo, Rank=2, Corner=FALSE, Uncor=TRUE)
+ multinomial, pneumo, Rank=2, Corner=FALSE, Uncorrel=TRUE)
\dontrun{
lvplot(fit, chull=TRUE, scores=TRUE, clty=2, ccol="blue", scol="red",
Ccol="darkgreen", Clwd=2, Ccex=2,
- main="Biplot of some fictitional data")
-}
+ main="Biplot of some fictitional data") }
}
\keyword{models}
\keyword{regression}
-\keyword{hplot}
+\keyword{graphs}
% pneumo$slet = scale(log(pneumo$exposure.time))
diff --git a/man/maxwell.Rd b/man/maxwell.Rd
index 6ad139d..d776aa1 100644
--- a/man/maxwell.Rd
+++ b/man/maxwell.Rd
@@ -59,10 +59,11 @@ maxwell(link = "loge", earg=list())
\seealso{
\code{\link{Maxwell}},
\code{\link{rayleigh}}.
+
}
\examples{
-y = rmaxwell(n <- 1000, a=exp(2))
-fit = vglm(y ~ 1, maxwell, trace=TRUE, crit="c")
+mdata = data.frame(y = rmaxwell(1000, a=exp(2)))
+fit = vglm(y ~ 1, maxwell, mdata, trace=TRUE, crit="c")
coef(fit, matrix=TRUE)
Coef(fit)
}
diff --git a/man/MaxwellUC.Rd b/man/maxwellUC.Rd
similarity index 96%
rename from man/MaxwellUC.Rd
rename to man/maxwellUC.Rd
index 54eb230..ea3fe97 100644
--- a/man/MaxwellUC.Rd
+++ b/man/maxwellUC.Rd
@@ -11,7 +11,7 @@
}
\usage{
-dmaxwell(x, a, log=FALSE)
+dmaxwell(x, a, log = FALSE)
pmaxwell(q, a)
qmaxwell(p, a)
rmaxwell(n, a)
@@ -45,19 +45,21 @@ rmaxwell(n, a)
See \code{\link{maxwell}}, the \pkg{VGAM} family function
for estimating the parameter \eqn{a} by maximum likelihood estimation,
for the formula of the probability density function.
+
}
\note{
The Maxwell distribution is related to the Rayleigh distribution.
+
}
\seealso{
\code{\link{maxwell}},
\code{\link{Rayleigh}},
\code{\link{rayleigh}}.
+
}
\examples{
\dontrun{
-a = 3
-x = seq(-0.5, 3, len=100)
+a = 3; x = seq(-0.5, 3, len = 100)
plot(x, dmaxwell(x, a=a), type="l", col="blue", las=1, ylab="",
main="blue is density, red is cumulative distribution function",
sub="Purple lines are the 10,20,...,90 percentiles")
diff --git a/man/mccullagh89.Rd b/man/mccullagh89.Rd
index 4cf7571..c5f9723 100644
--- a/man/mccullagh89.Rd
+++ b/man/mccullagh89.Rd
@@ -8,11 +8,9 @@
}
\usage{
-mccullagh89(ltheta="rhobit", lnu="logoff",
- itheta=NULL, inu=NULL,
- etheta=list(),
- enu=if(lnu == "logoff") list(offset=0.5) else list(),
- zero=NULL)
+mccullagh89(ltheta="rhobit", lnu="logoff", itheta=NULL, inu=NULL,
+ etheta=list(), enu=if(lnu == "logoff") list(offset=0.5)
+ else list(), zero=NULL)
}
%- maybe also 'usage' for other objects documented here.
\arguments{
diff --git a/man/mckaygamma2.Rd b/man/mckaygamma2.Rd
index 3a1b02b..f8d61e4 100644
--- a/man/mckaygamma2.Rd
+++ b/man/mckaygamma2.Rd
@@ -61,14 +61,16 @@ mckaygamma2(la = "loge", lp = "loge", lq = "loge",
%% improve the references
\references{
+
McKay, A. T. (1934)
Sampling from batches.
\emph{Journal of the Royal Statistical Society---Supplement},
\bold{1}, 207--216.
+
Kotz, S. and Balakrishnan, N. and Johnson, N. L. (2000)
-\emph{Continuous Multivariate Distributions Volume 1: Models
-and Applications},
+\emph{Continuous Multivariate Distributions Volume 1:
+Models and Applications},
2nd edition,
New York: Wiley.
diff --git a/man/micmen.Rd b/man/micmen.Rd
index daab99c..5528b5f 100644
--- a/man/micmen.Rd
+++ b/man/micmen.Rd
@@ -7,9 +7,8 @@
}
\usage{
micmen(rpar = 0.001, divisor = 10, init1 = NULL, init2 = NULL,
- link1 = "identity", link2 = "identity",
- earg1=list(), earg2=list(),
- dispersion = 0, zero = NULL)
+ link1 = "identity", link2 = "identity", earg1=list(),
+ earg2=list(), dispersion = 0, zero = NULL)
}
%- maybe also 'usage' for other objects documented here.
\arguments{
diff --git a/man/mix2exp.Rd b/man/mix2exp.Rd
index 67431de..0cf0d51 100644
--- a/man/mix2exp.Rd
+++ b/man/mix2exp.Rd
@@ -9,10 +9,8 @@
}
\usage{
-mix2exp(lphi="logit", llambda="loge",
- ephi=list(), el1=list(), el2=list(),
- iphi=0.5, il1=NULL, il2=NULL,
- qmu=c(0.8, 0.2), nsimEIM=100, zero=1)
+mix2exp(lphi="logit", llambda="loge", ephi=list(), el1=list(), el2=list(),
+ iphi=0.5, il1=NULL, il2=NULL, qmu=c(0.8, 0.2), nsimEIM=100, zero=1)
}
%- maybe also 'usage' for other objects documented here.
\arguments{
@@ -121,13 +119,12 @@ mix2exp(lphi="logit", llambda="loge",
}
\examples{
-lambda1 = exp(1)
-lambda2 = exp(3)
+lambda1 = exp(1); lambda2 = exp(3)
(phi = logit(-1, inverse=TRUE))
-y1 = rexp(n <- 1000, lambda1)
-y2 = rexp(n, lambda2)
-y = ifelse(runif(n) < phi, y1, y2)
-fit = vglm(y ~ 1, mix2exp)
+mdata = data.frame(y1 = rexp(nn <- 1000, lambda1))
+mdata = transform(mdata, y2 = rexp(nn, lambda2))
+mdata = transform(mdata, y = ifelse(runif(nn) < phi, y1, y2))
+fit = vglm(y ~ 1, mix2exp, mdata, trace=TRUE)
coef(fit, matrix=TRUE)
# Compare the results with the truth
@@ -135,10 +132,9 @@ round(rbind('Estimated'=Coef(fit),
'Truth'=c(phi, lambda1, lambda2)), dig=2)
\dontrun{# Plot the results
-hist(y, prob=TRUE, main="Red=estimate, blue=truth")
+with(mdata, hist(y, prob=TRUE, main="Red=estimate, blue=truth"))
abline(v=1/Coef(fit)[c(2,3)], lty=2, col="red", lwd=2)
-abline(v=1/c(lambda1, lambda2), lty=2, col="blue", lwd=2)
-}
+abline(v=1/c(lambda1, lambda2), lty=2, col="blue", lwd=2) }
}
\keyword{models}
\keyword{regression}
diff --git a/man/mix2normal1.Rd b/man/mix2normal1.Rd
index 10cd139..f11220f 100644
--- a/man/mix2normal1.Rd
+++ b/man/mix2normal1.Rd
@@ -169,22 +169,21 @@ London: Chapman & Hall.
}
\examples{
-n = 1000
-mu1 = 99
-mu2 = 150
+mu1 = 99; mu2 = 150
sd1 = sd2 = exp(3)
(phi = logit(-1, inverse=TRUE))
-y = ifelse(runif(n) < phi, rnorm(n, mu1, sd1), rnorm(n, mu2, sd2))
-
-fit = vglm(y ~ 1, mix2normal1(equalsd=TRUE))
+nn = 1000
+mdata = data.frame(y = ifelse(runif(nn) < phi, rnorm(nn, mu1, sd1),
+ rnorm(nn, mu2, sd2)))
+fit = vglm(y ~ 1, mix2normal1(equalsd=TRUE), mdata)
# Compare the results
-cf = coef(fit)
-round(rbind('Estimated'=c(logit(cf[1], inv=TRUE),
- cf[2], exp(cf[3]), cf[4]), 'Truth'=c(phi, mu1, sd1, mu2)), dig=2)
+cfit = coef(fit)
+round(rbind('Estimated'=c(logit(cfit[1], inv=TRUE),
+ cfit[2], exp(cfit[3]), cfit[4]), 'Truth'=c(phi, mu1, sd1, mu2)), dig=2)
\dontrun{# Plot the results
-xx = seq(min(y), max(y), len=200)
+xx = with(mdata, seq(min(y), max(y), len=200))
plot(xx, (1-phi)*dnorm(xx, mu2, sd2), type="l", xlab="y",
main="Red=estimate, blue=truth", col="blue", ylab="Density")
phi.est = logit(coef(fit)[1], inverse=TRUE)
@@ -193,8 +192,7 @@ lines(xx, phi*dnorm(xx, mu1, sd1), col="blue")
lines(xx, phi.est * dnorm(xx, Coef(fit)[2], sd.est), col="red")
lines(xx, (1-phi.est) * dnorm(xx, Coef(fit)[4], sd.est), col="red")
abline(v=Coef(fit)[c(2,4)], lty=2, col="red")
-abline(v=c(mu1, mu2), lty=2, col="blue")
-}
+abline(v=c(mu1, mu2), lty=2, col="blue") }
}
\keyword{models}
\keyword{regression}
diff --git a/man/mix2poisson.Rd b/man/mix2poisson.Rd
index 7c4d95c..8bacea2 100644
--- a/man/mix2poisson.Rd
+++ b/man/mix2poisson.Rd
@@ -126,37 +126,35 @@ mix2poisson(lphi = "logit", llambda = "loge",
\examples{
# Example 1: simulated data
-n = 1000
+nn = 1000
mu1 = exp(2.5) # also known as lambda1
mu2 = exp(3)
(phi = logit(-0.5, inverse=TRUE))
-y = ifelse(runif(n) < phi, rpois(n, mu1), rpois(n, mu2))
-fit = vglm(y ~ 1, mix2poisson)
+mdata = data.frame(y = ifelse(runif(nn) < phi, rpois(nn, mu1), rpois(nn, mu2)))
+fit = vglm(y ~ 1, mix2poisson, mdata)
coef(fit, matrix=TRUE)
# Compare the results with the truth
round(rbind('Estimated'=Coef(fit), 'Truth'=c(phi, mu1, mu2)), dig=2)
\dontrun{# Plot the results
-ty = table(y)
+ty = with(mdata, table(y))
plot(names(ty), ty, type="h", main="Red=estimate, blue=truth",
ylab="Frequency", xlab="y")
abline(v=Coef(fit)[-1], lty=2, col="red", lwd=2)
-abline(v=c(mu1, mu2), lty=2, col="blue", lwd=2)
-}
+abline(v=c(mu1, mu2), lty=2, col="blue", lwd=2) }
# Example 2: London Times data (Lange, 1997, p.31)
-deaths = 0:9
-freq = c(162, 267, 271, 185, 111, 61, 27, 8, 3, 1)
-y = rep(deaths, freq)
+ltdata1 = data.frame(deaths = 0:9,
+ freq = c(162, 267, 271, 185, 111, 61, 27, 8, 3, 1))
+ltdata2 = data.frame(y = with(ltdata1, rep(deaths, freq)))
# Usually this does not work well unless nsimEIM is large
-fit = vglm(deaths ~ 1, weight = freq,
+fit = vglm(deaths ~ 1, weight=freq, data=ltdata1,
mix2poisson(iphi=0.3, il1=1, il2=2.5, nsimEIM=5000))
# This works better in general
-fit = vglm(y ~ 1, mix2poisson(iphi=0.3, il1=1, il2=2.5))
-
+fit = vglm(y ~ 1, mix2poisson(iphi=0.3, il1=1, il2=2.5), ltdata2)
coef(fit, matrix=TRUE)
Coef(fit)
}
diff --git a/man/multinomial.Rd b/man/multinomial.Rd
index 16bef18..7f60cdc 100644
--- a/man/multinomial.Rd
+++ b/man/multinomial.Rd
@@ -13,9 +13,6 @@ multinomial(zero = NULL, parallel = FALSE, nointercept = NULL,
}
%- maybe also 'usage' for other objects documented here.
\arguments{
- In the following, the response \eqn{Y} is assumed to be a factor with
- unordered values \eqn{1,2,\dots,M+1}, so that \eqn{M} is the number
- of linear/additive predictors \eqn{\eta_j}{eta_j}.
\item{zero}{
An integer-valued vector specifying which
@@ -30,9 +27,7 @@ multinomial(zero = NULL, parallel = FALSE, nointercept = NULL,
}
\item{nointercept}{
- An integer-valued vector specifying which
- linear/additive predictors have no intercepts.
- Any values must be from the set \{1,2,\ldots,\eqn{M}\}.
+ See \code{\link{CommonVGAMffArguments}} for more details.
}
\item{refLevel}{
@@ -50,6 +45,11 @@ multinomial(zero = NULL, parallel = FALSE, nointercept = NULL,
}
}
\details{
+ In this help file the response \eqn{Y} is assumed to be a factor with
+ unordered values \eqn{1,2,\dots,M+1}, so that \eqn{M} is the number
+ of linear/additive predictors \eqn{\eta_j}{eta_j}.
+
+
The default model can be written
\deqn{\eta_j = \log(P[Y=j]/ P[Y=M+1])}{%
eta_j = log(P[Y=j]/ P[Y=M+1])}
@@ -80,36 +80,51 @@ multinomial(zero = NULL, parallel = FALSE, nointercept = NULL,
}
\references{
+
+Yee, T. W. (2009)
+The \pkg{VGAM} package for categorical data analysis.
+\emph{Journal of Statistical Software},
+\bold{32}, % zzz--zzz.
+\url{http://www.jstatsoft.org/v32/i10/}.
+
+
Yee, T. W. and Hastie, T. J. (2003)
Reduced-rank vector generalized linear models.
\emph{Statistical Modelling},
\bold{3}, 15--41.
+
McCullagh, P. and Nelder, J. A. (1989)
\emph{Generalized Linear Models}, 2nd ed.
London: Chapman & Hall.
+
Agresti, A. (2002)
\emph{Categorical Data Analysis},
2nd ed. New York: Wiley.
+
Hastie, T. J., Tibshirani, R. J. and Friedman, J. H. (2009)
\emph{The Elements of Statistical Learning: Data Mining, Inference and Prediction},
2nd ed.
New York: Springer-Verlag.
+
Simonoff, J. S. (2003)
\emph{Analyzing Categorical Data},
New York: Springer-Verlag.
+
Anderson, J. A. (1984)
Regression and ordered categorical variables.
\emph{Journal of the Royal Statistical Society, Series B, Methodological},
\bold{46}, 1--30.
-Documentation accompanying the \pkg{VGAM} package at
-\url{http://www.stat.auckland.ac.nz/~yee}
-contains further information and examples.
+
+Further information and examples on categorical data analysis
+by the \pkg{VGAM} package can be found at
+\url{http://www.stat.auckland.ac.nz/~yee/VGAM/doc/categorical.pdf}.
+
}
\author{ Thomas W. Yee }
@@ -130,6 +145,7 @@ contains further information and examples.
are separable and/or the fitted probabilities are close to 0 or 1.
The fitted values returned are estimates of the probabilities
\eqn{P[Y=j]} for \eqn{j=1,\ldots,M+1}.
+ See \pkg{safeBinaryRegression} for the logistic regression case.
Here is an example of the usage of the \code{parallel} argument.
If there are covariates \code{x2}, \code{x3} and \code{x4}, then
@@ -161,14 +177,9 @@ contains further information and examples.
\section{Warning }{
No check is made to verify that the response is nominal.
- The arguments \code{zero} and \code{nointercept} can be inputted
- with values that fail. For example, \code{multinomial(zero=2,
- nointercept=1:3)} means the second linear/additive predictor is
- identically zero, which will cause a failure.
- Be careful about the use of other potentially contradictory constraints,
- e.g., \code{multinomial(zero=2, parallel = TRUE ~ x3)}. If in doubt,
- apply \code{constraints()} to the fitted object to check.
+ See \code{\link{CommonVGAMffArguments}} for more warnings.
+
}
\seealso{
@@ -182,7 +193,7 @@ contains further information and examples.
\code{\link{rrvglm}},
\code{\link{fill1}},
\code{\link[stats:Multinom]{Multinomial}},
- \code{\link[base]{iris}}.
+ \code{\link[datasets]{iris}}.
The author's homepage has further documentation about
categorical data analysis using \pkg{VGAM}.
diff --git a/man/negbinomial.Rd b/man/negbinomial.Rd
index 2f98cfc..80c7dae 100644
--- a/man/negbinomial.Rd
+++ b/man/negbinomial.Rd
@@ -7,10 +7,8 @@
distribution.
}
\usage{
-negbinomial(lmu = "loge", lk = "loge",
- emu =list(), ek=list(),
- ik = NULL, nsimEIM=100,
- cutoff = 0.995, Maxiter=5000,
+negbinomial(lmu = "loge", lk = "loge", emu = list(), ek = list(),
+ ik = NULL, nsimEIM = 100, cutoff = 0.995, Maxiter=5000,
deviance.arg = FALSE, method.init=1,
shrinkage.init=0.95, zero = -2)
}
@@ -252,29 +250,28 @@ Fitting the negative binomial distribution to biological data.
% \code{\link[MASS]{rnegbin}}.
\code{\link[stats:NegBinomial]{rnbinom}},
\code{\link{nbolf}}.
+
}
\examples{
# Example 1: apple tree data
-y = 0:7
-w = c(70, 38, 17, 10, 9, 3, 2, 1)
-fit = vglm(y ~ 1, negbinomial, weights=w)
+appletree = data.frame(y = 0:7, w = c(70, 38, 17, 10, 9, 3, 2, 1))
+fit = vglm(y ~ 1, negbinomial, appletree, weights=w)
summary(fit)
coef(fit, matrix=TRUE)
Coef(fit)
# Example 2: simulated data with multivariate response
-x = runif(n <- 500)
-y1 = rnbinom(n, mu=exp(3+x), size=exp(1)) # k is size
-y2 = rnbinom(n, mu=exp(2-x), size=exp(0))
-fit = vglm(cbind(y1,y2) ~ x, negbinomial, trace=TRUE)
-coef(fit, matrix=TRUE)
+ndata = data.frame(x = runif(nn <- 500))
+ndata = transform(ndata, y1 = rnbinom(nn, mu=exp(3+x), size=exp(1)),
+ y2 = rnbinom(nn, mu=exp(2-x), size=exp(0)))
+fit1 = vglm(cbind(y1,y2) ~ x, negbinomial, ndata, trace=TRUE)
+coef(fit1, matrix=TRUE)
# Example 3: large counts so definitely use the nsimEIM argument
-x = runif(n <- 500)
-y = rnbinom(n, mu=exp(12+x), size=exp(1)) # k is size
-range(y) # Large counts
-fit = vglm(y ~ x, negbinomial(nsimEIM=100), trace=TRUE)
-coef(fit, matrix=TRUE)
+ndata = transform(ndata, y3 = rnbinom(nn, mu=exp(12+x), size=exp(1)))
+with(ndata, range(y3)) # Large counts
+fit2 = vglm(y3 ~ x, negbinomial(nsimEIM=100), ndata, trace=TRUE)
+coef(fit2, matrix=TRUE)
}
\keyword{models}
\keyword{regression}
diff --git a/man/normal1.Rd b/man/normal1.Rd
index 196e16b..7ded1f7 100644
--- a/man/normal1.Rd
+++ b/man/normal1.Rd
@@ -36,6 +36,7 @@ normal1(lmean="identity", lsd="loge", emean=list(), esd=list(), zero=NULL)
are modelled as functions of the explanatory variables.
}
+
}
\details{
By default, the mean is the first linear/additive predictor and
@@ -77,18 +78,17 @@ New York: Wiley-Interscience, Third edition.
}
\examples{
-n = 200
-x = rnorm(n)
-y = rnorm(n, mean=1-3*x, sd=exp(1+0.2*x))
-fit = vglm(y ~ x, normal1)
+ndata = data.frame(x = rnorm(nn <- 200))
+ndata = transform(ndata, y = rnorm(nn, mean=1-3*x, sd=exp(1+0.2*x)))
+fit = vglm(y ~ x, normal1, ndata, trace=TRUE)
coef(fit, matrix=TRUE)
# Generate a random sample from a N(mu=theta, sigma=theta)
# distribution with theta=10. Then estimate theta.
theta = 10
-y = rnorm(100, m=theta, sd=theta)
-fit = vglm(y ~ 1, normal1(lsd="identity"),
- constraints=list("(Intercept)"=rbind(1,1)))
+ndata = data.frame(y = rnorm(100, m=theta, sd=theta))
+fit = vglm(y ~ 1, normal1(lsd="identity"), ndata,
+ constraints = list("(Intercept)"=rbind(1,1)))
coef(fit, matrix=TRUE)
}
\keyword{models}
diff --git a/man/nzmarital.Rd b/man/nzmarital.Rd
new file mode 100644
index 0000000..3e00ab7
--- /dev/null
+++ b/man/nzmarital.Rd
@@ -0,0 +1,49 @@
+\name{nzmarital}
+\alias{nzmarital}
+\docType{data}
+\title{
+ New Zealand Marital Data.
+}
+\description{
+ Some marital data mainly from a large NZ company collected in the
+ early 1990s.
+
+}
+\usage{data(nzmarital)}
+\format{
+ A data frame with 6053 observations on the following 3 variables.
+ \describe{
+ \item{\code{age}}{a numeric vector, age in years}
+ \item{\code{ethnicity}}{a factor with levels \code{European}
+ \code{Maori} \code{Other} \code{Polynesian}.
+ Only Europeans are included in the data set.
+ }
+
+ \item{\code{mstatus}}{a factor with levels
+ \code{Divorced/Separated} \code{Married/Partnered} \code{Single} \code{Widowed}.
+ }
+ }
+}
+\details{
+This is a subset of a data set collected from a self-administered
+questionnaire administered in a large New Zealand workforce observational
+study conducted during 1992--3. The data were augmented by a second
+study consisting of retirees. The data can be considered a reasonable
+representation of the white male New Zealand population in the early
+1990s.
+
+}
+\source{
+ Clinical Trials Research Unit, University of Auckland, New Zealand.
+}
+
+\references{
+ See \code{\link{bminz}} and \code{\link{chestnz}}.
+}
+\examples{
+summary(nzmarital)
+}
+\keyword{datasets}
+
+
+
diff --git a/man/paralogistic.Rd b/man/paralogistic.Rd
index 5922aa1..f761490 100644
--- a/man/paralogistic.Rd
+++ b/man/paralogistic.Rd
@@ -7,9 +7,8 @@
paralogistic distribution.
}
\usage{
-paralogistic(link.a = "loge", link.scale = "loge",
- earg.a=list(), earg.scale=list(),
- init.a = 1, init.scale = NULL, zero = NULL)
+paralogistic(link.a = "loge", link.scale = "loge", earg.a=list(),
+ earg.scale=list(), init.a = 1, init.scale = NULL, zero = NULL)
}
%- maybe also 'usage' for other objects documented here.
\arguments{
@@ -86,13 +85,14 @@ default value is not \code{NULL}.
\code{\link{invlomax}},
\code{\link{lomax}},
\code{\link{invparalogistic}}.
+
}
\examples{
-y = rparalogistic(n=3000, 4, 6)
-fit = vglm(y ~ 1, paralogistic, trace=TRUE)
+pdat = data.frame(y = rparalogistic(n=3000, 4, 6))
+fit = vglm(y ~ 1, paralogistic, pdat, trace=TRUE)
fit = vglm(y ~ 1, paralogistic(init.a=2.3, init.sc=5),
- trace=TRUE, crit="c")
+ pdat, trace=TRUE, crit="c")
coef(fit, mat=TRUE)
Coef(fit)
summary(fit)
diff --git a/man/pareto1.Rd b/man/pareto1.Rd
index 46e9ce9..5d7703d 100644
--- a/man/pareto1.Rd
+++ b/man/pareto1.Rd
@@ -155,26 +155,25 @@ tpareto1(lower, upper, lshape = "loge", earg=list(), ishape=NULL,
}
\examples{
alpha = 2; k = exp(3)
-y = rpareto(n=1000, location=alpha, shape=k)
-fit = vglm(y ~ 1, pareto1, trace=TRUE)
+pdat = data.frame(y = rpareto(n=1000, location=alpha, shape=k))
+fit = vglm(y ~ 1, pareto1, pdat, trace=TRUE)
fit at extra # The estimate of alpha is here
head(fitted(fit))
-mean(y)
+with(pdat, mean(y))
coef(fit, matrix=TRUE)
summary(fit) # Standard errors are incorrect!!
# Here, alpha is assumed known
-fit2 = vglm(y ~ 1, pareto1(location=alpha), trace=TRUE, crit="c")
+fit2 = vglm(y ~ 1, pareto1(location=alpha), pdat, trace=TRUE, crit="c")
fit2 at extra # alpha stored here
head(fitted(fit2))
-mean(y)
coef(fit2, matrix=TRUE)
summary(fit2) # Standard errors are ok
# Upper truncated Pareto distribution
lower = 2; upper = 8; k = exp(2)
-y = rtpareto(n=100, lower=lower, upper=upper, shape=k)
-fit3 = vglm(y ~ 1, tpareto1(lower, upper), trace=TRUE, cri="c")
+pdat3 = data.frame(y = rtpareto(n=100, lower=lower, upper=upper, shape=k))
+fit3 = vglm(y ~ 1, tpareto1(lower, upper), pdat3, trace=TRUE, cri="c")
coef(fit3, matrix=TRUE)
c(fit3 at misc$lower, fit3 at misc$upper)
}
diff --git a/man/paretoIV.Rd b/man/paretoIV.Rd
index 6c76ef7..1ba2e8d 100644
--- a/man/paretoIV.Rd
+++ b/man/paretoIV.Rd
@@ -148,9 +148,9 @@ Fairland, Maryland: International Cooperative Publishing House.
\code{\link{gpd}}.
}
\examples{
-y = rparetoIV(n <- 2000, scale=exp(1), ineq=exp(-0.3), shape=exp(1))
-\dontrun{par(mfrow=c(2,1)); hist(y); hist(log(y)); }
-fit = vglm(y ~ 1, paretoIV, trace=TRUE)
+pdat = data.frame(y=rparetoIV(2000, scal=exp(1), ineq=exp(-0.3), shap=exp(1)))
+\dontrun{par(mfrow=c(2,1)); with(pdat, hist(y)); with(pdat, hist(log(y))) }
+fit = vglm(y ~ 1, paretoIV, pdat, trace=TRUE)
coef(fit, matrix=TRUE)
Coef(fit)
summary(fit)
diff --git a/man/persp.qrrvglm.Rd b/man/persp.qrrvglm.Rd
index 77238ba..b087408 100644
--- a/man/persp.qrrvglm.Rd
+++ b/man/persp.qrrvglm.Rd
@@ -10,13 +10,13 @@ applicable for rank-1 or rank-2 models with argument \code{Norrr = ~ 1}.
\usage{
persp.qrrvglm(x, varlvI = FALSE, reference = NULL, plot.it = TRUE,
xlim=NULL, ylim=NULL, zlim=NULL,
- gridlength=if(Rank==1) 301 else c(51,51),
+ gridlength = if (Rank==1) 301 else c(51,51),
whichSpecies = NULL,
- xlab = if(Rank==1) "Latent Variable" else "Latent Variable 1",
- ylab = if(Rank==1) "Expected Value" else "Latent Variable 2",
+ xlab = if (Rank==1) "Latent Variable" else "Latent Variable 1",
+ ylab = if (Rank==1) "Expected Value" else "Latent Variable 2",
zlab = "Expected value", labelSpecies = FALSE,
stretch = 1.05, main="", ticktype = "detailed",
- col = if(Rank==1) par()$col else "white",
+ col = if (Rank==1) par()$col else "white",
llty=par()$lty, llwd=par()$lwd,
add1 = FALSE, ...)
}
@@ -206,7 +206,7 @@ r2 = cqo(cbind(Alopacce, Alopcune, Alopfabr, Arctlute, Arctperi,
sort(r1 at misc$deviance.Bestof) # A history of the fits
sort(r2 at misc$deviance.Bestof) # A history of the fits
-if(deviance(r2) > 857) stop("suboptimal fit obtained")
+if (deviance(r2) > 857) stop("suboptimal fit obtained")
persp(r1, xlim=c(-6,5), col=1:4, label=TRUE)
@@ -219,5 +219,5 @@ persp(r2, xlim=c(-6,5), ylim=c(-4,5), theta=10, phi=20, zlim=c(0,220),
}
\keyword{models}
\keyword{regression}
-\keyword{hplot}
+\keyword{graphs}
diff --git a/man/plackUC.Rd b/man/plackUC.Rd
index 7997c74..25dec0a 100644
--- a/man/plackUC.Rd
+++ b/man/plackUC.Rd
@@ -55,19 +55,18 @@ Some contributions to contingency-type distributions.
}
\examples{
\dontrun{
-N = 101
+N = 101; oratio = exp(1)
x = seq(0.0, 1.0, len=N)
-oratio = exp(1)
ox = expand.grid(x, x)
z = dplack(ox[,1], ox[,2], oratio=oratio)
contour(x, x, matrix(z, N, N), col="blue")
z = pplack(ox[,1], ox[,2], oratio=oratio)
contour(x, x, matrix(z, N, N), col="blue")
-plot(r <- rplack(n=3000, oratio=oratio))
+plot(rr <- rplack(n=3000, oratio=oratio))
par(mfrow=c(1,2))
-hist(r[,1]) # Should be uniform
-hist(r[,2]) # Should be uniform
+hist(rr[,1]) # Should be uniform
+hist(rr[,2]) # Should be uniform
}
}
\keyword{distribution}
diff --git a/man/plotdeplot.lmscreg.Rd b/man/plotdeplot.lmscreg.Rd
index 5b020fa..483f2c7 100644
--- a/man/plotdeplot.lmscreg.Rd
+++ b/man/plotdeplot.lmscreg.Rd
@@ -8,8 +8,7 @@
}
\usage{
plotdeplot.lmscreg(answer, y.arg, add.arg = FALSE,
- xlab = "", ylab = "density",
- xlim = NULL, ylim = NULL,
+ xlab = "", ylab = "density", xlim = NULL, ylim = NULL,
llty.arg = par()$lty, col.arg = par()$col,
llwd.arg = par()$lwd, ...)
}
diff --git a/man/plotqtplot.lmscreg.Rd b/man/plotqtplot.lmscreg.Rd
index 9c79d06..6b0b3a3 100644
--- a/man/plotqtplot.lmscreg.Rd
+++ b/man/plotqtplot.lmscreg.Rd
@@ -104,6 +104,6 @@ qtplot(fit, perc=c(25,50,75,95), lcol="blue", tcol="blue", llwd=2)
}
}
-\keyword{hplot}
+\keyword{graphs}
\keyword{models}
\keyword{regression}
diff --git a/man/plotvgam.Rd b/man/plotvgam.Rd
index 2b0df5f..22166c1 100644
--- a/man/plotvgam.Rd
+++ b/man/plotvgam.Rd
@@ -17,9 +17,6 @@ plotvgam(x, newdata = NULL, y = NULL, residuals = NULL,
}
%- maybe also 'usage' for other objects documented here.
\arguments{
- In the following, \eqn{M} is the number of linear/additive
- predictors, and \eqn{r} is the number of columns of the
- constraint matrix of interest.
\item{x}{ A fitted \pkg{VGAM} object, e.g., produced by
\code{vgam()}, \code{vglm()}, or \code{rrvglm()}. }
@@ -104,6 +101,11 @@ plotvgam(x, newdata = NULL, y = NULL, residuals = NULL,
}
\details{
+ In this help file \eqn{M} is the number of linear/additive
+ predictors, and \eqn{r} is the number of columns of the
+ constraint matrix of interest.
+
+
Many of \code{plotvgam()}'s options can be found in
\code{\link{plotvgam.control}}, e.g., line types, line widths,
colors.
@@ -151,7 +153,6 @@ fit = vgam(cbind(nBnW,nBW,BnW,BW) ~ s(Age), binom2.or(zero=NULL), coalminers)
\dontrun{
par(mfrow=c(1,3))
plot(fit, se=TRUE, ylim=c(-3,2), las=1)
-
plot(fit, se=TRUE, which.cf=1:2, lcol="blue", scol="red", ylim=c(-3,2))
plot(fit, se=TRUE, which.cf=1:2, lcol="blue", scol="red", overlay=TRUE)
}
@@ -159,4 +160,4 @@ plot(fit, se=TRUE, which.cf=1:2, lcol="blue", scol="red", overlay=TRUE)
\keyword{models}
\keyword{regression}
\keyword{smooth}
-\keyword{hplot}
+\keyword{graphs}
diff --git a/man/plotvgam.control.Rd b/man/plotvgam.control.Rd
index 476e26d..9e0b8c0 100644
--- a/man/plotvgam.control.Rd
+++ b/man/plotvgam.control.Rd
@@ -8,13 +8,13 @@
}
\usage{
plotvgam.control(which.cf = NULL,
- xlim = NULL, ylim = NULL, llty = par()$lty,
- slty = "dashed", pcex = par()$cex,
- pch = par()$pch, pcol = par()$col,
- lcol = par()$col, rcol = par()$col,
- scol = par()$col, llwd = par()$lwd, slwd = par()$lwd,
- add.arg = FALSE, one.at.a.time = FALSE,
- .include.dots = TRUE, noxmean= FALSE, ...)
+ xlim = NULL, ylim = NULL, llty = par()$lty,
+ slty = "dashed", pcex = par()$cex,
+ pch = par()$pch, pcol = par()$col,
+ lcol = par()$col, rcol = par()$col,
+ scol = par()$col, llwd = par()$lwd, slwd = par()$lwd,
+ add.arg = FALSE, one.at.a.time = FALSE,
+ .include.dots = TRUE, noxmean= FALSE, ...)
}
%- maybe also 'usage' for other objects documented here.
\arguments{
diff --git a/man/pneumo.Rd b/man/pneumo.Rd
index 3acc55c..64f56f7 100644
--- a/man/pneumo.Rd
+++ b/man/pneumo.Rd
@@ -33,7 +33,6 @@ data set, the two most severe categories were combined.
\examples{
# Fit the proportional odds model, p.179, in McCullagh and Nelder (1989)
pneumo = transform(pneumo, let=log(exposure.time))
-vglm(cbind(normal,mild,severe) ~ let,
- cumulative(parallel=TRUE, reverse=TRUE), pneumo)
+vglm(cbind(normal,mild,severe) ~ let, propodds, pneumo)
}
\keyword{datasets}
diff --git a/man/poissonff.Rd b/man/poissonff.Rd
index 89f24c3..c272a3c 100644
--- a/man/poissonff.Rd
+++ b/man/poissonff.Rd
@@ -139,25 +139,23 @@ poissonff(link = "loge", earg=list(), dispersion = 1, onedpar = FALSE,
\examples{
poissonff()
-x = rnorm(n <- 100)
-y = rpois(n, exp(1+x))
-(fit = vglm(y ~ x, family=poissonff))
+pdat = data.frame(x = rnorm(nn <- 100))
+pdat = transform(pdat, y = rpois(nn, exp(1+x)))
+(fit = vglm(y ~ x, family=poissonff, pdat))
coef(fit, matrix=TRUE)
-
-x2 = rnorm(n <- 100)
-x3 = rnorm(n)
-x4 = rnorm(n)
-lv1 = 0 + x3 - 2*x4
-lambda1 = exp(3 - 0.5 * (lv1-0)^2)
-lambda2 = exp(2 - 0.5 * (lv1-1)^2)
-lambda3 = exp(2 - 0.5 * ((lv1+4)/2)^2)
-y1 = rpois(n, lambda1)
-y2 = rpois(n, lambda2)
-y3 = rpois(n, lambda3)
-p1 = cqo(cbind(y1,y2,y3) ~ x2 + x3 + x4, poissonff, EqualTol=FALSE,
- ITol=FALSE)
-summary(p1) # # Three dispersion parameters are all unity
+nn = 200
+cdat = data.frame(x2 = rnorm(nn), x3 = rnorm(nn), x4 = rnorm(nn))
+cdat = transform(cdat, lv1 = 0 + x3 - 2*x4)
+cdat = transform(cdat, lambda1 = exp(3 - 0.5 * (lv1-0)^2),
+ lambda2 = exp(2 - 0.5 * (lv1-1)^2),
+ lambda3 = exp(2 - 0.5 * ((lv1+4)/2)^2))
+cdat = transform(cdat, y1 = rpois(nn, lambda1),
+ y2 = rpois(nn, lambda2),
+ y3 = rpois(nn, lambda3))
+# vvv p1 = cqo(cbind(y1,y2,y3) ~ x2 + x3 + x4, poissonff, cdat,
+# vvv EqualTol=FALSE, ITol=FALSE)
+# vvv summary(p1) # # Three dispersion parameters are all unity
\dontrun{
lvplot(p1, y=TRUE, lcol=2:4, pch=2:4, pcol=2:4, rug=FALSE)
}
diff --git a/man/poissonp.Rd b/man/poissonp.Rd
index fb914ba..6275880 100644
--- a/man/poissonp.Rd
+++ b/man/poissonp.Rd
@@ -92,16 +92,17 @@ poissonp(ostatistic, dimension=2, link="loge", earg=list(),
%}
\seealso{
\code{\link{poissonff}}.
+
}
\examples{
-y = rgamma(n <- 10, shape=exp(-1)) # Not good data!
+pdat = data.frame(y = rgamma(10, shape=exp(-1))) # Not good data!
os = 2
-fit = vglm(y ~ 1, poissonp(os, 2), tra=TRUE, cri="c")
-fit = vglm(y ~ 1, poissonp(os, 3), tra=TRUE, cri="c") # Slow convergence?
-fit = vglm(y ~ 1, poissonp(os, 3, idensi=1), tra=TRUE, cri="c")
+fit = vglm(y ~ 1, poissonp(os, 2), pdat, tra=TRUE, crit="c")
+fit = vglm(y ~ 1, poissonp(os, 3), pdat, tra=TRUE, crit="c") # Slow convergence?
+fit = vglm(y ~ 1, poissonp(os, 3, idensi=1), pdat, trace=TRUE, crit="c")
head(fitted(fit))
-mean(y)
-coef(fit, matrix=TRUE)
+with(pdat, mean(y))
+coef(fit, matrix = TRUE)
Coef(fit)
}
\keyword{models}
diff --git a/man/polf.Rd b/man/polf.Rd
index fad43a9..a622aa8 100644
--- a/man/polf.Rd
+++ b/man/polf.Rd
@@ -117,39 +117,36 @@ plot(p, y, type="l", col="blue", main="polf()")
abline(h=0, v=0.5, col="red", lty="dashed")
plot(p, y., type="l", col="blue",
- main="(Reciprocal of) first POLF derivative")
-}
+ main="(Reciprocal of) first POLF derivative") }
# Rutherford and Geiger data
-ruge = c(57,203,383,525,532,408,273,139,45,27,10,4,0,1,1)
-y = 0:14
-yy = rep(y, times=ruge)
-length(yy) # 2608 1/8-minute intervals
+ruge = data.frame(yy = rep(0:14,
+ times=c(57,203,383,525,532,408,273,139,45,27,10,4,0,1,1)))
+
+with(ruge, length(yy)) # 2608 1/8-minute intervals
cutpoint = 5
-yy01 = ifelse(yy <= cutpoint, 0, 1)
+ruge = transform(ruge, yy01 = ifelse(yy <= cutpoint, 0, 1))
earg = list(cutpoint=cutpoint)
-fit = vglm(yy01 ~ 1, binomialff(link="polf", earg=earg))
+fit = vglm(yy01 ~ 1, binomialff(link="polf", earg=earg), ruge)
coef(fit, matrix=TRUE)
exp(coef(fit))
# Another example
-nn = 1000
-x2 = sort(runif(nn))
-x3 = runif(nn)
-mymu = exp( 3 + 1 * x2 - 2 * x3)
-y1 = rpois(nn, lambda=mymu)
+pdat = data.frame(x2 = sort(runif(nn <- 1000)))
+pdat = transform(pdat, x3 = runif(nn))
+pdat = transform(pdat, mymu = exp( 3 + 1 * x2 - 2 * x3))
+pdat = transform(pdat, y1 = rpois(nn, lambda=mymu))
cutpoints = c(-Inf, 10, 20, Inf)
-cuty = Cut(y1, breaks=cutpoints)
+pdat = transform(pdat, cuty = Cut(y1, breaks=cutpoints))
\dontrun{
-plot(x2, x3, col=cuty, pch=as.character(cuty))
-}
-table(cuty) / sum(table(cuty))
+with(pdat, plot(x2, x3, col=cuty, pch=as.character(cuty))) }
+with(pdat, table(cuty) / sum(table(cuty)))
fit = vglm(cuty ~ x2 + x3, fam = cumulative(link="polf",
reverse=TRUE, parallel=TRUE, intercept.apply=TRUE,
mv=TRUE, earg=list(cutpoint=cutpoints[2:3])),
- trace=TRUE)
+ pdat, trace=TRUE)
head(fit at y)
head(fitted(fit))
head(predict(fit))
diff --git a/man/polonoUC.Rd b/man/polonoUC.Rd
index 68990ab..4474eb9 100644
--- a/man/polonoUC.Rd
+++ b/man/polonoUC.Rd
@@ -96,8 +96,7 @@ rpolono(n, meanlog=0, sdlog=1)
}
\examples{
-meanlog = 0.5; sdlog = 0.5
-y = 0:19
+meanlog = 0.5; sdlog = 0.5; y = 0:19
proby = dpolono(y, m=meanlog, sd=sdlog)
sum(proby) # Should be 1
\dontrun{
@@ -118,8 +117,7 @@ plot(y, proby, type="h", col="blue", ylab="P[Y=y]", log="y",
# Random number generation
table(y <- rpolono(n=1000, m=meanlog, sd=sdlog))
hist(y, breaks=((-1):max(y))+0.5, prob=TRUE, border="blue")
-par(opar)
-}
+par(opar) }
}
\keyword{distribution}
diff --git a/man/posbinomUC.Rd b/man/posbinomUC.Rd
index 7f780f7..9f2b0ac 100644
--- a/man/posbinomUC.Rd
+++ b/man/posbinomUC.Rd
@@ -73,15 +73,15 @@ rposbinom(n, size, prob)
\code{\link[stats:Binomial]{rbinom}}.
}
\examples{
-prob = 0.2
-size = 10
+prob = 0.2; size = 10
y = rposbinom(n=1000, size, prob)
+
table(y)
mean(y) # Sample mean
prob / (1-(1-prob)^size) # Population mean
-(i = dposbinom(0:size, size, prob))
-cumsum(i) - pposbinom(0:size, size, prob) # Should be 0s
+(ii = dposbinom(0:size, size, prob))
+cumsum(ii) - pposbinom(0:size, size, prob) # Should be 0s
table(rposbinom(100, size, prob))
table(qposbinom(runif(1000), size, prob))
@@ -93,8 +93,7 @@ barplot(rbind(dposbinom(x, 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(x), las=1)
-}
+ names.arg = as.character(x), las=1) }
}
\keyword{distribution}
diff --git a/man/posbinomial.Rd b/man/posbinomial.Rd
index ac3cf3a..eb929c9 100644
--- a/man/posbinomial.Rd
+++ b/man/posbinomial.Rd
@@ -24,13 +24,13 @@ posbinomial(link = "logit", earg=list())
\details{
The positive binomial distribution is the ordinary binomial distribution
but with the probability of zero being zero.
- Thus the other probabilities are scaled up (i.e., divided by 1-P(Y=0)).
+ Thus the other probabilities are scaled up
+ (i.e., divided by \eqn{1-P(Y=0)}{1-P(Y=0)}).
}
\value{
An object of class \code{"vglmff"} (see \code{\link{vglmff-class}}).
The object is used by modelling functions such as \code{\link{vglm}},
- \code{\link{rrvglm}}
and \code{\link{vgam}}.
}
@@ -59,26 +59,21 @@ parameter.
\section{Warning }{
Under- or over-flow may occur if the data is ill-conditioned.
+
}
\seealso{
\code{\link{binomialff}}.
}
\examples{
-# Number of albinotic children in families with 5 children
-# Data from Patil (1962)
-y = c(rep(1,25), rep(2,23), rep(3,10), 4, 5) # No zeros
-n = rep(5, 60)
-yprop = y / 5
-# Fit the identical models in two ways; MLE of p is 0.3088
-fit = vglm(yprop ~ 1, posbinomial, trace=TRUE, weights=n)
-fit2 = vglm(cbind(y, n-y) ~ 1, posbinomial, trace=TRUE)
-summary(fit)
-summary(fit2)
-Coef(fit2) # = MLE of p
-Coef(fit) # = MLE of p
+# Number of albinotic children in families with 5 kids (from Patil, 1962)
+akids = data.frame(y = c(rep(1,25), rep(2,23), rep(3,10), 4,5), n=rep(5,60))
+akids = transform(akids, yprop = y / 5)
+fit1 = vglm(yprop~1, posbinomial, akids, trace=TRUE, weights=n)
+fit2 = vglm(cbind(y,n-y)~1, posbinomial, akids, trace=TRUE) # Same model
+summary(fit1)
+Coef(fit2) # = MLE of p = 0.3088
head(fitted(fit2))
-head(fitted(fit))
}
\keyword{models}
\keyword{regression}
diff --git a/man/posnegbinUC.Rd b/man/posnegbinUC.Rd
index e7b79c5..98e1bea 100644
--- a/man/posnegbinUC.Rd
+++ b/man/posnegbinUC.Rd
@@ -106,8 +106,7 @@ 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=""),
- names.arg = as.character(x))
-}
+ names.arg = as.character(x)) }
# Another test for pposnegbin()
nn = 5000
diff --git a/man/posnegbinomial.Rd b/man/posnegbinomial.Rd
index 388cbe1..e9e11f3 100644
--- a/man/posnegbinomial.Rd
+++ b/man/posnegbinomial.Rd
@@ -8,9 +8,9 @@
}
\usage{
-posnegbinomial(lmunb = "loge", lk = "loge",
- emunb =list(), ek = list(), ik = NULL, zero = -2,
- cutoff = 0.995, shrinkage.init=0.95, method.init=1)
+posnegbinomial(lmunb = "loge", lk = "loge", emunb =list(), ek = list(),
+ ik = NULL, zero = -2, cutoff = 0.995, shrinkage.init=0.95,
+ method.init=1)
}
%- maybe also 'usage' for other objects documented here.
\arguments{
@@ -111,6 +111,12 @@ Generalized additive modelling and zero inflated count data.
\bold{157},
179--188.
+Williamson, E. and Bretherton, M. H. (1964)
+Tables of the logarithmic series distribution.
+\emph{Annals of Mathematical Statistics},
+\bold{35},
+284--297.
+
}
\author{ Thomas W. Yee }
\note{
@@ -128,26 +134,39 @@ Generalized additive modelling and zero inflated count data.
}
\examples{
-x = runif(nn <- 2000)
-y1 = rposnegbin(nn, munb=exp(0+2*x), size=exp(1))
-y2 = rposnegbin(nn, munb=exp(1+2*x), size=exp(3))
-fit = vglm(cbind(y1,y2) ~ x, posnegbinomial, trace=TRUE)
+pndat = data.frame(x = runif(nn <- 2000))
+pndat = transform(pndat, y1 = rposnegbin(nn, munb=exp(0+2*x), size=exp(1)),
+ y2 = rposnegbin(nn, munb=exp(1+2*x), size=exp(3)))
+fit = vglm(cbind(y1,y2) ~ x, posnegbinomial, pndat, trace=TRUE)
coef(fit, matrix=TRUE)
dim(fit at y)
# Another artificial data example
-munb = exp(2); size = k = exp(3); nn = 1000
-y = rposnegbin(nn, munb=munb, size=size)
-table(y)
-fit = vglm(y ~ 1, posnegbinomial, trace=TRUE)
+pndat2 = data.frame(munb = exp(2), size = exp(3)); nn = 1000
+pndat2 = transform(pndat2, y = rposnegbin(nn, munb=munb, size=size))
+with(pndat2, table(y))
+fit = vglm(y ~ 1, posnegbinomial, pndat2, trace=TRUE)
+coef(fit, matrix=TRUE)
+with(pndat2, mean(y)) # Sample mean
+head(with(pndat2, munb/(1-(size/(size+munb))^size)), 1) # Population mean
+head(fitted(fit), 3)
+head(predict(fit), 3)
+
+
+# Example: Corbet (1943) butterfly Malaya data
+corbet = data.frame(nindiv = 1:24,
+ ofreq = c(118, 74, 44, 24, 29, 22, 20, 19, 20, 15, 12,
+ 14, 6, 12, 6, 9, 9, 6, 10, 10, 11, 5, 3, 3))
+fit = vglm(nindiv ~ 1, posnegbinomial, weights=ofreq, data=corbet)
coef(fit, matrix=TRUE)
-mean(y) # Sample mean
-munb / (1 - (size/(size+munb))^size) # Population mean
-head(fitted(fit))
-head(predict(fit))
+Coef(fit)
+(khat = Coef(fit)['k'])
+pdf2 = dposnegbin(x=with(corbet, nindiv), mu=fitted(fit), size=khat)
+print( with(corbet, cbind(nindiv, ofreq, fitted=pdf2*sum(ofreq))), dig=1)
}
\keyword{models}
\keyword{regression}
+% bigN = with(corbet, sum(ofreq))
diff --git a/man/posnormUC.Rd b/man/posnormUC.Rd
index 8ccd3b1..7a1f72a 100644
--- a/man/posnormUC.Rd
+++ b/man/posnormUC.Rd
@@ -45,8 +45,7 @@ rposnorm(n, mean=0, sd=1)
}
\examples{
\dontrun{
-m = 0.8
-x = seq(-1, 4, len=501)
+m = 0.8; x = seq(-1, 4, len=501)
plot(x, dposnorm(x, m=m), type="l", ylim=0:1, las=1,
ylab=paste("posnorm(m=",m,", sd=1)"), col="blue",
main="Blue is density, red is cumulative distribution function",
diff --git a/man/posnormal1.Rd b/man/posnormal1.Rd
index 9879c63..e03f6fb 100644
--- a/man/posnormal1.Rd
+++ b/man/posnormal1.Rd
@@ -6,8 +6,7 @@
Fits a positive (univariate) normal distribution.
}
\usage{
-posnormal1(lmean="identity", lsd="loge",
- emean=list(), esd=list(),
+posnormal1(lmean="identity", lsd="loge", emean=list(), esd=list(),
imean=NULL, isd=NULL, nsimEIM = 100, zero=NULL)
}
%- maybe also 'usage' for other objects documented here.
@@ -102,13 +101,15 @@ posnormal1(lmean="identity", lsd="loge",
}
\examples{
-m = 1.0; SD = exp(1.0)
-y = rposnorm(n <- 1000, m=m, sd=SD)
-\dontrun{hist(y, prob=TRUE, main=paste("posnorm(m=",m,", sd=",round(SD,2),")"))}
-fit = vglm(y ~ 1, fam=posnormal1, trace=TRUE)
+pndat = data.frame(m = 1.0, SD = exp(1.0))
+pndat = transform(pndat, y = rposnorm(n <- 1000, m=m, sd=SD))
+
+\dontrun{with(pndat, hist(y, prob=TRUE, border="blue",
+ main=paste("posnorm(m=",m[1],", sd=",round(SD[1],2),")"))) }
+fit = vglm(y ~ 1, fam=posnormal1, pndat, trace=TRUE)
coef(fit, mat=TRUE)
(Cfit = Coef(fit))
-mygrid = seq(min(y), max(y), len=200) # Add the fit to the histogram
+mygrid = with(pndat, seq(min(y), max(y), len=200)) # Add the fit to the histogram
\dontrun{lines(mygrid, dposnorm(mygrid, Cfit[1], Cfit[2]), col="red")}
}
\keyword{models}
diff --git a/man/pospoisUC.Rd b/man/pospoisUC.Rd
index 0a50a18..9fca271 100644
--- a/man/pospoisUC.Rd
+++ b/man/pospoisUC.Rd
@@ -69,14 +69,13 @@ rpospois(n, lambda)
\code{\link[stats:Poisson]{rpois}}.
}
\examples{
-lambda = 2
-y = rpospois(n=1000, lambda)
+lambda = 2; y = rpospois(n=1000, lambda)
table(y)
mean(y) # Sample mean
lambda / (1-exp(-lambda)) # Population mean
-(i = dpospois(0:7, lambda))
-cumsum(i) - ppospois(0:7, lambda) # Should be 0s
+(ii = dpospois(0:7, lambda))
+cumsum(ii) - ppospois(0:7, lambda) # Should be 0s
table(rpospois(100, lambda))
table(qpospois(runif(1000), lambda))
@@ -88,8 +87,7 @@ barplot(rbind(dpospois(x, lambda), dpois(x, lambda)),
beside = TRUE, col = c("blue","green"),
main=paste("Positive Poisson(", lambda, ") (blue) vs",
" Poisson(", lambda, ") (green)", sep=""),
- names.arg = as.character(x), las=1, lwd=2)
-}
+ names.arg = as.character(x), las=1, lwd=2) }
}
\keyword{distribution}
diff --git a/man/pospoisson.Rd b/man/pospoisson.Rd
index fb3aa47..66929ed 100644
--- a/man/pospoisson.Rd
+++ b/man/pospoisson.Rd
@@ -56,6 +56,7 @@ pospoisson(link = "loge", earg=list(),
}
\section{Warning }{
Under- or over-flow may occur if the data is ill-conditioned.
+
}
\value{
@@ -72,6 +73,7 @@ The equilibrium size distribution of freely-forming groups.
Documentation accompanying the \pkg{VGAM} package at
\url{http://www.stat.auckland.ac.nz/~yee}
contains further information and examples.
+
}
\author{ Thomas W. Yee }
\note{
@@ -86,21 +88,22 @@ contains further information and examples.
\code{\link{posnegbinomial}},
\code{\link{poissonff}},
\code{\link{zipoisson}}.
+
}
\examples{
-y = 1:6
-w = c(1486, 694, 195, 37, 10, 1) # Data from Coleman and James (1961)
-fit = vglm(y ~ 1, pospoisson, weights=w)
+# Data from Coleman and James (1961)
+cjdat = data.frame(y = 1:6, w = c(1486, 694, 195, 37, 10, 1))
+fit = vglm(y ~ 1, pospoisson, cjdat, weights=w)
Coef(fit)
summary(fit)
fitted(fit)
# Artificial data
-x = runif(n <- 1000)
-lambda = exp(1 - 2*x)
-y = rpospois(n, lambda)
-table(y)
-fit = vglm(y ~ x, pospoisson, trace=TRUE, crit="c")
+pdat = data.frame(x = runif(nn <- 1000))
+pdat = transform(pdat, lambda = exp(1 - 2*x))
+pdat = transform(pdat, y = rpospois(nn, lambda))
+with(pdat, table(y))
+fit = vglm(y ~ x, pospoisson, pdat, trace=TRUE, crit="c")
coef(fit, matrix=TRUE)
}
\keyword{models}
diff --git a/man/powl.Rd b/man/powl.Rd
index 52ad832..b7accdf 100644
--- a/man/powl.Rd
+++ b/man/powl.Rd
@@ -97,9 +97,10 @@ max(abs(powl(powl(x, earg=earg), earg=earg, inverse=TRUE) - x)) # Should be 0
powl(x <- (-5):5, earg=list(power=0.5)) # Has NAs
# 1/2 = 0.5
-y = rbeta(n=1000, shape1=2^2, shape2=3^2)
+pdat = data.frame(y = rbeta(n=1000, shape1=2^2, shape2=3^2))
fit = vglm(y ~ 1, beta.ab(lshape1="powl", lshape2="powl",
- eshape1=list(power=0.5), eshape2=list(power=0.5), i1=3, i2=7))
+ eshape1=list(power=0.5), i1=3,
+ eshape2=list(power=0.5), i2=7), pdat)
t(coef(fit, matrix=TRUE))
Coef(fit) # Useful for intercept-only models
vcov(fit, untrans=TRUE)
diff --git a/man/predict.qrrvglm.Rd b/man/predict.qrrvglm.Rd
index b9a6bf3..25ca063 100644
--- a/man/predict.qrrvglm.Rd
+++ b/man/predict.qrrvglm.Rd
@@ -67,17 +67,17 @@ canonical Gaussian ordination.
\examples{
hspider[,1:6]=scale(hspider[,1:6]) # Standardize the environmental variables
set.seed(1234)
-p1 = cqo(cbind(Alopacce, Alopcune, Alopfabr, Arctlute, Arctperi, Auloalbi,
- Pardlugu, Pardmont, Pardnigr, Pardpull, Trocterr, Zoraspin) ~
- WaterCon + BareSand + FallTwig + CoveMoss + CoveHerb + ReflLux,
- fam=poissonff, data=hspider, Crow1positive=FALSE, ITol=TRUE)
-sort(p1 at misc$deviance.Bestof) # A history of all the iterations
+# vvv p1 = cqo(cbind(Alopacce, Alopcune, Alopfabr, Arctlute, Arctperi, Auloalbi,
+# vvv Pardlugu, Pardmont, Pardnigr, Pardpull, Trocterr, Zoraspin) ~
+# vvv WaterCon + BareSand + FallTwig + CoveMoss + CoveHerb + ReflLux,
+# vvv fam=poissonff, data=hspider, Crow1positive=FALSE, ITol=TRUE)
+# vvv sort(p1 at misc$deviance.Bestof) # A history of all the iterations
-head(predict(p1))
+# vvv head(predict(p1))
# The following should be all zeros
-max(abs(predict(p1, new=head(hspider)) - head(predict(p1))))
-max(abs(predict(p1, new=head(hspider), type="res") - head(fitted(p1))))
+# vvv max(abs(predict(p1, new=head(hspider)) - head(predict(p1))))
+# vvv max(abs(predict(p1, new=head(hspider), type="res") - head(fitted(p1))))
}
\keyword{models}
\keyword{regression}
diff --git a/man/predict.vglm.Rd b/man/predict.vglm.Rd
index c909de5..563c9c6 100644
--- a/man/predict.vglm.Rd
+++ b/man/predict.vglm.Rd
@@ -70,6 +70,7 @@ predict.vglm(object, newdata = NULL,
This code implements \emph{smart prediction}
(see \code{\link{smartpred}}).
+
}
\value{
If \code{se.fit = FALSE}, a vector or matrix of predictions.
@@ -97,6 +98,7 @@ Reduced-rank vector generalized linear models.
\section{Warning }{
This function may change in the future.
+
}
\seealso{
@@ -104,14 +106,14 @@ Reduced-rank vector generalized linear models.
\code{\link{vglm}},
\code{predict.vlm},
\code{\link{smartpred}}.
+
}
\examples{
# Illustrates smart prediction
pneumo = transform(pneumo, let=log(exposure.time))
fit = vglm(cbind(normal,mild, severe) ~ poly(c(scale(let)), 2),
- cumulative(parallel=TRUE),
- data=pneumo, trace=TRUE, x=FALSE)
+ propodds, data=pneumo, trace=TRUE, x=FALSE)
class(fit)
(q0 = head(predict(fit)))
diff --git a/man/prentice74.Rd b/man/prentice74.Rd
index 834552a..6a53702 100644
--- a/man/prentice74.Rd
+++ b/man/prentice74.Rd
@@ -81,33 +81,37 @@ else \eqn{q<0} is right skew.
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{
-Prentice, R. L. (1974)
-A log gamma model and its maximum likelihood estimation.
-\emph{Biometrika}, \bold{61}, 539--544.
+ Prentice, R. L. (1974)
+ A log gamma model and its maximum likelihood estimation.
+ \emph{Biometrika}, \bold{61}, 539--544.
+
}
\section{Warning }{
-The special case \eqn{q=0} is not handled, therefore
-estimates of \eqn{q} too close to zero may cause numerical problems.
+ The special case \eqn{q=0} is not handled, therefore
+ estimates of \eqn{q} too close to zero may cause numerical problems.
+
}
\author{ T. W. Yee }
\note{
-The notation used here differs from Prentice (1974):
-\eqn{\alpha=a}{alpha=a},
-\eqn{\sigma=b}{sigma=b}.
-Fisher scoring is used.
+ The notation used here differs from Prentice (1974):
+ \eqn{\alpha=a}{alpha=a},
+ \eqn{\sigma=b}{sigma=b}.
+ Fisher scoring is used.
+
}
\seealso{
-\code{\link{lgamma3ff}},
-\code{\link[base:Special]{lgamma}}.
+ \code{\link{lgamma3ff}},
+ \code{\link[base:Special]{lgamma}}.
+
}
\examples{
-x = runif(n <- 5000)
-loc = -1 + 2*x
-Scale = exp(1+x)
-y = rlgamma(n, loc=loc, scale=Scale, k=1)
-fit = vglm(y ~ x, prentice74(zero=3), trace=TRUE)
+pdat = data.frame(x = runif(nn <- 5000))
+pdat = transform(pdat, loc = -1 + 2*x, Scale = exp(1+x))
+pdat = transform(pdat, y = rlgamma(nn, loc=loc, scale=Scale, k=1))
+fit = vglm(y ~ x, prentice74(zero=3), pdat, trace=TRUE)
coef(fit, matrix=TRUE) # Note the coefficients for location
}
\keyword{models}
diff --git a/man/probit.Rd b/man/probit.Rd
index 782a874..4504993 100644
--- a/man/probit.Rd
+++ b/man/probit.Rd
@@ -108,8 +108,7 @@ lines(p, cloglog(p), col="chocolate", lwd=2)
lines(p, cauchit(p), col="tan", lwd=2)
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=2) }
}
\keyword{math}
\keyword{models}
diff --git a/man/propodds.Rd b/man/propodds.Rd
new file mode 100644
index 0000000..5f253ef
--- /dev/null
+++ b/man/propodds.Rd
@@ -0,0 +1,99 @@
+\name{propodds}
+\alias{propodds}
+\title{ Proportional Odds Model for Ordinal Regression }
+\description{
+ Fits the proportional odds model
+ to a (preferably ordered) factor response.
+
+}
+\usage{
+propodds(reverse=TRUE)
+}
+\arguments{
+
+ \item{reverse}{
+ Logical.
+ Fed into the \code{reverse} argument of \code{\link{cumulative}}.
+
+}
+}
+\details{
+ The \emph{proportional odds model} is a special case from the class of
+ \emph{cumulative link models}.
+ It involves a logit link applied to cumulative probabilities and a
+ strong \emph{parallelism} assumption.
+ A parallelism assumption means there is less chance of
+ numerical problems because the fitted probabilities will remain
+ between 0 and 1; however
+ the \emph{parallelism} assumption ought to be checked,
+ e.g., via a likelihood ratio test.
+ This \pkg{VGAM} family function is merely a shortcut for
+ \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{
+Agresti, A. (2002)
+\emph{Categorical Data Analysis},
+2nd ed. New York: Wiley.
+
+
+Yee, T. W. (2010)
+The \pkg{VGAM} package for categorical data analysis.
+\emph{Journal of Statistical Software},
+\bold{32}, 1--34.
+\url{http://www.jstatsoft.org/v32/i10/}.
+
+
+Yee, T. W. and Wild, C. J. (1996)
+Vector generalized additive models.
+\emph{Journal of the Royal Statistical Society, Series B, Methodological},
+\bold{58}, 481--493.
+
+Documentation accompanying the \pkg{VGAM} package at
+\url{http://www.stat.auckland.ac.nz/~yee}
+contains further information and examples.
+
+}
+\author{ Thomas W. Yee }
+
+\section{Warning }{
+ 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))
+fit at y # Sample proportions
+weights(fit, type="prior") # Number of observations
+coef(fit, matrix=TRUE)
+constraints(fit) # Constraint matrices
+
+# Check that the model is linear in let ----------------------
+fit2 = vgam(cbind(normal, mild, severe) ~ s(let, df=2), propodds, pneumo)
+\dontrun{
+plot(fit2, se=TRUE, lcol=2, scol=2) }
+
+# Check the proportional odds assumption with a LRT ----------
+(fit3 = vglm(cbind(normal, mild, severe) ~ let,
+ cumulative(parallel=FALSE, reverse=TRUE), pneumo))
+pchisq(2*(logLik(fit3)-logLik(fit)),
+ df=length(coef(fit3))-length(coef(fit)), lower.tail=FALSE)
+}
+\keyword{models}
+\keyword{regression}
+
+% pneumo$let = log(pneumo$exposure.time)
diff --git a/man/prplot.Rd b/man/prplot.Rd
new file mode 100644
index 0000000..15f0182
--- /dev/null
+++ b/man/prplot.Rd
@@ -0,0 +1,89 @@
+\name{prplot}
+\alias{prplot}
+\alias{prplot.control}
+%- Also NEED an '\alias' for EACH other topic documented here.
+\title{
+Probability Plots for Categorical Data Analysis
+}
+\description{
+Plots the fitted probabilities for some very simplified special
+cases of categorical data analysis models.
+}
+\usage{
+prplot(object, control = prplot.control(...), ...)
+
+prplot.control(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, rug.arg = FALSE, ...)
+
+}
+%- maybe also 'usage' for other objects documented here.
+\arguments{
+ \item{object}{
+ Currently only an \code{\link{cumulative}} object.
+ This includes a \code{\link{propodds}} object since that
+ \pkg{VGAM} family function is a special case of \code{\link{cumulative}}.
+
+}
+ \item{control}{
+List containing some basic graphical parameters.
+
+}
+ \item{xlab, ylab, main, xlim, ylim, lty }{
+ See \code{\link[graphics]{par}} and \code{...} below.
+
+}
+ \item{col, rcol, lwd, rlwd, las, rug.arg}{
+ See \code{\link[graphics]{par}} and \code{...} below.
+ Arguments starting with \code{r} refer to the rug.
+ Argument \code{rug.arg} is logical: add a rug for the distinct values of the
+ explanatory variable?
+
+}
+ \item{\dots}{
+ Arguments such as \code{xlab} which are fed into \code{prplot.control()}.
+ Only a small selection of graphical arguments from
+ \code{\link[graphics]{par}} are offered.
+
+}
+}
+\details{
+ For models involving one term in the RHS of the formula this function
+ plots the fitted probabilities against the single explanatory variable.
+
+}
+\value{
+ The object is returned invisibly with the \code{preplot} slot assigned.
+ This is obtained by a call to \code{plotvgam()}.
+
+}
+%\references{
+%% ~put references to the literature/web site here ~
+%}
+%\author{
+%T. W. Yee
+%}
+\note{
+ This function is rudimentary.
+}
+
+%% ~Make other sections like Warning with \section{Warning }{....} ~
+
+\seealso{
+ \code{\link{cumulative}}.
+
+}
+\examples{
+pneumo = transform(pneumo, let=log(exposure.time))
+fit = vglm(cbind(normal, mild, severe) ~ let, propodds, pneumo)
+M = fit at misc$M
+\dontrun{
+prplot(fit)
+prplot(fit, lty=1:M, col=(1:M)+2, rug=TRUE, las=1, ylim=c(0,1), rlwd=2) }
+}
+% Add one or more standard keywords, see file 'KEYWORDS' in the
+% R documentation directory.
+\keyword{graphs}
+\keyword{models}
+\keyword{regression}
+
diff --git a/man/qrrvglm.control.Rd b/man/qrrvglm.control.Rd
index a065329..28cba85 100644
--- a/man/qrrvglm.control.Rd
+++ b/man/qrrvglm.control.Rd
@@ -10,41 +10,23 @@
}
\usage{
-qrrvglm.control(Rank = 1,
- Bestof = if(length(Cinit)) 1 else 10,
- checkwz=TRUE,
- Cinit = NULL,
- Crow1positive = TRUE,
- epsilon = 1.0e-06,
- EqualTolerances = ITolerances,
- Etamat.colmax = 10,
- FastAlgorithm = TRUE,
- GradientFunction=TRUE,
- Hstep = 0.001,
+qrrvglm.control(Rank = 1, Bestof = if (length(Cinit)) 1 else 10,
+ checkwz=TRUE, Cinit = NULL, Crow1positive = TRUE,
+ epsilon = 1.0e-06, EqualTolerances = ITolerances,
+ Etamat.colmax = 10, FastAlgorithm = TRUE,
+ GradientFunction=TRUE, Hstep = 0.001,
isdlv = rep(c(2, 1, rep(0.5, len=Rank)), len=Rank),
- iKvector = 0.1,
- iShape = 0.1,
- ITolerances = TRUE,
- maxitl = 40,
- method.init = 1,
- Maxit.optim = 250,
- MUXfactor = rep(7, length=Rank),
- Norrr = ~ 1,
+ iKvector = 0.1, iShape = 0.1, ITolerances = TRUE,
+ maxitl = 40, method.init = 1, Maxit.optim = 250,
+ MUXfactor = rep(7, length=Rank), Norrr = ~ 1,
optim.maxit = 20,
- Parscale = if(ITolerances) 0.001 else 1.0,
- SD.Cinit = 0.02,
- SmallNo = 5.0e-13,
- trace = TRUE,
+ Parscale = if (ITolerances) 0.001 else 1.0,
+ SD.Cinit = 0.02, SmallNo = 5.0e-13, trace = TRUE,
Use.Init.Poisson.QO=TRUE,
wzepsilon = .Machine$double.eps^0.75, ...)
}
%- maybe also `usage' for other objects documented here.
\arguments{
- In the following, \eqn{R} is the \code{Rank}, \eqn{M} is the number
- of linear predictors, and \eqn{S} is the number of responses
- (species).
- Thus \eqn{M=S} for binomial and Poisson responses, and
- \eqn{M=2S} for the negative binomial and 2-parameter gamma distributions.
\item{Rank}{
The numerical rank \eqn{R} of the model, i.e., the
@@ -287,6 +269,12 @@ qrrvglm.control(Rank = 1,
\item{\dots}{ Ignored at present. }
}
\details{
+ In this help file \eqn{R} is the \code{Rank}, \eqn{M} is the number
+ of linear predictors, and \eqn{S} is the number of responses (species).
+ Thus \eqn{M=S} for binomial and Poisson responses, and
+ \eqn{M=2S} for the negative binomial and 2-parameter gamma distributions.
+
+
Recall that the central formula for CQO is
\deqn{\eta = B_1^T x_1 + A \nu +
\sum_{m=1}^M (\nu^T D_m \nu) e_m}{%
@@ -447,36 +435,6 @@ chances of obtaining the global solution.
# Poisson CQO with equal tolerances
set.seed(111) # This leads to the global solution
hspider[,1:6]=scale(hspider[,1:6]) # Good idea when ITolerances = TRUE
-p1 = cqo(cbind(Alopacce, Alopcune, Alopfabr, Arctlute, Arctperi, Auloalbi,
- Pardlugu, Pardmont, Pardnigr, Pardpull, Trocterr, Zoraspin) ~
- WaterCon + BareSand + FallTwig + CoveMoss + CoveHerb + ReflLux,
- ITolerances = TRUE,
- fam = quasipoissonff, data = hspider)
-sort(p1 at misc$deviance.Bestof) # A history of all the iterations
-
-(isdlv = sd(lv(p1))) # should be approx isdlv
-
-# Refit the model with better initial values
-set.seed(111) # This leads to the global solution
-p1 = cqo(cbind(Alopacce, Alopcune, Alopfabr, Arctlute, Arctperi, Auloalbi,
- Pardlugu, Pardmont, Pardnigr, Pardpull, Trocterr, Zoraspin) ~
- WaterCon + BareSand + FallTwig + CoveMoss + CoveHerb + ReflLux,
- ITolerances = TRUE, isdlv = isdlv, # Note the use of isdlv here
- fam = quasipoissonff, data = hspider)
-sort(p1 at misc$deviance.Bestof) # A history of all the iterations
-
-# Negative binomial CQO; smallest deviance is about 275.389
-set.seed(111) # This leads to the global solution
-nb1 = cqo(cbind(Alopacce, Alopcune, Alopfabr, Arctlute, Arctperi, Auloalbi,
- Pardlugu, Pardmont, Pardnigr, Pardpull, Trocterr, Zoraspin) ~
- WaterCon + BareSand + FallTwig + CoveMoss + CoveHerb + ReflLux,
- ITol = FALSE, EqualTol = TRUE, # A good idea for negbinomial
- fam = negbinomial, data = hspider)
-sort(nb1 at misc$deviance.Bestof) # A history of all the iterations
-summary(nb1)
-\dontrun{
-lvplot(nb1, lcol=1:12, y=TRUE, pcol=1:12)
-}
}
\keyword{models}
\keyword{regression}
diff --git a/man/qtplot.gumbel.Rd b/man/qtplot.gumbel.Rd
index 988eaa3..0c1c95b 100644
--- a/man/qtplot.gumbel.Rd
+++ b/man/qtplot.gumbel.Rd
@@ -104,7 +104,7 @@ qtplot(fit1, perc=97, mpv=FALSE, lcol=3, tcol=3,
head(i at post$qtplot$fitted)
}
}
-\keyword{hplot}
+\keyword{graphs}
\keyword{models}
\keyword{regression}
diff --git a/man/qtplot.lmscreg.Rd b/man/qtplot.lmscreg.Rd
index 67b7f9c..6379100 100644
--- a/man/qtplot.lmscreg.Rd
+++ b/man/qtplot.lmscreg.Rd
@@ -74,7 +74,7 @@ qtplot(fit)
qtplot(fit, perc=c(25,50,75,95), lcol="blue", tcol="blue", llwd=2)
}
}
-\keyword{hplot}
+\keyword{graphs}
\keyword{models}
\keyword{regression}
diff --git a/man/rcqo.Rd b/man/rcqo.Rd
index 06ecda6..07ebe1c 100644
--- a/man/rcqo.Rd
+++ b/man/rcqo.Rd
@@ -354,45 +354,6 @@ n = 100; p = 5; S = 5
mydata = rcqo(n, p, S, ESOpt=TRUE, EqualMax=TRUE)
names(mydata)
myform = attr(mydata, "formula")
-fit = cqo(myform, fam=poissonff, ITol=TRUE, data=mydata,
- Bestof=3) # Fit a CQO model to the data
-\dontrun{
-matplot(attr(mydata, "lv"), mydata[,-(1:(p-1))], col=1:S)
-persp(fit, col=1:S, add=TRUE)
-lvplot(fit, lcol=1:S, y=TRUE, pcol=1:S) # The same plot as above
-}
-
-# Compare the fitted model with the 'truth'
-ccoef(fit) # The fitted model
-attr(mydata, "ccoefficients") # The 'truth'
-
-c(sd(attr(mydata, "lv")), sd(lv(fit))) # Both values should be approx equal
-
-
-# Example 2: negative binomial data fitted using a Poisson model:
-n = 200; p = 5; S = 5
-mydata = rcqo(n, p, S, fam="negbin", sqrt=TRUE)
-myform = attr(mydata, "formula")
-fit = cqo(myform, fam=poissonff, ITol=TRUE, dat=mydata)
-\dontrun{
-lvplot(fit, lcol=1:S, y=TRUE, pcol=1:S)
-}
-# Compare the fitted model with the 'truth'
-ccoef(fit) # The fitted model
-attr(mydata, "ccoefficients") # The 'truth'
-
-
-# Example 3: gamma2 data fitted using a Gaussian model:
-n = 200; p = 5; S = 3
-mydata = rcqo(n, p, S, fam="gamma2", Log=TRUE)
-fit = cqo(attr(mydata, "formula"), fam=gaussianff, ITol=TRUE, dat=mydata)
-\dontrun{
-matplot(attr(mydata, "lv"), exp(mydata[,-(1:(p-1))]), col=1:S) # 'raw' data
-lvplot(fit, lcol=1:S, y=TRUE, pcol=1:S) # Fitted model to transformed data
-}
-# Compare the fitted model with the 'truth'
-ccoef(fit) # The fitted model
-attr(mydata, "ccoefficients") # The 'truth'
}
\keyword{distribution}
diff --git a/man/recexp1.Rd b/man/recexp1.Rd
index 57df415..3a9239d 100644
--- a/man/recexp1.Rd
+++ b/man/recexp1.Rd
@@ -73,7 +73,7 @@ Coef(fit)
%# Keep only the records
%delete = c(FALSE, rep(TRUE, len=n-1))
%for(i in 2:length(rawy))
-% if(rawy[i] > max(rawy[1:(i-1)])) delete[i] = FALSE
+% if (rawy[i] > max(rawy[1:(i-1)])) delete[i] = FALSE
%(y = rawy[!delete])
diff --git a/man/reciprocal.Rd b/man/reciprocal.Rd
index 2163829..93c9aac 100644
--- a/man/reciprocal.Rd
+++ b/man/reciprocal.Rd
@@ -86,6 +86,7 @@ close to 0.
\seealso{
\code{\link{identity}},
\code{\link{powl}}.
+
}
\examples{
reciprocal(1:5)
diff --git a/man/recnormal1.Rd b/man/recnormal1.Rd
index b07557e..eaf01ba 100644
--- a/man/recnormal1.Rd
+++ b/man/recnormal1.Rd
@@ -93,6 +93,6 @@ summary(fit)
%# Keep only observations that are records
%delete = c(FALSE, rep(TRUE, len=n))
%for(i in 2:length(rawy))
-% if(rawy[i] > max(rawy[1:(i-1)])) delete[i] = FALSE
+% if (rawy[i] > max(rawy[1:(i-1)])) delete[i] = FALSE
%(y = rawy[!delete])
diff --git a/man/rhobit.Rd b/man/rhobit.Rd
index 133ac41..6c75e81 100644
--- a/man/rhobit.Rd
+++ b/man/rhobit.Rd
@@ -90,6 +90,7 @@ contains further information and examples.
\code{\link{Links}},
\code{\link{binom2.rho}},
\code{\link{fisherz}}.
+
}
\examples{
diff --git a/man/riceff.Rd b/man/riceff.Rd
index b861b26..b72811a 100644
--- a/man/riceff.Rd
+++ b/man/riceff.Rd
@@ -8,10 +8,8 @@
}
\usage{
-riceff(lvee="loge", lsigma="loge",
- evee=list(), esigma=list(),
- ivee=NULL, isigma=NULL,
- nsimEIM=100, zero=NULL)
+riceff(lvee="loge", lsigma="loge", evee=list(), esigma=list(),
+ ivee=NULL, isigma=NULL, nsimEIM=100, zero=NULL)
}
%- maybe also 'usage' for other objects documented here.
\arguments{
diff --git a/man/rig.Rd b/man/rig.Rd
index 2141148..bf008e7 100644
--- a/man/rig.Rd
+++ b/man/rig.Rd
@@ -42,6 +42,7 @@ rig(lmu = "identity", llambda = "loge",
Jorgensen, B. (1997)
\emph{The Theory of Dispersion Models}.
London: Chapman & Hall
+
}
\author{ T. W. Yee }
\note{
@@ -50,11 +51,12 @@ London: Chapman & Hall
}
\seealso{
\code{\link{simplex}}.
+
}
\examples{
-y = rchisq(n=100, df=14) # Not 'proper' data!!
-fit = vglm(y ~ 1, rig, trace=TRUE)
-fit = vglm(y ~ 1, rig, trace=TRUE, eps=1e-9, cri="c")
+rdata = data.frame(y = rchisq(n=100, df=14)) # Not 'proper' data!!
+fit = vglm(y ~ 1, rig, rdata, trace=TRUE)
+fit = vglm(y ~ 1, rig, rdata, trace=TRUE, eps=1e-9, cri="c")
summary(fit)
}
\keyword{models}
diff --git a/man/rlplot.egev.Rd b/man/rlplot.egev.Rd
index 2b8640f..44fc64a 100644
--- a/man/rlplot.egev.Rd
+++ b/man/rlplot.egev.Rd
@@ -135,7 +135,7 @@ range(i2 at post$rlplot$upper - i1 at post$rlplot$upper) # Should be near 0
range(i2 at post$rlplot$lower - i1 at post$rlplot$lower) # Should be near 0
}
}
-\keyword{hplot}
+\keyword{graphs}
\keyword{models}
\keyword{regression}
diff --git a/man/rrvglm.control.Rd b/man/rrvglm.control.Rd
index 279717e..45dc667 100644
--- a/man/rrvglm.control.Rd
+++ b/man/rrvglm.control.Rd
@@ -8,7 +8,7 @@
}
\usage{
rrvglm.control(Rank = 1, Algorithm = c("alternating", "derivative"),
- Corner = TRUE, Uncor = FALSE, Wmat = NULL, Svd.arg = FALSE,
+ Corner = TRUE, Uncorrelated.lv = FALSE, Wmat = NULL, Svd.arg = FALSE,
Index.corner = if (length(Structural.zero))
head((1:1000)[-Structural.zero], Rank) else 1:Rank,
Alpha = 0.5, Bestof = 1, Cinit = NULL,
@@ -41,7 +41,7 @@ rrvglm.control(Rank = 1, Algorithm = c("alternating", "derivative"),
i.e., they hold an order-\eqn{R} identity matrix.
}
-\item{Uncor}{
+\item{Uncorrelated.lv}{
Logical indicating whether uncorrelated latent variables are to be used.
This is normalization forces the variance-covariance
matrix of the latent variables to be \code{diag(Rank)}, i.e., unit
diff --git a/man/s.Rd b/man/s.Rd
index 6a418c0..1180f18 100644
--- a/man/s.Rd
+++ b/man/s.Rd
@@ -11,19 +11,15 @@ s(x, df = 4, spar = 0, ...)
}
%- maybe also `usage' for other objects documented here.
\arguments{
- In the following, \eqn{M} is the number of additive predictors
- and \eqn{r} is the number of component functions to be
- estimated (so that \eqn{r} is an element from the set
- \{1,2,\ldots,\eqn{M}\}).
- Also, if \eqn{n} is the number of \emph{distinct} abscissae, then
- \code{s} will fail if \eqn{n < 7}.
\item{x}{
covariate (abscissae) to be smoothed.
- Note that \code{x} must be a single variable
+ Note that \code{x} must be a \emph{single} variable
and not a function of a variable.
For example, \code{s(x)} is fine but \code{s(log(x))} will fail.
- In this case, let \code{logx <- log(x)}, say, and use \code{s(logx)}.
+ In this case, let \code{logx <- log(x)}, say, and then use \code{s(logx)}.
+ At this stage bivariate smoothers (\code{x} would be a two-column matrix)
+ are not implemented.
}
\item{df}{
@@ -47,17 +43,33 @@ s(x, df = 4, spar = 0, ...)
\item{\dots}{ Ignored for now. }
}
\details{
+ In this help file \eqn{M} is the number of additive predictors
+ and \eqn{r} is the number of component functions to be
+ estimated (so that \eqn{r} is an element from the set
+ \{1,2,\ldots,\eqn{M}\}).
+ Also, if \eqn{n} is the number of \emph{distinct} abscissae, then
+ \code{s} will fail if \eqn{n < 7}.
+
+
\code{s}, which is symbolic and does not perform any smoothing itself,
only handles a single covariate.
- It differs from the S-PLUS \code{s} and also the one from
- the \code{mgcv} library. They should not be mixed together.
+ Note that \code{s} works in \code{\link{vgam}} only.
+ It has no effect in \code{\link{vglm}}
+ (actually, it is similar to the identity function \code{\link[base:AsIs]{I}}
+ so that \code{s(x2)} is the same as \code{x2} in the LM model matrix).
+ It differs from the \code{s} of the \pkg{gam} and \pkg{mgcv} packages;
+ they should not be mixed together.
+ Also, terms involving \code{s} should be simple additive terms, and not
+ involving interactions and nesting etc.
+ For example, \code{myfactor:s(x2)} is not a good idea.
- S-PLUS's \code{s} allowed \code{spar} to be negative;
+ It also differs from the S-PLUS \code{s} which
+ allows \code{spar} to be negative;
\pkg{VGAM} does not allow this.
}
\value{
- A vector with attributes that are used by \code{vgam}.
+ A vector with attributes that are (only) used by \code{vgam}.
}
\references{
@@ -71,8 +83,16 @@ Vector generalized additive models.
\note{
The vector cubic smoothing spline which \code{s()} represents is
- computationally demanding for large \eqn{M}. The cost is approximately
- \eqn{O(M^3)}.
+ computationally demanding for large \eqn{M}.
+ The cost is approximately \eqn{O(M^3)}.
+
+ An alternative to using
+ \code{s} with \code{\link{vgam}} is
+ \code{\link[splines]{bs}}
+ and/or \code{\link[splines]{ns}}
+ with \code{\link{vglm}}.
+ The latter implements half-stepping, which is helpful if
+ convergence is difficult.
}
@@ -81,6 +101,7 @@ Vector generalized additive models.
\seealso{
\code{\link{vgam}},
\code{\link{vsmooth.spline}}.
+
}
\examples{
@@ -89,16 +110,15 @@ fit = vgam(agaaus ~ s(altitude, df=2), binomialff, hunua)
\dontrun{
plot(fit, se=TRUE)}
-
# Bivariate logistic model with artificial data
-n = 300
-mydf = data.frame(x1=runif(n), x2=runif(n))
+nn = 300
+mydf = data.frame(x1=runif(nn), x2=runif(nn))
mydf = transform(mydf,
- y1 = ifelse(runif(n) < 1/(1+exp(-sin(2*x2))), 1, 0),
- y2 = ifelse(runif(n) < 1/(1+exp(-sin(2*x2))), 1, 0))
+ y1 = rbinom(nn, size=1, prob=logit(sin(2*x2), inv=TRUE)),
+ y2 = rbinom(nn, size=1, prob=logit(sin(2*x2), inv=TRUE)))
fit = vgam(cbind(y1,y2) ~ x1 + s(x2, 3), trace=TRUE,
binom2.or(exchangeable = TRUE ~ s(x2,3)), data=mydf)
-coef(fit, matrix=TRUE)
+coef(fit, matrix=TRUE) # Hard to interpret
\dontrun{
plot(fit, se=TRUE, which.term= 2, scol="blue")}
}
diff --git a/man/simplex.Rd b/man/simplex.Rd
index 7b00347..b031c80 100644
--- a/man/simplex.Rd
+++ b/man/simplex.Rd
@@ -6,8 +6,7 @@
The two parameters of the univariate simplex distribution are estimated.
}
\usage{
-simplex(lmu = "logit", lsigma = "loge",
- emu=list(), esigma=list(),
+simplex(lmu = "logit", lsigma = "loge", emu=list(), esigma=list(),
imu = NULL, isigma = NULL)
}
%- maybe also 'usage' for other objects documented here.
diff --git a/man/sinmad.Rd b/man/sinmad.Rd
index 58a765b..c3f999a 100644
--- a/man/sinmad.Rd
+++ b/man/sinmad.Rd
@@ -97,9 +97,9 @@ default value is not \code{NULL}.
}
\examples{
-y = rsinmad(n=3000, 3, 5, 2)
-fit = vglm(y ~ 1, sinmad, trace=TRUE)
-fit = vglm(y ~ 1, sinmad, trace=TRUE, crit="c")
+sdata = data.frame(y = rsinmad(n=3000, 3, 5, 2))
+fit = vglm(y ~ 1, sinmad, sdata, trace=TRUE)
+fit = vglm(y ~ 1, sinmad, sdata, trace=TRUE, crit="c")
coef(fit, mat=TRUE)
Coef(fit)
summary(fit)
diff --git a/man/skellam.Rd b/man/skellam.Rd
index 566567e..9119904 100644
--- a/man/skellam.Rd
+++ b/man/skellam.Rd
@@ -81,7 +81,7 @@ two Poisson variates belonging to different populations.
\bold{109}, 296.
}
-\author{ T. W. Yee }
+%\author{ T. W. Yee }
\note{
Numerical problems may occur for data if \eqn{\mu_1}{mu1} and/or
\eqn{\mu_2}{mu2} are large.
@@ -95,17 +95,17 @@ two Poisson variates belonging to different populations.
}
\examples{
-x = runif(n <- 1000)
-mu1 = exp(1+x); mu2 = exp(1+x);
-y = rskellam(n, mu1, mu2)
-fit1 = vglm(y ~ x, skellam, trace=TRUE, crit="l")
-fit2 = vglm(y ~ x, skellam(parallel=TRUE), trace=TRUE, crit="c")
+sdata = data.frame(x = runif(nn <- 1000))
+sdata = transform(sdata, mu1 = exp(1+x), mu2 = exp(1+x))
+sdata = transform(sdata, y = rskellam(nn, mu1, mu2))
+fit1 = vglm(y ~ x, skellam, sdata, trace=TRUE)
+fit2 = vglm(y ~ x, skellam(parallel=TRUE), sdata, trace=TRUE, crit="c")
coef(fit1, matrix=TRUE)
coef(fit2, matrix=TRUE)
summary(fit1)
# Likelihood ratio test for equal means:
-1-pchisq(2*(logLik(fit1)-logLik(fit2)),
- df=fit2 at df.residual-fit1@df.residual)
+pchisq(2*(logLik(fit1)-logLik(fit2)),
+ df=fit2 at df.residual-fit1@df.residual, lower.tail=FALSE)
}
\keyword{models}
\keyword{regression}
diff --git a/man/skellamUC.Rd b/man/skellamUC.Rd
index fc3770d..cf33e74 100644
--- a/man/skellamUC.Rd
+++ b/man/skellamUC.Rd
@@ -33,7 +33,7 @@ rskellam(n, mu1, mu2)
\code{rskellam} generates random deviates.
}
-\author{ T. W. Yee }
+%\author{ T. W. Yee }
\details{
See \code{\link{skellam}}, the \pkg{VGAM} family function
for estimating the parameters,
diff --git a/man/skewnormal1.Rd b/man/skewnormal1.Rd
index 240f9f9..6069482 100644
--- a/man/skewnormal1.Rd
+++ b/man/skewnormal1.Rd
@@ -100,20 +100,19 @@ distribution.
}
\examples{
-y = rsnorm(n <- 1000, shape=5)
-fit = vglm(y ~ 1, skewnormal1, trace=TRUE)
+sdata = data.frame(y = rsnorm(nn <- 1000, shape=5))
+fit = vglm(y ~ 1, skewnormal1, sdata, trace=TRUE)
coef(fit, matrix=TRUE)
-head(fitted(fit))
-mean(y)
+head(fitted(fit), 1)
+with(sdata, mean(y))
\dontrun{
-hist(y, prob=TRUE)
-x = seq(min(y), max(y), len=200)
-lines(x, dsnorm(x, shape=Coef(fit)), col="blue")
-}
+with(sdata, hist(y, prob=TRUE))
+x = with(sdata, seq(min(y), max(y), len=200))
+with(sdata, lines(x, dsnorm(x, shape=Coef(fit)), col="blue")) }
-x = runif(n)
-y = rsnorm(n, shape=1 + 2*x)
-fit = vglm(y ~ x, skewnormal1, trace=TRUE, crit="coef")
+sdata = data.frame(x = runif(nn))
+sdata = transform(sdata, y = rsnorm(nn, shape=1 + 2*x))
+fit = vglm(y ~ x, skewnormal1, sdata, trace=TRUE, crit="coef")
summary(fit)
}
\keyword{models}
diff --git a/man/slash.Rd b/man/slash.Rd
index 939b046..829a50f 100644
--- a/man/slash.Rd
+++ b/man/slash.Rd
@@ -102,8 +102,8 @@ f(y) = 1/(2*sigma*sqrt(2*pi)) if y=mu
}
\examples{
-y = rslash(n=1000, mu=4, sigma=exp(2))
-fit = vglm(y ~ 1, slash, trace=TRUE)
+sdata = data.frame(y = rslash(n=1000, mu=4, sigma=exp(2)))
+fit = vglm(y ~ 1, slash, sdata, trace=TRUE)
coef(fit, matrix=TRUE)
Coef(fit)
summary(fit)
diff --git a/man/slashUC.Rd b/man/slashUC.Rd
index 019dc34..e8c971c 100644
--- a/man/slashUC.Rd
+++ b/man/slashUC.Rd
@@ -58,15 +58,14 @@ rslash(n, mu=0, sigma=1)
}
\examples{
\dontrun{
-x = seq(-5,5,length=201)
-plot(x, dslash(x), type="l", col="blue", ylab="f(x)", ylim=c(0,0.4),
- main="Standard Slash, Normal and Cauchy Densities", lwd=2)
-lines(x, dnorm(x), col="black", lty=2, lwd=2)
-lines(x, dcauchy(x), col="red", lty=3, lwd=2)
-legend(x=2, y=0.3, c("slash","normal","cauchy"), lty=1:3,
+curve(dslash, col="blue", ylab="f(x)", -5, 5, ylim=c(0,0.4),
+ main="Standard slash, normal and Cauchy densities", lwd=2)
+curve(dnorm, col="black", lty=2, lwd=2, add=TRUE)
+curve(dcauchy, col="red", lty=3, lwd=2, add=TRUE)
+legend(x=2, y=0.3, c("slash","normal","Cauchy"), lty=1:3,
col=c("blue","black","red"), lwd=2)
-plot(x, pslash(q=x), col="blue", type="l", ylim=0:1)
+curve(pslash, col="blue", -5, 5, ylim=0:1)
}
}
\keyword{distribution}
diff --git a/man/smartpred.Rd b/man/smartpred.Rd
index 83a6069..29dbf6f 100644
--- a/man/smartpred.Rd
+++ b/man/smartpred.Rd
@@ -107,7 +107,7 @@
\code{\link{wrapup.smart}}.
Commonly used data-dependent functions include
\code{\link[base]{scale}},
- \code{\link[base]{poly}},
+ \code{\link[stats]{poly}},
\code{\link[splines]{bs}},
\code{\link[splines]{ns}}.
In \R,
diff --git a/man/snormUC.Rd b/man/snormUC.Rd
index feaef38..6e515e6 100644
--- a/man/snormUC.Rd
+++ b/man/snormUC.Rd
@@ -79,7 +79,7 @@ x = seq(-4, 4, len=n)
plot(x, dsnorm(x, shape=shape), type="l", col="blue", las=1, ylab="")
abline(v=0, h=0, lty="dashed", col="darkgreen")
lines(x, dnorm(x), col="red")
-legend(-3.5, 0.6, leg=c(paste("Blue=dsnorm(x, ", shape,")", sep=""),
+legend(-3.5, 0.6, leg=c(paste("Blue = dsnorm(x, ", shape,")", sep=""),
"standard normal density"), lty=1, col=c("blue","red"))
}
}
diff --git a/man/sratio.Rd b/man/sratio.Rd
index 88aa742..477a28d 100644
--- a/man/sratio.Rd
+++ b/man/sratio.Rd
@@ -12,10 +12,6 @@ sratio(link = "logit", earg = list(),
}
%- maybe also 'usage' for other objects documented here.
\arguments{
- In the following, the response \eqn{Y} is assumed to be a factor
- with ordered values \eqn{1,2,\dots,M+1}, so that
- \eqn{M} is the number of linear/additive predictors
- \eqn{\eta_j}{eta_j}.
\item{link}{
Link function applied to the \eqn{M}
@@ -52,6 +48,12 @@ sratio(link = "logit", earg = list(),
}
}
\details{
+ In this help file the response \eqn{Y} is assumed to be a factor
+ with ordered values \eqn{1,2,\dots,M+1}, so that
+ \eqn{M} is the number of linear/additive predictors
+ \eqn{\eta_j}{eta_j}.
+
+
There are a number of definitions for the \emph{continuation ratio}
in the literature. To make life easier, in the \pkg{VGAM} package,
we use \emph{continuation} ratios (see \code{\link{cratio}})
@@ -78,6 +80,14 @@ New York: Springer-Verlag.
McCullagh, P. and Nelder, J. A. (1989)
\emph{Generalized Linear Models}, 2nd ed. London: Chapman & Hall.
+
+Yee, T. W. (2010)
+The \pkg{VGAM} package for categorical data analysis.
+\emph{Journal of Statistical Software},
+\bold{32}, 1--34.
+\url{http://www.jstatsoft.org/v32/i10/}.
+
+
Documentation accompanying the \pkg{VGAM} package at
\url{http://www.stat.auckland.ac.nz/~yee}
contains further information and examples.
diff --git a/man/studentt.Rd b/man/studentt.Rd
index 9a390fb..c84c904 100644
--- a/man/studentt.Rd
+++ b/man/studentt.Rd
@@ -6,7 +6,7 @@
Estimation of the degrees of freedom for a Student t distribution.
}
\usage{
-studentt(link.df = "loglog", earg=list(), idf=NULL, nsimEIM=100)
+studentt(link.df = "loglog", earg=list(), idf=NULL, nsimEIM=300)
}
%- maybe also 'usage' for other objects documented here.
\arguments{
@@ -91,11 +91,10 @@ The probable error of a mean.
}
\examples{
-n = 500
-y = rt(n, df=exp(exp(0.5)))
-fit = vglm(y ~ 1, studentt, trace=TRUE)
+sdata = data.frame(x = runif(nn <- 1000))
+sdata = transform(sdata, y = rt(nn, df=exp(exp(0.5 - x))))
+fit = vglm(y ~ x, studentt, sdata, trace=TRUE)
coef(fit, matrix=TRUE)
-Coef(fit)
}
\keyword{models}
\keyword{regression}
diff --git a/man/tikuv.Rd b/man/tikuv.Rd
index cd7ce18..1eb2716 100644
--- a/man/tikuv.Rd
+++ b/man/tikuv.Rd
@@ -7,8 +7,7 @@
}
\usage{
-tikuv(d, lmean="identity", lsigma="loge",
- emean=list(), esigma=list(),
+tikuv(d, lmean="identity", lsigma="loge", emean=list(), esigma=list(),
isigma=NULL, zero=2)
}
%- maybe also 'usage' for other objects documented here.
diff --git a/man/tobit.Rd b/man/tobit.Rd
index 5f1eb95..f8bdbdb 100644
--- a/man/tobit.Rd
+++ b/man/tobit.Rd
@@ -108,26 +108,24 @@ Estimation of relationships for limited dependent variables.
\code{\link{dcnormal1}}.
}
\examples{
-n = 1000
-x = seq(-1, 1, len=n)
-f = function(x) 1 + 4*x
-ystar = f(x) + rnorm(n)
-Lower = 1
-Upper = 4
-y = pmax(ystar, Lower)
-y = pmin(y, Upper)
-table(y==Lower | y==Upper) # How many censored values?
-fit = vglm(y ~ x, tobit(Lower=Lower, Upper=Upper), trace=TRUE)
+tdata = data.frame(x = seq(-1, 1, len=(nn <- 1000)))
+foo = function(x) 1 + 4*x
+tdata = transform(tdata, ystar = foo(x) + rnorm(nn))
+Lower = 1; Upper = 4
+tdata = transform(tdata, y = pmax(ystar, Lower))
+tdata = transform(tdata, y = pmin(y, Upper))
+with(tdata, table(y==Lower | y==Upper)) # How many censored values?
+
+fit = vglm(y ~ x, tobit(Lower=Lower, Upper=Upper), tdata, trace=TRUE)
table(fit at extra$censoredL)
table(fit at extra$censoredU)
coef(fit, matrix=TRUE)
summary(fit)
\dontrun{
-plot(x, y, main="Tobit model", las=1)
-legend(-0.9, 3, c("Truth", "Estimate"), col=c("Blue", "Red"), lwd=2)
-lines(x, f(x), col="blue", lwd=2) # The truth
-lines(x, fitted(fit), col="red", lwd=2, lty="dashed") # The estimate
-}
+with(tdata, plot(x, y, main="Tobit model", las=1))
+legend(-0.9, 3, c("Truth", "Estimate"), col=c("blue", "red"), lwd=2)
+with(tdata, lines(x, foo(x), col="blue", lwd=2))
+with(tdata, lines(x, fitted(fit), col="red", lwd=2, lty="dashed")) }
}
\keyword{models}
\keyword{regression}
diff --git a/man/trplot.qrrvglm.Rd b/man/trplot.qrrvglm.Rd
index 6ce103e..5ae6e6d 100644
--- a/man/trplot.qrrvglm.Rd
+++ b/man/trplot.qrrvglm.Rd
@@ -10,10 +10,8 @@ It is only applicable for rank-1 models with argument
\code{Norrr = ~ 1}.
}
\usage{
-trplot.qrrvglm(object, whichSpecies = NULL,
- add=FALSE, plot.it=TRUE,
- label.sites = FALSE,
- sitenames = rownames(object at y),
+trplot.qrrvglm(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, len = nos * (nos - 1)/2),
@@ -163,4 +161,4 @@ abline(a=0, b=1, lty="dashed") # Useful reference line
}
\keyword{models}
\keyword{regression}
-\keyword{hplot}
+\keyword{graphs}
diff --git a/man/undocumented-methods.Rd b/man/undocumented-methods.Rd
index 35141d3..e43504c 100644
--- a/man/undocumented-methods.Rd
+++ b/man/undocumented-methods.Rd
@@ -23,6 +23,7 @@
\alias{coefficients,uqo-method}
\alias{coefficients,vsmooth.spline-method}
\alias{coefficients,vsmooth.spline.fit-method}
+\alias{coefficients,summary.vglm-method}
\alias{Coefficients,vlm-method}
\alias{coef,cao-method}
\alias{coef,vlm-method}
@@ -31,6 +32,7 @@
\alias{coef,uqo-method}
\alias{coef,vsmooth.spline-method}
\alias{coef,vsmooth.spline.fit-method}
+\alias{coef,summary.vglm-method}
\alias{Coef,cao-method}
\alias{Coef,vlm-method}
\alias{Coef,qrrvglm-method}
diff --git a/man/uqo.Rd b/man/uqo.Rd
index 395267a..c27a10c 100644
--- a/man/uqo.Rd
+++ b/man/uqo.Rd
@@ -227,7 +227,7 @@ p1 = cqo(cbind(Alopacce, Alopcune, Alopfabr, Arctlute, Arctperi,
WaterCon + BareSand + FallTwig + CoveMoss + CoveHerb + ReflLux,
ITolerances = TRUE, fam = poissonff, data = hspider,
Crow1positive=TRUE, Bestof=3, trace=FALSE)
-if(deviance(p1) > 1589.0) stop("suboptimal fit obtained")
+if (deviance(p1) > 1589.0) stop("suboptimal fit obtained")
set.seed(111)
up1 = uqo(cbind(Alopacce, Alopcune, Alopfabr, Arctlute, Arctperi,
@@ -236,7 +236,7 @@ up1 = uqo(cbind(Alopacce, Alopcune, Alopfabr, Arctlute, Arctperi,
family = poissonff, data = hspider,
ITolerances = TRUE,
Crow1positive = TRUE, lvstart = -lv(p1))
-if(deviance(up1) > 1310.0) stop("suboptimal fit obtained")
+if (deviance(up1) > 1310.0) stop("suboptimal fit obtained")
nos = ncol(up1 at y) # Number of species
clr = (1:(nos+1))[-7] # to omit yellow
@@ -256,7 +256,7 @@ par(mfrow=c(2,1))
persp(up1, main="Red/Blue are the constrained/unconstrained models",
label=TRUE, col="blue", las=1)
persp(p1, add=FALSE, col="red")
-1-pchisq(deviance(p1) - deviance(up1), df=52-30)
+pchisq(deviance(p1) - deviance(up1), df=52-30, lower.tail=FALSE)
}
}
\keyword{models}
diff --git a/man/uqo.control.Rd b/man/uqo.control.Rd
index 7d93e41..2e6ac43 100644
--- a/man/uqo.control.Rd
+++ b/man/uqo.control.Rd
@@ -11,7 +11,7 @@
}
\usage{
-uqo.control(Rank=1, Bestof = if(length(lvstart) &&
+uqo.control(Rank=1, Bestof = if (length(lvstart) &&
!jitter.sitescores) 1 else 10, CA1 = FALSE, Crow1positive
= TRUE, epsilon = 1.0e-07, EqualTolerances = ITolerances,
Etamat.colmax = 10, GradientFunction=TRUE, Hstep = 0.001,
diff --git a/man/vgam.Rd b/man/vgam.Rd
index 1477b8d..a013d98 100644
--- a/man/vgam.Rd
+++ b/man/vgam.Rd
@@ -21,8 +21,6 @@ vgam(formula, family, data = list(), weights = NULL, subset = NULL,
\arguments{
% The following comes from vglm.Rd but with minor tweaks
- In the following, \eqn{M} is the number of additive predictors.
-
\item{formula}{
a symbolic description of the model to be fit.
The RHS of the formula is applied to each linear/additive predictor.
@@ -155,8 +153,7 @@ vgam(formula, family, data = list(), weights = NULL, subset = NULL,
}
\details{
A vector generalized additive model (VGAM) is loosely defined
- as a statistical model that is a function of \eqn{M} additive
- predictors.
+ as a statistical model that is a function of \eqn{M} additive predictors.
The central formula is given by
\deqn{\eta_j = \sum_{k=1}^p f_{(j)k}(x_k)}{%
eta_j = sum_{k=1}^p f_{(j)k}(x_k)}
@@ -283,8 +280,8 @@ coef(fit2, mat=TRUE) # Not really interpretable
\dontrun{
plot(fit2, se=TRUE, overlay=TRUE, lcol=1:2, scol=1:2)
-o = with(hunua, order(altitude))
-with(hunua, matplot(altitude[o], fitted(fit2)[o,], type="l", lwd=2,
+ooo = with(hunua, order(altitude))
+with(hunua, matplot(altitude[ooo], fitted(fit2)[ooo,], type="l", lwd=2,
xlab="Altitude (m)", ylab="Probability of presence", las=1,
main="Two plant species' response curves", ylim=c(0,.8)))
with(hunua, rug(altitude))
diff --git a/man/vgam.control.Rd b/man/vgam.control.Rd
index f83bb5b..5768c5e 100644
--- a/man/vgam.control.Rd
+++ b/man/vgam.control.Rd
@@ -18,8 +18,6 @@ vgam.control(all.knots = FALSE, bf.epsilon = 1e-07, bf.maxit = 30,
\arguments{
% zz na.action differs from vglm
-In the following, we let \eqn{d} be the number of \code{\link{s}} terms
-in the formula.
\item{all.knots}{
logical indicating if all distinct points of
@@ -32,16 +30,19 @@ in the formula.
This increases very slowly with \eqn{n}
so that the number of knots is approximately between 50 and 60
for large \eqn{n}.
+
}
\item{bf.epsilon}{
tolerance used by the modified vector
backfitting algorithm for testing convergence.
Must be a positive number.
+
}
\item{bf.maxit}{
maximum number of iterations allowed in
the modified vector
backfitting algorithm. Must be a positive integer.
+
}
\item{checkwz}{
logical indicating whether the diagonal elements of
@@ -55,6 +56,7 @@ in the formula.
be used to test for convergence.
The possibilities are listed in \code{.min.criterion.VGAM}, but
most family functions only implement a few of these.
+
}
\item{epsilon}{
positive convergence tolerance epsilon. Roughly
@@ -62,40 +64,46 @@ in the formula.
are assumed to have
converged when two successive \code{criterion} values are within
\code{epsilon} of each other.
+
}
\item{maxit}{
maximum number of
- Newton-Raphson/Fisher-scoring/local-scoring iterations allowed.
+ Newton-Raphson/Fisher-scoring/local-scoring iterations allowed.
+
}
\item{na.action}{
- how to handle missing values. Unlike the
- SPLUS \code{gam} function, \code{\link{vgam}} cannot handle
- \code{NA}s when smoothing.
+ how to handle missing values.
+ Unlike the SPLUS \code{gam} function, \code{\link{vgam}} cannot handle
+ \code{NA}s when smoothing.
+
}
\item{nk}{
vector of length \eqn{d} containing positive integers.
- Recycling is used if necessary.
- The \eqn{i}th value is the number of B-spline coefficients to be
- estimated for each component function of the \eqn{i}th
- \code{s()} term.
- \code{nk} differs from the number of knots by some constant.
- If specified, \code{nk} overrides the automatic knot selection
- procedure.
+ where \eqn{d} be the number of \code{\link{s}} terms
+ in the formula.
+ Recycling is used if necessary.
+ The \eqn{i}th value is the number of B-spline coefficients to be
+ estimated for each component function of the \eqn{i}th
+ \code{s()} term.
+ \code{nk} differs from the number of knots by some constant.
+ If specified, \code{nk} overrides the automatic knot selection procedure.
+
}
\item{save.weight}{
logical indicating whether the \code{weights} slot
- of a \code{"vglm"} object will be saved on the object. If not, it will
- be reconstructed when needed, e.g., \code{summary}.
+ of a \code{"vglm"} object will be saved on the object.
+ If not, it will be reconstructed when needed, e.g., \code{summary}.
+
}
\item{se.fit}{
logical indicating whether approximate
- pointwise standard errors are to be saved on the object.
- If \code{TRUE}, then these can be plotted with \code{plot(..., se=TRUE)}.
+ pointwise standard errors are to be saved on the object.
+ If \code{TRUE}, then these can be plotted with \code{plot(..., se=TRUE)}.
}
\item{trace}{
- logical indicating if output should be produced for
- each iteration.
+ logical indicating if output should be produced for each iteration.
+
}
\item{wzepsilon}{
Small positive number used to test whether the diagonals of the working
@@ -116,6 +124,7 @@ in the formula.
}
}
\details{
+
Most of the control parameters are used within \code{vgam.fit} and
you will have to look at that to understand the full details. Many of
the control parameters are used in a similar manner by \code{vglm.fit}
@@ -132,6 +141,7 @@ in the formula.
A list with components matching the input names. A little error
checking is done, but not much.
The list is assigned to the \code{control} slot of \code{\link{vgam}} objects.
+
}
\references{
Yee, T. W. and Wild, C. J. (1996)
@@ -140,6 +150,7 @@ Vector generalized additive models.
\bold{58}, 481--493.
\url{http://www.stat.auckland.ac.nz/~yee}
+
}
\author{ Thomas W. Yee}
@@ -147,6 +158,7 @@ Vector generalized additive models.
\code{\link{vgam}} does not implement half-stepsizing, therefore parametric
models should be fitted with \code{\link{vglm}}. Also, \code{\link{vgam}} is
slower than \code{\link{vglm}} too.
+
}
% ~Make other sections like Warning with \section{Warning }{....} ~
@@ -156,6 +168,7 @@ Vector generalized additive models.
\code{\link{vglm.control}},
\code{\link{vsmooth.spline}},
\code{\link{vglm}}.
+
}
\examples{
diff --git a/man/vglm.Rd b/man/vglm.Rd
index 9af2e3a..a4a2d16 100644
--- a/man/vglm.Rd
+++ b/man/vglm.Rd
@@ -18,7 +18,6 @@ vglm(formula, family, data = list(), weights = NULL, subset = NULL,
}
%- maybe also `usage' for other objects documented here.
\arguments{
- In the following, \eqn{M} is the number of linear predictors.
\item{formula}{
a symbolic description of the model to be fit.
@@ -334,7 +333,7 @@ The \code{VGAM} Package.
}
\examples{
-# Example 1. Dobson (1990) Page 93: Randomized Controlled Trial :
+# Example 1. See help(glm)
counts = c(18,17,15,20,10,20,25,13,12)
outcome = gl(3,1,9)
treatment = gl(3,3)
@@ -349,8 +348,7 @@ vglm(cbind(normal, mild, severe) ~ let, multinomial, pneumo)
# Example 3. Proportional odds model
-fit3 = vglm(cbind(normal,mild,severe) ~ let, trace=TRUE,
- cumulative(parallel=TRUE, reverse=TRUE), pneumo)
+fit3 = vglm(cbind(normal,mild,severe) ~ let, propodds, pneumo, trace=TRUE)
coef(fit3, matrix=TRUE)
constraints(fit3)
model.matrix(fit3, type="lm") # LM model matrix
@@ -375,6 +373,7 @@ eyesdat = transform(eyesdat, eta1 = -1+2*lop,
eyesdat = transform(eyesdat,
leye = rbinom(nn, size=1, prob=logit(eta1, inv=TRUE)),
reye = rbinom(nn, size=1, prob=logit(eta2, inv=TRUE)))
+head(eyesdat)
fit5 = vglm(cbind(leye,reye) ~ op,
binom2.or(exchangeable=TRUE, zero=3),
data=eyesdat, trace=TRUE,
@@ -382,8 +381,7 @@ fit5 = vglm(cbind(leye,reye) ~ op,
form2 = ~ op + lop + rop + fill(lop))
coef(fit5)
coef(fit5, matrix=TRUE)
-
-
+constraints(fit5)
}
\keyword{models}
\keyword{regression}
diff --git a/man/vglm.control.Rd b/man/vglm.control.Rd
index 21fb827..bebbb7a 100644
--- a/man/vglm.control.Rd
+++ b/man/vglm.control.Rd
@@ -75,6 +75,14 @@ vglm.control(checkwz=TRUE, criterion = names(.min.criterion.VGAM),
}
\item{trace}{
logical indicating if output should be produced for each iteration.
+ Setting \code{trace=TRUE} is recommended in general because
+ \pkg{VGAM} fits a very broad variety of models and distributions, and
+ for some of them, convergence is intrinsically more difficult.
+ Monitoring convergence can help check that the solution is reasonable
+ or that a problem has occurred.
+ It may suggest better initial values are needed,
+ the making of invalid assumptions, or that
+ the model is inappropriate for the data, etc.
}
\item{wzepsilon}{
@@ -148,6 +156,10 @@ Reduced-rank vector generalized linear models.
}
\author{ Thomas W. Yee}
\note{
+ Reiterating from above,
+ setting \code{trace=TRUE} is recommended in general.
+
+
In Example 2 below there are two covariates that have linear/additive
predictor specific values.
These are handled using the \code{xij} argument.
diff --git a/man/vonmises.Rd b/man/vonmises.Rd
index c7060cc..98eda8e 100644
--- a/man/vonmises.Rd
+++ b/man/vonmises.Rd
@@ -122,13 +122,13 @@ New York: Wiley-Interscience, Third edition.
}
\examples{
-x = runif(n <- 1000)
-y = rnorm(n, m=2+x, sd=exp(0.2)) # Not von Mises data!!
-fit = vglm(y ~ x, vonmises(zero=2), trace=TRUE)
+vdata = data.frame(x = runif(nn <- 1000))
+vdata = transform(vdata, y = rnorm(nn, m=2+x, sd=exp(0.2))) # Not good data!!
+fit = vglm(y ~ x, vonmises(zero=2), vdata, trace=TRUE)
coef(fit, matrix=TRUE)
Coef(fit)
-range(y) # original data
-range(fit at y) # processed data is in [0,2*pi)
+with(vdata, range(y)) # original data
+range(fit at y) # processed data is in [0,2*pi)
}
\keyword{models}
\keyword{regression}
diff --git a/man/vsmooth.spline.Rd b/man/vsmooth.spline.Rd
index 500a428..92c0735 100644
--- a/man/vsmooth.spline.Rd
+++ b/man/vsmooth.spline.Rd
@@ -6,36 +6,41 @@
Fits a vector cubic smoothing spline.
}
\usage{
-vsmooth.spline(x, y, w, df = rep(5, M), spar = NULL,
- all.knots = FALSE,
+vsmooth.spline(x, y, w, df = rep(5, M), spar = NULL, all.knots = FALSE,
iconstraint = diag(M), xconstraint = diag(M),
constraints = list("(Intercepts)" = diag(M), x = diag(M)),
tol.nl = 0.01, var.arg = FALSE, scale.w = TRUE, nk = NULL)
}
%- maybe also 'usage' for other objects documented here.
\arguments{
- \item{x}{ A vector, matrix or a list.
-If a list, the \code{x} component is used.
-If a matrix, the first column is used.
-\code{x} may also be a complex vector, in which case
-the real part is used, and the imaginary part is used for the response.
-In this help file, \code{n} is the number of unique values of \code{x}.
-}
- \item{y}{ A vector, matrix or a list.
-If a list, the \code{y} component is used.
-If a matrix, all but the first column is used.
-In this help file, \code{M} is the number of columns of \code{y} if
-there are no constraints on the functions.
+ \item{x}{
+ A vector, matrix or a list.
+ If a list, the \code{x} component is used.
+ If a matrix, the first column is used.
+ \code{x} may also be a complex vector, in which case
+ the real part is used, and the imaginary part is used for the response.
+ In this help file, \code{n} is the number of unique values of \code{x}.
+
+}
+ \item{y}{
+ A vector, matrix or a list.
+ If a list, the \code{y} component is used.
+ If a matrix, all but the first column is used.
+ In this help file, \code{M} is the number of columns of \code{y} if
+ there are no constraints on the functions.
+
}
\item{w}{
-The weight matrices or the number of observations.
-If the weight matrices, then this must be a \code{n}-row matrix
-with the elements in matrix-band form (see \code{iam}).
-If a vector, then these are the number of observations.
-By default, \code{w} is the \code{M} by \code{M} identity
-matrix, denoted by \code{matrix(1, n, M)}.
-}
- \item{df}{ Numerical vector containing the degrees of
+ The weight matrices or the number of observations.
+ If the weight matrices, then this must be a \code{n}-row matrix
+ with the elements in matrix-band form (see \code{iam}).
+ If a vector, then these are the number of observations.
+ By default, \code{w} is the \code{M} by \code{M} identity
+ matrix, denoted by \code{matrix(1, n, M)}.
+
+}
+ \item{df}{
+Numerical vector containing the degrees of
freedom for each component function (smooth).
If necessary, the vector is recycled to have length equal
to the number of component functions to be estimated
@@ -45,6 +50,7 @@ A value of 2 means a linear fit, and each element of
\code{df} should lie between 2 and \code{n}.
The larger the values of \code{df} the more wiggly the
smooths.
+
}
\item{spar}{
Numerical vector containing the non-negative smoothing
@@ -60,46 +66,55 @@ be linear.
By default, the \code{NULL} value of \code{spar} means
\code{df} is used to determine the smoothing
parameters.
+
}
\item{all.knots}{ Logical. If \code{TRUE} then each distinct
value of \code{x} will be a knot. By default, only a subset of
the unique values of \code{x} are used; typically, the number
of knots is \code{O(n^0.25)} for \code{n} large,
but if \code{n <= 40} then all the unique values of \code{x} are used.
+
}
\item{iconstraint}{ A \code{M}-row constraint matrix for the
intercepts. It must be of full column rank.
By default, the constraint matrix for the intercepts is the
\code{M} by \code{M} identity matrix, meaning no constraints.
+
}
\item{xconstraint}{ A \code{M}-row constraint matrix for \code{x}.
It must be of full column rank.
By default, the constraint matrix for the intercepts is the
\code{M} by \code{M} identity matrix, meaning no constraints.
+
}
\item{constraints}{
An alternative to specifying \code{iconstraint} and \code{xconstraint},
this is a list with two components corresponding to the
intercept and \code{x} respectively. They must both be a
\code{M}-row constraint matrix with full column rank.
+
}
\item{tol.nl}{ Tolerance for testing nonlinearity for the
component functions. If \code{df} is within \code{tol.nl} of
2 then the function is treated as linear.
+
}
\item{var.arg}{ Logical: return the pointwise variances
of the fit?
Currently, this corresponds only to the nonlinear part of the
fit, and may be wrong.
+
}
\item{scale.w}{
Logical.
By default, the weights \code{w} are scaled so that the
diagonal elements have mean 1.
+
}
\item{nk}{ Number of knots.
If used, this argument overrides \code{all.knots}, and
must lie between 6 and \code{n}+2 inclusive.
+
}
}
\details{
diff --git a/man/wald.Rd b/man/wald.Rd
index 2a25e07..fc9f93a 100644
--- a/man/wald.Rd
+++ b/man/wald.Rd
@@ -54,11 +54,13 @@ Johnson, N. L. and Kotz, S. and Balakrishnan, N. (1994)
2nd edition,
Volume 1,
New York: Wiley.
+
}
\author{ T. W. Yee }
\note{
The \pkg{VGAM} family function \code{\link{inv.gaussianff}}
estimates the location parameter \eqn{\mu}{mu} too.
+
}
@@ -67,10 +69,8 @@ New York: Wiley.
}
\examples{
-set.seed(123)
-shape = 1
-y = rgamma(n=1000, shape=shape) # Not inverse Gaussian!!
-fit = vglm(y ~ 1, wald(init=0.2), trace=TRUE)
+wdata = data.frame(y = rgamma(n=1000, shape=1)) # Not inverse Gaussian!!
+fit = vglm(y ~ 1, wald(init=0.2), wdata, trace=TRUE)
coef(fit, matrix=TRUE)
Coef(fit)
summary(fit)
diff --git a/man/weibull.Rd b/man/weibull.Rd
index 0310caa..d45fa44 100644
--- a/man/weibull.Rd
+++ b/man/weibull.Rd
@@ -10,7 +10,7 @@
\usage{
weibull(lshape = "loge", lscale = "loge",
eshape = list(), escale = list(),
- ishape = NULL, iscale = NULL,
+ ishape = NULL, iscale = NULL,
nrfs = 1, imethod=1, zero = 2)
}
%- maybe also 'usage' for other objects documented here.
@@ -122,7 +122,7 @@ Weibull and GE distributions,
This function is under development to handle other censoring situations.
The version of this function which will handle censored data will be
called \code{cenweibull()}. It is currently being written and will use
- \code{\link{Surv}} as input.
+ \code{\link{SurvS4}} as input.
It should be released in later versions of \pkg{VGAM}.
If the shape parameter is less than two then misleading inference may
diff --git a/man/wffc.P2star.Rd b/man/wffc.P2star.Rd
index ad8110b..13aecf3 100644
--- a/man/wffc.P2star.Rd
+++ b/man/wffc.P2star.Rd
@@ -41,9 +41,10 @@ wffc.P2star(length, min.eligible = 0.18)
% \url{http://www.2008worldflyfishingchamps.com}
% is the official website.
- Yee, T. W. (2009)
- VGLMs and VGAMs: an overview for applications in fisheries research.
- In preparation.
+ Yee, T. W. (2010)
+ On strategies and issues raised by an analysis of
+ the 2008 World Fly Fishing Championships data.
+ \emph{In preparation}.
}
diff --git a/man/wffc.Rd b/man/wffc.Rd
index 1fa8b69..54e9894 100644
--- a/man/wffc.Rd
+++ b/man/wffc.Rd
@@ -24,8 +24,8 @@
\item{\code{sector}}{a numeric vector; a value from the set 1,2,\ldots,5.}
\item{\code{beatboat}}{a numeric vector; beat or boat number,
a value from the set 1,2,\ldots,19.}
- \item{\code{comid}}{a numeric vector; the competitor's ID number. Uniquely
- identifies each competitor.
+ \item{\code{comid}}{a numeric vector; the competitor's ID number.
+ Uniquely identifies each competitor.
These ID numbers actually correspond to their rankings
in the individual level. }
\item{\code{iname}}{a character vector; the individual competitor's name. }
@@ -53,9 +53,10 @@ USA (USA),
Wales (WAL).
}
}
+
}
\details{
- Details may be obtained at Yee (2009b).
+ Details may be obtained at Yee (2010) and Yee (2010b).
Here is a brief summary.
The three competition days were 28--30 March.
Each session was fixed at 9.00am--12.00pm and 2.30--5.30pm daily.
@@ -73,6 +74,7 @@ Wales (WAL).
except for one boat which only had one.
Each competitor was randomly assigned to a beat/boat.
+
Competitors were ranked according to their placings at each sector-session
combination, and then these placings were summed. Those with the minimum
total placings were the winners, thus it was not necessarily those who had
@@ -81,6 +83,7 @@ each of the 19 competitors was ranked 1 (best) to 19 (worst) according
to the point system. This is the ``placing'' for that session. These
placings were added up over the 5 sessions to give the ``total placings''.
+
All sectors have naturally wild Rainbow trout (\emph{Oncorhynchus mykiss})
while Lake Otamangakau and the Whanganui River also holds Brown trout
(\emph{Salmo trutta}). Only these two species were targetted.
@@ -93,19 +96,23 @@ The gender of the fish were also not recorded electronically, and
anyway, distinguishing between male and female was very difficult
for small fish.
+
Although species and gender data were supposed to have been
collected at the time of capture the quality of these variables
is rather poor and furthermore they were not recorded electronically.
+
% 11 out of (11 + 210) were brown trout, in Otamangakau.
% 52 were NAs.
%
% 3 out of ( 3 + 179) were brown trout, in Rotoaira.
% 19 were NAs.
+
Note that some fish may have been caught more than once, hence
these data do not represent individual fish but rather recorded captures.
+
Note also that a few internal discrepancies may be found within and between
the data frames
\code{\link{wffc}},
@@ -119,6 +126,7 @@ is rather poor and furthermore they were not recorded electronically.
The data has already been cleaned of errors and internal inconsistencies
but a few may remain.
+
}
\seealso{
@@ -144,14 +152,17 @@ is rather poor and furthermore they were not recorded electronically.
% \url{http://www.2008worldflyfishingchamps.com}
% is the official website.
- Yee, T. W. (2009a)
+ Yee, T. W. (2010)
VGLMs and VGAMs: an overview for applications in fisheries research.
- In preparation.
+ \emph{Fisheries Research},
+ \bold{101}, 116--126.
+
- Yee, T. W. (2009b)
- Some issues raised by the analysis of
+ Yee, T. W. (2010b)
+ On strategies and issues raised by an analysis of
the 2008 World Fly Fishing Championships data.
- In preparation.
+ \emph{In preparation}.
+
}
\examples{
diff --git a/man/wffc.indiv.Rd b/man/wffc.indiv.Rd
index 8517296..61a4ade 100644
--- a/man/wffc.indiv.Rd
+++ b/man/wffc.indiv.Rd
@@ -36,9 +36,10 @@
% \url{http://www.2008worldflyfishingchamps.com/}.
%}
\references{
- Yee, T. W. (2009)
+ Yee, T. W. (2010)
VGLMs and VGAMs: an overview for applications in fisheries research.
- In preparation.
+ \emph{Fisheries Research},
+ \bold{101}, 116--126.
}
\examples{
diff --git a/man/wffc.nc.Rd b/man/wffc.nc.Rd
index 318c36f..f26d73f 100644
--- a/man/wffc.nc.Rd
+++ b/man/wffc.nc.Rd
@@ -36,13 +36,17 @@
% \url{http://www.2008worldflyfishingchamps.com/}.
%}
\references{
- Yee, T. W. (2009)
+ Yee, T. W. (2010)
VGLMs and VGAMs: an overview for applications in fisheries research.
- In preparation.
+ \emph{Fisheries Research},
+ \bold{101}, 116--126.
}
-\seealso{ \code{\link{DeLury}}. }
+\seealso{
+\code{\link{DeLury}}.
+
+}
\examples{
xtabs( ~ sector + session, wffc.nc)
diff --git a/man/wffc.teams.Rd b/man/wffc.teams.Rd
index 596aefa..18b89f8 100644
--- a/man/wffc.teams.Rd
+++ b/man/wffc.teams.Rd
@@ -30,12 +30,9 @@
%\source{
% \url{http://www.2008worldflyfishingchamps.com/}.
%}
-\references{
- Yee, T. W. (2009)
- VGLMs and VGAMs: an overview for applications in fisheries research.
- In preparation.
-
-}
+%\references{
+%
+%}
\examples{
wffc.teams
}
diff --git a/man/yeo.johnson.Rd b/man/yeo.johnson.Rd
index a0ef366..9b449f9 100644
--- a/man/yeo.johnson.Rd
+++ b/man/yeo.johnson.Rd
@@ -21,7 +21,9 @@ yeo.johnson(y, lambda, derivative = 0,
\item{epsilon}{ Numeric and positive value. The tolerance given
to values of \code{lambda} when comparing it to 0 or 2. }
\item{inverse}{ Logical.
- Return the inverse transformation? }
+ Return the inverse transformation?
+ }
+
}
\details{
The Yeo-Johnson transformation can be thought of as an extension
@@ -30,10 +32,12 @@ yeo.johnson(y, lambda, derivative = 0,
positive values. Both can be used to transform the data so
as to improve normality. They can be used to perform LMS
quantile regression.
+
}
\value{
The Yeo-Johnson transformation or its inverse, or its
derivatives with respect to \code{lambda}, of \code{y}.
+
}
\references{
Yeo, I.-K. and Johnson, R. A. (2000)
@@ -44,26 +48,27 @@ A new family of power transformations to improve normality or symmetry.
Yee, T. W. (2004)
Quantile regression via vector generalized additive models.
\emph{Statistics in Medicine}, \bold{23}, 2295--2315.
+
}
\author{ Thomas W. Yee }
\note{
If \code{inverse=TRUE} then the argument \code{derivative=0} is required.
+
}
\seealso{
\code{\link{lms.yjn}},
\code{\link[MASS]{boxcox}}.
+
}
\examples{
-n = 200
-y = seq(-4, 4, len=n)
+y = seq(-4, 4, len= (nn <- 200))
ltry = c(0, 0.5, 1, 1.5, 2) # Try these values of lambda
lltry = length(ltry)
-psi = matrix(NA, n, lltry)
-for(i in 1:lltry) {
- psi[,i] = yeo.johnson(y, lambda=ltry[i])
-}
+psi = matrix(NA, nn, lltry)
+for(ii in 1:lltry)
+ psi[,ii] = yeo.johnson(y, lambda=ltry[ii])
\dontrun{
matplot(y, psi, type="l", ylim=c(-4, 4), lwd=2, lty=1:lltry,
@@ -71,8 +76,7 @@ matplot(y, psi, type="l", ylim=c(-4, 4), lwd=2, lty=1:lltry,
main="Yeo-Johnson transformation with some values of lambda")
abline(v=0, h=0)
legend(x=c(1), y=c(-0.5), lty=1:lltry, legend=as.character(ltry),
- lwd=2, col=1:lltry)
-}
+ lwd=2, col=1:lltry) }
}
\keyword{models}
\keyword{regression}
diff --git a/man/yulesimon.Rd b/man/yulesimon.Rd
index 39b7827..fed28ee 100644
--- a/man/yulesimon.Rd
+++ b/man/yulesimon.Rd
@@ -67,10 +67,10 @@ yulesimon(link="loge", earg=list(), irho=NULL, nsimEIM=200)
}
\examples{
-x = runif(n <- 1000)
-y = ryules(n, rho=exp(1.5-x))
-table(y)
-fit = vglm(y ~ x, yulesimon, trace=TRUE)
+ydata = data.frame(x = runif(nn <- 1000))
+ydata = transform(ydata, y = ryules(nn, rho=exp(1.5-x)))
+with(ydata, table(y))
+fit = vglm(y ~ x, yulesimon, ydata, trace=TRUE)
coef(fit, matrix=TRUE)
summary(fit)
}
diff --git a/man/zanegbinUC.Rd b/man/zanegbinUC.Rd
index 21d8dd1..5db561c 100644
--- a/man/zanegbinUC.Rd
+++ b/man/zanegbinUC.Rd
@@ -63,8 +63,7 @@ rzanegbin(n, p0, size, prob=NULL, munb=NULL)
}
\examples{
-munb = 3; size = 4; p0 = 0.3
-x = (-1):7
+munb = 3; size = 4; p0 = 0.3; x = (-1):7
(ii = dzanegbin(x, p0=p0, munb=munb, size=size))
table(rzanegbin(100, p0=p0, munb=munb, size=size))
@@ -72,10 +71,10 @@ table(rzanegbin(100, p0=p0, munb=munb, size=size))
x = 0:10
barplot(rbind(dzanegbin(x, p0=p0, munb=munb, size=size),
dnbinom(x, mu=munb, size=size)),
- beside = TRUE, col = c("blue","green"),
- main=paste("ZANB(p0=", p0, ", munb=", munb, ", size=", size, ") (blue) vs",
- " NB(mu=", munb, ", size=", size, ") (green)", sep=""),
- names.arg = as.character(x), cex.main=0.7, las=1)
-}
+ beside = TRUE, col = c("blue","green"), cex.main=0.7, las=1,
+ ylab = "Probability",names.arg = as.character(x),
+ main=paste("ZANB(p0=", p0, ", munb=", munb, ", size=", size,
+ ") [blue] vs", " NB(mu=", munb, ", size=", size,
+ ") [green] densities", sep="")) }
}
\keyword{distribution}
diff --git a/man/zanegbinomial.Rd b/man/zanegbinomial.Rd
index 8fc0883..870e7f1 100644
--- a/man/zanegbinomial.Rd
+++ b/man/zanegbinomial.Rd
@@ -153,16 +153,16 @@ for counts with extra zeros.
}
\examples{
-x = runif(n <- 2000)
-p0 = logit(-1 + 2*x, inverse=TRUE)
-y1 = rposnegbin(n, munb=exp(0+2*x), size=exp(1)) # With covariates
-y2 = rposnegbin(n, munb=exp(1+2*x), size=exp(1)) # With covariates
-y1 = ifelse(runif(n) < p0, 0, y1)
-y2 = ifelse(runif(n) < p0, 0, y2)
-table(y1)
-table(y2)
-
-fit = vglm(cbind(y1,y2) ~ x, zanegbinomial, trace=TRUE)
+zdata = data.frame(x = runif(nn <- 2000))
+zdata = transform(zdata, p0 = logit(-1 + 2*x, inverse=TRUE),
+ y1 = rposnegbin(nn, munb=exp(0+2*x), size=exp(1)),
+ y2 = rposnegbin(nn, munb=exp(1+2*x), size=exp(1)))
+zdata = transform(zdata, y1 = ifelse(runif(nn) < p0, 0, y1),
+ y2 = ifelse(runif(nn) < p0, 0, y2))
+with(zdata, table(y1))
+with(zdata, table(y2))
+
+fit = vglm(cbind(y1,y2) ~ x, zanegbinomial, zdata, trace=TRUE)
coef(fit, matrix=TRUE)
head(fitted(fit))
head(predict(fit))
diff --git a/man/zapoisUC.Rd b/man/zapoisUC.Rd
index 8125b3e..c14124c 100644
--- a/man/zapoisUC.Rd
+++ b/man/zapoisUC.Rd
@@ -56,13 +56,10 @@ rzapois(n, lambda, p0 = 0)
}
\examples{
-lambda = 3
-p0 = 0.2
-x = (-1):7
-(i = dzapois(x, lambda, p0))
-max(abs(cumsum(i) - pzapois(x, lambda, p0))) # Should be 0
+lambda = 3; p0 = 0.2; x = (-1):7
+(ii = dzapois(x, lambda, p0))
+max(abs(cumsum(ii) - pzapois(x, lambda, p0))) # Should be 0
table(rzapois(100, lambda, p0))
-
table(qzapois(runif(100), lambda, p0))
round(dzapois(0:10, lambda, p0) * 100) # Should be similar
@@ -70,9 +67,8 @@ round(dzapois(0:10, lambda, p0) * 100) # Should be similar
x = 0:10
barplot(rbind(dzapois(x, lambda, p0), dpois(x, lambda)),
beside = TRUE, col = c("blue","green"),
- main=paste("ZAP(", lambda, ", p0=", p0, ") (blue) vs",
- " Poisson(", lambda, ") (green)", sep=""),
- names.arg = as.character(x))
-}
+ main=paste("ZAP(", lambda, ", p0=", p0, ") [blue] vs",
+ " Poisson(", lambda, ") [green] densities", sep=""),
+ names.arg = as.character(x), ylab="Probability") }
}
\keyword{distribution}
diff --git a/man/zapoisson.Rd b/man/zapoisson.Rd
index 8131b81..cff6601 100644
--- a/man/zapoisson.Rd
+++ b/man/zapoisson.Rd
@@ -131,13 +131,14 @@ that these are reasonable.
}
\examples{
-x = runif(n <- 1000)
-p0 = logit(-1 + 1*x, inverse=TRUE)
-lambda = loge(-0.3 + 2*x, inverse=TRUE)
-y = ifelse(runif(n) < p0, 0, rpospois(n, lambda))
-table(y)
-fit = vglm(y ~ x, zapoisson, trace=TRUE)
-fit = vglm(y ~ x, zapoisson, trace=TRUE, crit="c")
+zapdata = data.frame(x = runif(nn <- 1000))
+zapdata = transform(zapdata, p0 = logit(-1 + 1*x, inverse=TRUE),
+ lambda = loge(-0.5 + 2*x, inverse=TRUE))
+zapdata = transform(zapdata, y = rzapois(nn, lambda, p0=p0))
+
+with(zapdata, table(y))
+fit = vglm(y ~ x, zapoisson, zapdata, trace=TRUE)
+fit = vglm(y ~ x, zapoisson, zapdata, trace=TRUE, crit="c")
head(fitted(fit))
head(predict(fit))
head(predict(fit, untransform=TRUE))
@@ -146,14 +147,13 @@ coef(fit, matrix=TRUE)
# Another example ------------------------------
# Data from Angers and Biswas (2003)
-y = 0:7; w = c(182, 41, 12, 2, 2, 0, 0, 1)
-y = y[w>0]
-w = w[w>0]
-yy = rep(y,w)
+abdata = data.frame(y = 0:7, w = c(182, 41, 12, 2, 2, 0, 0, 1))
+abdata = subset(abdata, w>0)
+yy = with(abdata, rep(y, w))
fit3 = vglm(yy ~ 1, zapoisson, trace=TRUE, crit="c")
coef(fit3, matrix=TRUE)
Coef(fit3) # Estimate of lambda (they get 0.6997 with standard error 0.1520)
-head(fitted(fit3))
+head(fitted(fit3), 1)
mean(yy) # compare this with fitted(fit3)
}
\keyword{models}
diff --git a/man/zero.Rd b/man/zero.Rd
index ac24d13..eba4061 100644
--- a/man/zero.Rd
+++ b/man/zero.Rd
@@ -87,10 +87,8 @@ args(multinomial)
args(binom2.or)
args(gpd)
-
#LMS quantile regression example
-fit = vglm(BMI ~ bs(age, df=4), fam=lms.bcg(zero=c(1,3)),
- data=bminz, trace=TRUE)
+fit = vglm(BMI ~ bs(age, df=4), lms.bcg(zero=c(1,3)), bminz, trace=TRUE)
coef(fit, matrix=TRUE)
}
\keyword{models}
diff --git a/man/zeta.Rd b/man/zeta.Rd
index ee73695..1108e5b 100644
--- a/man/zeta.Rd
+++ b/man/zeta.Rd
@@ -8,13 +8,14 @@
}
\usage{
zeta(x, deriv = 0)
+
}
%- maybe also 'usage' for other objects documented here.
\arguments{
\item{x}{
- A complex-valued vector/matrix whose real values must be \eqn{\geq
- 1}{>= 1}. Otherwise, if \code{x} may be real. If \code{deriv} is 1
- or 2 then \code{x} must be real and positive.
+ A complex-valued vector/matrix whose real values must be
+ \eqn{\geq 1}{>= 1}. Otherwise, if \code{x} may be real.
+ If \code{deriv} is 1 or 2 then \code{x} must be real and positive.
}
\item{deriv}{
@@ -58,21 +59,25 @@ Riemann, B. (1859)
Ueber die Anzahl der Primzahlen unter einer gegebenen Grosse.
\emph{Monatsberichte der Berliner Akademie, November 1859}.
+
Edwards, H. M. (1974)
\emph{Riemann's Zeta Function}.
Academic Press: New York.
+
Markman, B. (1965)
The Riemann zeta function.
\emph{BIT},
\bold{5},
138--141.
+
Abramowitz, M. and Stegun, I. A. (1972)
\emph{Handbook of Mathematical Functions with Formulas, Graphs, and
Mathematical Tables},
New York: Dover Publications Inc.
+
}
\author{ T. W. Yee, with the help of G. J. Tee. }
\note{
@@ -85,25 +90,24 @@ New York: Dover Publications Inc.
\code{\link{zetaff}},
\code{\link{lerch}},
\code{\link[base:Special]{gamma}}.
+
}
\examples{
zeta(2:10)
\dontrun{
-x = seq(1.2, 10, len=100)
-plot(x, zeta(x), type="l", las=1, xlim=c(-12,10), ylim=c(-1,4), col="red")
-x = seq(-12, 0.8, len=100)
-lines(x, zeta(x), col="red")
+curve(zeta, -13, 0.8, xlim=c(-12,10), ylim=c(-1,4), col="red")
+curve(zeta, 1.2, 12, add = TRUE, col="red")
abline(v=0, h=c(0,1), lty="dashed")
# Close up plot
-x = seq(-14, -0.4, len=100)
-plot(x, zeta(x), type="l", las=1, col="red")
+curve(zeta, -14, -0.4, col="red")
abline(v=0, h=0, lty="dashed")
-# Plot of the first derivatives
+# Plot of the first derivative
x = seq(0.04, 0.8, len=100)
-plot(x, zeta(x, deriv=1), type="l", las=1, col="blue", xlim=c(0.04,3), ylim=c(-6,0))
+plot(x, zeta(x, deriv=1), type="l", las=1, col="blue",
+ xlim=c(0.04,3), ylim=c(-6,0), main="zeta'(x)")
x = seq(1.2, 3, len=100)
lines(x, zeta(x, deriv=1), col="blue")
abline(v=0, h=0, lty="dashed") }
@@ -116,3 +120,9 @@ zeta(8) - pi^8 / 9450 # Should be 0
}
\keyword{math}
+% curve(zeta, -13, 0.8, xlim=c(-12,10), ylim=c(-1,4), col="red")
+% curve(zeta, 1.2, 12, add = TRUE, col="red")
+% abline(v=0, h=c(0,1), lty="dashed")
+
+
+
diff --git a/man/zetaUC.Rd b/man/zetaUC.Rd
index 949f7b9..a252ac5 100644
--- a/man/zetaUC.Rd
+++ b/man/zetaUC.Rd
@@ -31,6 +31,7 @@ dzeta(x, p, log=FALSE)
}
\value{
Returns the density evaluated at \code{x}.
+
}
\references{
@@ -57,11 +58,13 @@ New York: Wiley.
\section{Warning}{
This function has not been fully tested.
+
}
\seealso{
\code{\link{zeta}},
\code{\link{zetaff}}.
+
}
\examples{
@@ -69,8 +72,7 @@ dzeta(1:20, p=2)
\dontrun{
plot(1:6, dzeta(1:6, p=4), type="h", las=1, ylab="Probability",
main="zeta probability function; black: p = 4; blue: p = 2")
-points(0.10+1:6, dzeta(1:6, p=2), type="h", col="blue")
-}
+points(0.10+1:6, dzeta(1:6, p=2), type="h", col="blue") }
}
\keyword{distribution}
diff --git a/man/zetaff.Rd b/man/zetaff.Rd
index 19b6606..5f2abe3 100644
--- a/man/zetaff.Rd
+++ b/man/zetaff.Rd
@@ -48,13 +48,14 @@ provided \eqn{p>2}.
It appears that good initial values are needed for successful
convergence. If convergence is not obtained, try several values
ranging from values near 0 to values about 10 or more.
+
}
\value{
An object of class \code{"vglmff"} (see \code{\link{vglmff-class}}).
The object is used by modelling functions such as \code{\link{vglm}},
- \code{\link{rrvglm}}
and \code{\link{vgam}}.
+
}
%Lindsey, J. K. (1995)
@@ -75,34 +76,31 @@ Boca Raton: Chapman & Hall/CRC Press.
}
\author{ T. W. Yee }
-\note{ The \code{\link{zeta}} function may be used to
-compute values of the zeta function.
+\note{
+ The \code{\link{zeta}} function may be used to compute values of the
+ zeta function.
+
}
\seealso{
-\code{\link{zeta}},
-\code{\link{dzeta}},
-\code{\link{hzeta}},
-\code{\link{zipf}}.
-
-Documentation accompanying the \pkg{VGAM} package at
-\url{http://www.stat.auckland.ac.nz/~yee}
-contains further information and examples.
+ \code{\link{zeta}},
+ \code{\link{dzeta}},
+ \code{\link{hzeta}},
+ \code{\link{zipf}}.
}
\examples{
-y = 1:5 # Knight, p.304
-w = c(63, 14, 5, 1, 2)
-fit = vglm(y ~ 1, zetaff, trace=TRUE, wei=w, crit="c")
+zdata = data.frame(y = 1:5, w = c(63, 14, 5, 1, 2)) # Knight, p.304
+fit = vglm(y ~ 1, zetaff, zdata, trace=TRUE, wei=w, crit="c")
(phat = Coef(fit)) # 1.682557
-cbind(dzeta(y, phat) * sum(w), w)
+with(zdata, cbind(dzeta(y, phat) * sum(w), w))
-weighted.mean(y, w)
+with(zdata, weighted.mean(y, w))
fitted(fit, mat=FALSE)
predict(fit)
-# MLE should satisfy the following:
-mean(log(rep(y, w))) + zeta(1+phat, deriv=1)/zeta(1+phat) # Should be 0
+# The following should be zero at the MLE:
+with(zdata, mean(log(rep(y, w))) + zeta(1+phat, deriv=1)/zeta(1+phat))
}
\keyword{models}
\keyword{regression}
diff --git a/man/zibinomUC.Rd b/man/zibinomUC.Rd
index 07d5cb7..aeaa512 100644
--- a/man/zibinomUC.Rd
+++ b/man/zibinomUC.Rd
@@ -62,8 +62,8 @@ rzibinom(n, size, prob, phi = 0)
}
\examples{
prob = 0.2; size = 10; phi = 0.5
-(i = dzibinom(0:size, size, prob, phi=phi))
-max(abs(cumsum(i) - pzibinom(0:size, size, prob, phi=phi))) # Should be 0
+(ii = dzibinom(0:size, size, prob, phi=phi))
+max(abs(cumsum(ii) - pzibinom(0:size, size, prob, phi=phi))) # Should be 0
table(rzibinom(100, size, prob, phi=phi))
table(qzibinom(runif(100), size, prob, phi=phi))
@@ -76,7 +76,6 @@ barplot(rbind(dzibinom(x, size, prob, phi=phi),
beside = TRUE, col = c("blue","green"),
main=paste("ZIB(", size, ", ", prob, ", phi=", phi, ") (blue) vs",
" Binomial(", size, ", ", prob, ") (green)", sep=""),
- names.arg = as.character(x), las=1, lwd=2)
-}
+ names.arg = as.character(x), las=1, lwd=2) }
}
\keyword{distribution}
diff --git a/man/zibinomial.Rd b/man/zibinomial.Rd
index 55c33a9..4811180 100644
--- a/man/zibinomial.Rd
+++ b/man/zibinomial.Rd
@@ -8,8 +8,7 @@
}
\usage{
-zibinomial(lphi="logit", lmu="logit",
- ephi=list(), emu=list(),
+zibinomial(lphi="logit", lmu="logit", ephi=list(), emu=list(),
iphi=NULL, zero=1, mv=FALSE)
}
%- maybe also 'usage' for other objects documented here.
@@ -27,8 +26,9 @@ zibinomial(lphi="logit", lmu="logit",
}
\item{iphi}{
- Optional initial value for \eqn{\phi}{phi}, whose value must lie
- between 0 and 1. The default is to compute an initial value internally.
+ Optional initial values for \eqn{\phi}{phi}, whose values must lie
+ between 0 and 1. The default is to compute an initial value internally.
+ If a vector then recyling is used.
}
\item{zero}{
diff --git a/man/zinegbinUC.Rd b/man/zinegbinUC.Rd
index 8bd8465..5e4776a 100644
--- a/man/zinegbinUC.Rd
+++ b/man/zinegbinUC.Rd
@@ -72,8 +72,8 @@ rzinegbin(n, phi, size, prob=NULL, munb=NULL)
\examples{
munb = 3; phi = 0.2; size = k = 10
x = 0:10
-(i = dzinegbin(x, phi=phi, mu=munb, size=k))
-max(abs(cumsum(i) - pzinegbin(x, phi=phi, mu=munb, size=k))) # Should be 0
+(ii = dzinegbin(x, phi=phi, mu=munb, size=k))
+max(abs(cumsum(ii) - pzinegbin(x, phi=phi, mu=munb, size=k))) # Should be 0
table(rzinegbin(100, phi=phi, mu=munb, size=k))
table(qzinegbin(runif(1000), phi=phi, mu=munb, size=k))
@@ -86,7 +86,6 @@ barplot(rbind(dzinegbin(x, phi=phi, mu=munb, size=k),
main=paste("ZINB(mu=", munb, ", k=", k, ", phi=", phi,
") (blue) vs negative binomial(mu=", munb,
", size=", k, ") (green)", sep=""),
- names.arg = as.character(x))
-}
+ names.arg = as.character(x)) }
}
\keyword{distribution}
diff --git a/man/zinegbinomial.Rd b/man/zinegbinomial.Rd
index 1af6e33..011b18a 100644
--- a/man/zinegbinomial.Rd
+++ b/man/zinegbinomial.Rd
@@ -8,10 +8,9 @@
}
\usage{
-zinegbinomial(lphi="logit", lmunb = "loge", lk = "loge",
- ephi=list(), emunb =list(), ek = list(),
- iphi = NULL, ik = NULL, zero = -3, method.init=1,
- shrinkage.init=0.95, nsimEIM=200)
+zinegbinomial(lphi="logit", lmunb = "loge", lk = "loge", ephi=list(),
+ emunb =list(), ek = list(), iphi = NULL, ik = NULL,
+ zero = -3, method.init=1, shrinkage.init=0.95, nsimEIM=200)
}
%- maybe also 'usage' for other objects documented here.
\arguments{
@@ -30,6 +29,7 @@ zinegbinomial(lphi="logit", lmunb = "loge", lk = "loge",
\item{iphi, ik}{
Optional initial values for \eqn{\phi}{phi} and \eqn{k}{k}.
The default is to compute an initial value internally for both.
+ If a vector then recycling is used.
}
\item{method.init}{
@@ -125,23 +125,22 @@ zinegbinomial(lphi="logit", lmunb = "loge", lk = "loge",
\seealso{
\code{\link{Zinegbin}},
\code{\link{negbinomial}},
- \code{\link[stats:negative binomial]{rpois}}.
+ \code{\link[stats:Poisson]{rpois}}.
}
\examples{
-x = runif(n <- 1000)
-phi = logit(-0.5+1*x, inverse=TRUE)
-munb = exp(3+x)
-k = exp(0+2*x)
-y1 = rzinegbin(n, phi, mu=munb, size=k)
-y2 = rzinegbin(n, phi, mu=munb, size=k)
-table(y1)["0"] / sum(table(y1))
-table(y2)["0"] / sum(table(y2))
-fit = vglm(cbind(y1,y2) ~ x, zinegbinomial(zero=NULL), trace=TRUE)
+nbdat = data.frame(x = runif(nn <- 1000))
+nbdat = transform(nbdat, phi = logit(-0.5+1*x, inverse=TRUE),
+ munb = exp(3+x),
+ k = exp(0+2*x))
+nbdat = transform(nbdat, y1 = rzinegbin(nn, phi, mu=munb, size=k),
+ y2 = rzinegbin(nn, phi, mu=munb, size=k))
+with(nbdat, table(y1)["0"] / sum(table(y1)))
+fit = vglm(cbind(y1,y2) ~ x, zinegbinomial(zero=NULL), nbdat, trace=TRUE)
coef(fit, matrix=TRUE)
summary(fit)
-head(cbind(fitted(fit), (1-phi) * munb))
-vcov(fit)
+head(cbind(fitted(fit), with(nbdat, (1-phi) * munb)))
+round(vcov(fit), 3)
}
\keyword{models}
\keyword{regression}
diff --git a/man/zipebcom.Rd b/man/zipebcom.Rd
index de6dc57..d895c1e 100644
--- a/man/zipebcom.Rd
+++ b/man/zipebcom.Rd
@@ -164,7 +164,7 @@ zipebcom(lmu12="cloglog", lphi12="logit", loratio="loge",
Journal of Theoretical Biology, \bold{259}. In press.
}
-\author{ Thomas W. Yee }
+%\author{ Thomas W. Yee }
\note{
The \code{"12"} in the argument names reinforce the user about the
exchangeability assumption.
@@ -202,22 +202,20 @@ with(mydat, table(ybin1,ybin2)) / nsites # For interest only
\dontrun{
# Various plots of the data, for interest only
par(mfrow=c(2,2))
-with(mydat, plot(jitter(ybin1) ~ x, col="blue"))
+plot(jitter(ybin1) ~ x, data = mydat, col="blue")
-with(mydat, plot(jitter(ybin2) ~ jitter(ybin1), col="blue"))
+plot(jitter(ybin2) ~ jitter(ybin1), data = mydat, col="blue")
-with(mydat, plot(x, mu12, col="blue", type="l", ylim=0:1,
- ylab="Probability", main="Marginal probability and phi"))
+plot(mu12 ~ x, data = mydat, col="blue", type="l", ylim=0:1,
+ ylab="Probability", main="Marginal probability and phi")
with(mydat, abline(h=phi1[1], col="red", lty="dashed"))
tmat2 = with(mydat, dbinom2.or(mu1=mu12, oratio=oratio, exch=TRUE))
with(mydat, matplot(x, tmat2, col=1:4, type="l", ylim=0:1,
- ylab="Probability", main="Joint probabilities"))
-}
+ ylab="Probability", main="Joint probabilities")) }
# Now fit the model to the data.
fit = vglm(cbind(ybin1,ybin2) ~ x, fam=zipebcom, dat=mydat, trace=TRUE)
-
coef(fit, matrix=TRUE)
summary(fit)
vcov(fit)
diff --git a/man/zipf.Rd b/man/zipf.Rd
index 038e0f6..e061bed 100644
--- a/man/zipf.Rd
+++ b/man/zipf.Rd
@@ -60,6 +60,7 @@ zipf(N=NULL, link="loge", earg=list(), init.s=NULL)
An object of class \code{"vglmff"} (see \code{\link{vglmff-class}}).
The object is used by modelling functions such as \code{\link{vglm}}
and \code{\link{vgam}}.
+
}
\references{
@@ -82,12 +83,12 @@ pp.526-- of Chapter 11 of
}
\examples{
-y = 1:5; w = c(63, 14, 5, 1, 2)
-fit = vglm(y ~ 1, zipf, trace=TRUE, weight=w)
-fit = vglm(y ~ 1, zipf(link=identity, init=3.4), tra=TRUE, weight=w, cri="c")
+zdat = data.frame(y = 1:5, w = c(63, 14, 5, 1, 2))
+fit = vglm(y ~ 1, zipf, zdat, trace=TRUE, weight=w, cri="c")
+fit = vglm(y ~ 1, zipf(link=identity, init=3.4), zdat, tra=TRUE, weight=w)
fit at misc$N
(shat = Coef(fit))
-weighted.mean(y, w)
+with(zdat, weighted.mean(y, w))
fitted(fit, mat=FALSE)
}
\keyword{models}
diff --git a/man/zipfUC.Rd b/man/zipfUC.Rd
index 66a1def..849058c 100644
--- a/man/zipfUC.Rd
+++ b/man/zipfUC.Rd
@@ -52,15 +52,14 @@ pzipf(q, N, s)
}
\examples{
-\dontrun{
N = 10; s=0.5; y = 1:N
proby = dzipf(y, N=N, s=s)
-plot(y, proby, type="h", col="blue", ylab="P[Y=y]", ylim=c(0,0.2),
- main=paste("Zipf(N=",N,", s=",s,")", sep=""))
+\dontrun{
+plot(proby ~ y, type="h", col="blue", ylab="P[Y=y]", ylim=c(0,0.2),
+ main=paste("Zipf(N=",N,", s=",s,")", sep=""), lwd=2, las = 1) }
sum(proby) # Should be 1
max(abs(cumsum(proby) - pzipf(y, N=N, s=s))) # Should be 0
}
-}
\keyword{distribution}
diff --git a/man/zipoisUC.Rd b/man/zipoisUC.Rd
index a77a677..fb675d4 100644
--- a/man/zipoisUC.Rd
+++ b/man/zipoisUC.Rd
@@ -60,11 +60,9 @@ rzipois(n, lambda, phi = 0)
}
\examples{
-lambda = 3
-phi = 0.2
-x <- (-1):7
-(i = dzipois(x, lambda, phi))
-max(abs(cumsum(i) - pzipois(x, lambda, phi))) # Should be 0
+lambda = 3; phi = 0.2; x = (-1):7
+(ii = dzipois(x, lambda, phi))
+max(abs(cumsum(ii) - pzipois(x, lambda, phi))) # Should be 0
table(rzipois(100, lambda, phi))
table(qzipois(runif(100), lambda, phi))
@@ -76,7 +74,6 @@ barplot(rbind(dzipois(x, lambda, phi), dpois(x, lambda)),
beside = TRUE, col = c("blue","green"),
main=paste("ZIP(", lambda, ", phi=", phi, ") (blue) vs",
" Poisson(", lambda, ") (green)", sep=""),
- names.arg = as.character(x))
-}
+ names.arg = as.character(x)) }
}
\keyword{distribution}
diff --git a/man/zipoisson.Rd b/man/zipoisson.Rd
index 043f214..62cbe3f 100644
--- a/man/zipoisson.Rd
+++ b/man/zipoisson.Rd
@@ -8,8 +8,7 @@
}
\usage{
-zipoisson(lphi="logit", llambda = "loge",
- ephi=list(), elambda =list(),
+zipoisson(lphi="logit", llambda = "loge", ephi=list(), elambda =list(),
iphi = NULL, method.init=1, shrinkage.init=0.8, zero = NULL)
}
%- maybe also 'usage' for other objects documented here.
@@ -31,8 +30,9 @@ zipoisson(lphi="logit", llambda = "loge",
}
\item{iphi}{
- Optional initial value for \eqn{\phi}{phi}, whose value must lie
- between 0 and 1. The default is to compute an initial value internally.
+ Optional initial values for \eqn{\phi}{phi}, whose values must lie
+ between 0 and 1. The default is to compute an initial value internally.
+ If a vector then recycling is used.
}
\item{method.init}{
@@ -139,39 +139,33 @@ zipoisson(lphi="logit", llambda = "loge",
}
\examples{
-x = runif(n <- 2000)
-phi = logit(-0.5 + 1*x, inverse=TRUE)
-lambda = loge(0.5 + 2*x, inverse=TRUE)
-y = rzipois(n, lambda, phi)
-table(y)
-fit = vglm(y ~ x, zipoisson, trace=TRUE)
+zipdat = data.frame(x = runif(nn <- 2000))
+zipdat = transform(zipdat, phi = logit(-0.5 + 1*x, inverse=TRUE),
+ lambda = loge(0.5 + 2*x, inverse=TRUE))
+zipdat = transform(zipdat, y = rzipois(nn, lambda, phi))
+with(zipdat, table(y))
+fit = vglm(y ~ x, zipoisson, zipdat, trace=TRUE)
coef(fit, matrix=TRUE) # These should agree with the above values
-# Another example: data from McKendrick (1926).
-y = 0:4 # Number of cholera cases per household in an Indian village
-w = c(168, 32, 16, 6, 1) # Frequencies; there are 223=sum(w) households
-fit = vglm(y ~ 1, zipoisson, wei=w, trace=TRUE)
+# Another example: McKendrick (1926). Data from 223 Indian village households
+cholera = data.frame(ncases = 0:4, # Number of cholera cases,
+ wfreq = c(168, 32, 16, 6, 1)) # Frequencies
+fit = vglm(ncases ~ 1, zipoisson, wei=wfreq, data=cholera, trace=TRUE)
coef(fit, matrix=TRUE)
-cbind(actual=w, fitted= round(
- dzipois(y, lambda=Coef(fit)[2], phi=Coef(fit)[1]) * sum(w), dig=2))
+with(cholera, cbind(actual=wfreq, fitted= round(
+ dzipois(ncases, lambda=Coef(fit)[2], phi=Coef(fit)[1]) * sum(wfreq), dig=2)))
# Another example: data from Angers and Biswas (2003)
-y = 0:7
-w = c(182, 41, 12, 2, 2, 0, 0, 1)
-y = y[w>0]
-w = w[w>0]
-\dontrun{
-# The zero is deflated, not inflated, giving convergence problems
-w[1] = 1
-}
-fit = vglm(y ~ 1, zipoisson(lphi=probit, iphi=0.3), wei=w, tra=TRUE)
+abdat = data.frame(y = 0:7, w = c(182, 41, 12, 2, 2, 0, 0, 1))
+abdat = subset(abdat, w>0)
+fit = vglm(y ~ 1, zipoisson(lphi=probit, iphi=0.3), abdat, wei=w, trace=TRUE)
fit at misc$prob0 # Estimate of P(Y=0)
coef(fit, matrix=TRUE)
Coef(fit) # Estimate of phi and lambda
fitted(fit)
-weighted.mean(y,w) # Compare this with fitted(fit)
+with(abdat, weighted.mean(y, w)) # Compare this with fitted(fit)
summary(fit)
}
\keyword{models}
diff --git a/src/cqof.f b/src/cqof.f
index ae2a0ad..0af9699 100644
--- a/src/cqof.f
+++ b/src/cqof.f
@@ -1032,6 +1032,7 @@
double precision dh3rio, ig5cmad, ig5v8gzsp, dldshape
double precision l0zqm, q1znur
integer lqhm2g
+ vi231l = 1
uxzze7 = 1
ogq67o = 0.990d0
ogq67o = 0.995d0
@@ -1282,7 +1283,12 @@
integer uxzze7, foej1u
double precision hq710, fiumb4, t7sbea, xmr7cj, elq2cs, qik6ym,
&zl11l0, wlkaa3, jftq1
+ double precision epx9jf1, epx9jf2
+ integer scvgce
uxzze7 = 1
+ scvgce = 0
+ oju3yh(1,1) = 1
+ zxao0o(1) = 0.0d0
cqui1v = p1i8xz(1)
w5tcfp = p1i8xz(2)
zxiwf1 = p1i8xz(3)
@@ -1311,7 +1317,8 @@
call p0lk40(hft28, ur73jo, nfiumb4, lku8xq, vi231l, cqui1v,
&zvxw1l, aqk377, w5tcfp, cr8hav, i5uvkm, zqve1l, vvl1li, h3mrfq,
&q121lc)
-653 if(.not.(ugsma5 .eq. 0))goto 23496
+653 epx9jf2 = 1.0d0
+ if(.not.(ugsma5 .eq. 0))goto 23496
do 23498 d9rjek=1,aqk377
call nbq4ua(jmwo0z, go0l1q, l1zvxx, nfiumb4, lku8xq, aqk377,
&zvxw1l, d9rjek, w8xfic, foej1u)
@@ -1406,16 +1413,23 @@
call kqx20o(zvxw1l, jmwo0z, w8xfic, w5poyv, nfiumb4, lku8xq,
&aqk377, xhe4cg, go0l1q, nx1bat,oht3ga,fiumb4,wlkaa3, oht3ga)
23544 continue
- return
+ scvgce = 1
+ goto 20097
+ goto 23543
23542 continue
hq710 = nx1bat
+ scvgce = 0
23543 continue
23504 continue
- if(.not.(ugsma5 .eq. 1 .or. ugsma5 .eq. 2))goto 23546
+20097 epx9jf1 = 0.0d0
+ if(.not.(scvgce .eq. 1))goto 23546
+ return
+23546 continue
+ if(.not.(ugsma5 .eq. 1 .or. ugsma5 .eq. 2))goto 23548
ugsma5 = 0
p1i8xz(9) = 1
goto 653
-23546 continue
+23548 continue
gqxvz8 = 3
return
end
@@ -1443,6 +1457,11 @@
double precision ni1qfp, epx9jf
ni1qfp = 0.0d0
uxzze7 = 1
+ zxao0o(1) = 1.0d0
+ call intpr(
+ &"entering cqo1f uxzze7 -------------------------------: ",-1,
+ &uxzze7,1)
+ call intpr("in cqo1f aqk377: ",-1,aqk377,1)
cqui1v = p1i8xz(1)
w5tcfp = p1i8xz(2)
zxiwf1 = p1i8xz(3)
@@ -1452,19 +1471,20 @@
pga6nul = p1i8xz(7)
p1i8xz(9) = 0
dyt0pg = p1i8xz(12)
- if(.not.(dyt0pg .ne. 1))goto 23548
+ if(.not.(dyt0pg .ne. 1))goto 23550
gqxvz8 = 4
return
-23548 continue
+23550 continue
h3mrfq = p1i8xz(14)
uvnk0i = p1i8xz(15)
p1 = p1i8xz(16)
foej1u = p1i8xz(18)
+ call intpr("Entry to cqo1f: ugsma5 ",-1,ugsma5,1)
fiumb4 = l1zvxx(1)
zl11l0 = dsqrt(fiumb4)
- if(.not.((zvxw1l .eq. 1) .or. (zvxw1l .eq. 4)))goto 23550
+ if(.not.((zvxw1l .eq. 1) .or. (zvxw1l .eq. 4)))goto 23552
wlkaa3 = dlog(fiumb4)
-23550 continue
+23552 continue
qik6ym = l1zvxx(2)
jftq1 = l1zvxx(3)
elq2cs = 0.0d0
@@ -1474,140 +1494,175 @@
i5uvkm = cqui1v * (cqui1v+1) / 2
call u16zxj(hft28, ur73jo, nfiumb4, cqui1v, zvxw1l, q121lc,
&vi231l, zxiwf1, i5uvkm, zqve1l, vvl1li, oju3yh, p1, h3mrfq)
- do 23552 lir0o1=1,aqk377
+ call dblepr("cqo1f: q121lc()",-1,q121lc,nfiumb4)
+ call dblepr("cqo1f: ur73jo(,)",-1,ur73jo,vi231l*zxiwf1)
+ call dblepr("cqo1f: w8xfic(,1)",-1,w8xfic(1,1),nfiumb4)
+ do 23554 lir0o1=1,aqk377
+ call intpr("cqo1f: lir0o1======================: ",-1,lir0o1,1)
653 epx9jf = 1.0d0
- if(.not.(ugsma5 .eq. 0))goto 23554
+ if(.not.(ugsma5 .eq. 0))goto 23556
+ call intpr("cqo1f: calling nbq4ua ",-1,lir0o1,1)
call nbq4ua(jmwo0z, go0l1q, l1zvxx, nfiumb4, lku8xq, aqk377,
&zvxw1l, lir0o1, w8xfic, foej1u)
- goto 23555
-23554 continue
- if(.not.(ugsma5 .eq. 2))goto 23556
+ goto 23557
+23556 continue
+ if(.not.(ugsma5 .eq. 2))goto 23558
+ call intpr("cqo1f: calling pjw1l; dyt0pg== ",-1,dyt0pg,1)
call pjw1l(ur73jo, lq8reh(1+(lir0o1-1)*zxiwf1), go0l1q, nfiumb4,
&lku8xq, vi231l, zxiwf1, dyt0pg, lir0o1, zvxw1l, h3mrfq, q121lc)
-23556 continue
-23555 continue
+23558 continue
+23557 continue
call o47zxq(go0l1q, w5poyv, nfiumb4, lku8xq, aqk377, zvxw1l,
&lir0o1)
- if(.not.(ugsma5 .eq. 2))goto 23558
+ if(.not.(ugsma5 .eq. 2))goto 23560
call kqx20o(zvxw1l, jmwo0z, w8xfic, w5poyv, nfiumb4, lku8xq,
&aqk377, xhe4cg, go0l1q, hq710, lir0o1, fiumb4, wlkaa3, uxzze7)
- goto 23559
-23558 continue
+ goto 23561
+23560 continue
hq710 = -1.0d0
-23559 continue
- do 23560 ucgi1r=1,pga6nul
+23561 continue
+ do 23562 ucgi1r=1,pga6nul
+ call intpr("ucgi1r: ",-1,ucgi1r,1)
+ call intpr("posn 7: ",-1,uxzze7,1)
+ call intpr("zvxw1l: ",-1,zvxw1l,1)
+ call dblepr("hq710",-1,hq710,1)
call kqsxz1(jmwo0z, w8xfic, go0l1q, w5poyv, hr83e, lj4dph, jrxg6l,
& jftq1, fiumb4, zl11l0, nfiumb4, lku8xq, aqk377, vi231l, zkjqhi,
&lir0o1, zvxw1l, gqxvz8, h3mrfq, q121lc)
- do 23562 nd6mep=1,zxiwf1
- do 23564 w3gohz=1,vi231l
+ call dblepr("cqo1f: go0l1q",-1,go0l1q,lku8xq*nfiumb4)
+ call dblepr("cqo1f: jrxg6l",-1,jrxg6l,zkjqhi*nfiumb4)
+ call dblepr("cqo1f: hr83e",-1,hr83e,nfiumb4*lku8xq)
+ call dblepr("cqo1f: lj4dph",-1,lj4dph,nfiumb4*lku8xq)
+ do 23564 nd6mep=1,zxiwf1
+ do 23566 w3gohz=1,vi231l
ioqzvb(w3gohz,nd6mep) = ur73jo(w3gohz,nd6mep)
+23566 continue
23564 continue
-23562 continue
- if(.not.((zvxw1l .eq. 3) .or. (zvxw1l .eq. 5)))goto 23566
- do 23568 nd6mep=1,zxiwf1
- do 23570 w3gohz=1,nfiumb4
+ call intpr("posn 3: ",-1,uxzze7,1)
+ if(.not.((zvxw1l .eq. 3) .or. (zvxw1l .eq. 5)))goto 23568
+ do 23570 nd6mep=1,zxiwf1
+ do 23572 w3gohz=1,nfiumb4
ioqzvb(2*w3gohz-1,nd6mep) = jrxg6l(2*lir0o1-1,w3gohz) * ioqzvb(2*
&w3gohz-1,nd6mep)
ioqzvb(2*w3gohz ,nd6mep) = jrxg6l(2*lir0o1 ,w3gohz) * ioqzvb(2*
&w3gohz ,nd6mep)
+23572 continue
23570 continue
+ goto 23569
23568 continue
- goto 23567
-23566 continue
- do 23572 nd6mep=1,zxiwf1
- do 23574 w3gohz=1,nfiumb4
+ do 23574 nd6mep=1,zxiwf1
+ do 23576 w3gohz=1,nfiumb4
ioqzvb(w3gohz,nd6mep) = jrxg6l(lir0o1,w3gohz) * ioqzvb(w3gohz,
&nd6mep)
+23576 continue
23574 continue
-23572 continue
-23567 continue
- do 23576 nd6mep=1,zxiwf1
+23569 continue
+ call intpr("posn 4: ",-1,uxzze7,1)
+ do 23578 nd6mep=1,zxiwf1
i83h1(nd6mep) = nd6mep
-23576 continue
+23578 continue
+ call dblepr("cqo1f: ioqzvb",-1,ioqzvb,vi231l*zxiwf1)
+ call intpr("ucgi1r: ",-1,ucgi1r,1)
t7sbea = 1.0d-7
call dhkt9w(ioqzvb,vi231l,vi231l,zxiwf1,i0qvzl,i83h1,t5vlzq,
&zx1610,t7sbea)
- if(.not.(zx1610 .ne. zxiwf1))goto 23578
+ call intpr("i83h1: ",-1,i83h1,zxiwf1)
+ if(.not.(zx1610 .ne. zxiwf1))goto 23580
gqxvz8 = 2
return
-23578 continue
- if(.not.((zvxw1l .eq. 3) .or. (zvxw1l .eq. 5)))goto 23580
- do 23582 w3gohz=1,nfiumb4
- t5vlzq(2*w3gohz-1,1)=jrxg6l(2*lir0o1-1,w3gohz)*hr83e(w3gohz,2*
+23580 continue
+ if(.not.((zvxw1l .eq. 3) .or. (zvxw1l .eq. 5)))goto 23582
+ do 23584 w3gohz=1,nfiumb4
+ t5vlzq(2*w3gohz-1,1) = jrxg6l(2*lir0o1-1,w3gohz) * hr83e(w3gohz,2*
&lir0o1-1)
- t5vlzq(2*w3gohz ,1)=jrxg6l(2*lir0o1 ,w3gohz)*hr83e(w3gohz,2*
+ t5vlzq(2*w3gohz ,1) = jrxg6l(2*lir0o1 ,w3gohz) * hr83e(w3gohz,2*
&lir0o1 )
+23584 continue
+ goto 23583
23582 continue
- goto 23581
-23580 continue
- do 23584 w3gohz=1,nfiumb4
+ do 23586 w3gohz=1,nfiumb4
t5vlzq(w3gohz,1) = jrxg6l(lir0o1,w3gohz) * hr83e(w3gohz,lir0o1)
-23584 continue
-23581 continue
+23586 continue
+23583 continue
+ call intpr("posn 5: ",-1,uxzze7,1)
tvyd2b = 101
+ call intpr("posn 6: ",-1,uxzze7,1)
call vdqrsl(ioqzvb,vi231l,vi231l,zx1610,i0qvzl, t5vlzq(1,1),
&elq2cs, t5vlzq(1,2), lq8reh(1+(lir0o1-1)*zxiwf1), elq2cs,t5vlzq(1,
&3),tvyd2b,fjg0qv)
- if(.not.(uvnk0i .gt. 1))goto 23586
-23586 continue
- do 23588 nd6mep=1,zxiwf1
- t5vlzq(nd6mep,1) = lq8reh((lir0o1-1)*zxiwf1 + nd6mep)
+ call dblepr("lq8reh(1+(lir0o1-1)*zxiwf1)",-1,lq8reh(1+(lir0o1-1)*
+ &zxiwf1),zxiwf1)
+ if(.not.(uvnk0i .gt. 1))goto 23588
23588 continue
do 23590 nd6mep=1,zxiwf1
- lq8reh((lir0o1-1)*zxiwf1 + i83h1(nd6mep)) = t5vlzq(nd6mep,1)
+ t5vlzq(nd6mep,1) = lq8reh((lir0o1-1)*zxiwf1 + nd6mep)
23590 continue
- if(.not.((zvxw1l .eq. 3) .or. (zvxw1l .eq. 5)))goto 23592
- do 23594 w3gohz=1,nfiumb4
- go0l1q(2*lir0o1-1,w3gohz)=t5vlzq(2*w3gohz-1,3)/jrxg6l(2*lir0o1-1,
- &w3gohz)
+ do 23592 nd6mep=1,zxiwf1
+ lq8reh((lir0o1-1)*zxiwf1 + i83h1(nd6mep)) = t5vlzq(nd6mep,1)
+23592 continue
+ call intpr("posn 7: ",-1,uxzze7,1)
+ if(.not.((zvxw1l .eq. 3) .or. (zvxw1l .eq. 5)))goto 23594
+ do 23596 w3gohz=1,nfiumb4
+ go0l1q(2*lir0o1-1,w3gohz) = t5vlzq(2*w3gohz-1,3) / jrxg6l(2*
+ &lir0o1-1,w3gohz)
go0l1q(2*lir0o1 ,w3gohz) = t5vlzq(2*w3gohz ,3) / jrxg6l(2*lir0o1 ,
&w3gohz)
-23594 continue
- if(.not.(h3mrfq .eq. 1))goto 23596
- do 23598 w3gohz=1,nfiumb4
+23596 continue
+ if(.not.(h3mrfq .eq. 1))goto 23598
+ do 23600 w3gohz=1,nfiumb4
go0l1q(2*lir0o1-1,w3gohz) = go0l1q(2*lir0o1-1,w3gohz) + q121lc(
&w3gohz)
+23600 continue
23598 continue
-23596 continue
- goto 23593
-23592 continue
- do 23600 w3gohz=1,nfiumb4
+ goto 23595
+23594 continue
+ do 23602 w3gohz=1,nfiumb4
go0l1q(lir0o1,w3gohz) = t5vlzq(w3gohz,3) / jrxg6l(lir0o1,w3gohz)
-23600 continue
- if(.not.(h3mrfq .eq. 1))goto 23602
- do 23604 w3gohz=1,nfiumb4
+23602 continue
+ if(.not.(h3mrfq .eq. 1))goto 23604
+ do 23606 w3gohz=1,nfiumb4
go0l1q(lir0o1,w3gohz) = go0l1q(lir0o1,w3gohz) + q121lc(w3gohz)
+23606 continue
23604 continue
-23602 continue
-23593 continue
+23595 continue
+ call intpr("posn 8: ",-1,uxzze7,1)
call o47zxq(go0l1q, w5poyv, nfiumb4, lku8xq, aqk377, zvxw1l,
&lir0o1)
+ call intpr("posn 8b: ",-1,uxzze7,1)
call kqx20o(zvxw1l, jmwo0z, w8xfic, w5poyv, nfiumb4, lku8xq,
&aqk377, xhe4cg, go0l1q, nx1bat,lir0o1,fiumb4,wlkaa3,uxzze7)
+ call intpr("posn 8c: ",-1,uxzze7,1)
xmr7cj = dabs(nx1bat - hq710) / (1.0d0 + dabs(nx1bat))
- if(.not.(xmr7cj .lt. qik6ym))goto 23606
+ call intpr("cqo1f: ucgi1r -------------",-1,ucgi1r,1)
+ call dblepr("cqo1f: xmr7cj",-1,xmr7cj,1)
+ if(.not.(xmr7cj .lt. qik6ym))goto 23608
gqxvz8 = 0
p1i8xz(8)=ucgi1r
- if(.not.((zvxw1l .eq. 3) .or. (zvxw1l .eq. 5)))goto 23608
+ call intpr("cqo1f p1i8xz(8): ",-1,p1i8xz(8),1)
+ if(.not.((zvxw1l .eq. 3) .or. (zvxw1l .eq. 5)))goto 23610
call kqx20o(zvxw1l, jmwo0z, w8xfic, w5poyv, nfiumb4, lku8xq,
&aqk377, xhe4cg, go0l1q, nx1bat,lir0o1,fiumb4,wlkaa3, oht3ga)
-23608 continue
+23610 continue
ni1qfp = ni1qfp + nx1bat
goto 1011
- goto 23607
-23606 continue
+ goto 23609
+23608 continue
hq710 = nx1bat
-23607 continue
-23560 continue
- if(.not.(ugsma5 .eq. 1))goto 23610
+23609 continue
+ call intpr("posn 9: ",-1,uxzze7,1)
+23562 continue
+ call intpr("cqo1f; unsuccessful convergence: ",-1,uxzze7,1)
+ if(.not.(ugsma5 .eq. 1))goto 23612
ugsma5 = 0
p1i8xz(9) = 1
goto 653
-23610 continue
+23612 continue
gqxvz8 = 3
1011 epx9jf = 1.0d0
-23552 continue
+23554 continue
+ call intpr(
+ &"exiting cqo1f uxzze7 ============================ : ",-1,uxzze7,
+ &1)
nx1bat = ni1qfp
return
end
@@ -1657,6 +1712,8 @@
d8gwha = p1i8xz(19)
ni1qfp = 0.0d0
uxzze7 = 1
+ zxao0o(1) = 1.0d0
+ t5vlzq(1,1) = 1.0d0
cqui1v = p1i8xz(1)
zxiwf1 = p1i8xz(3)
xhe4cg = p1i8xz(4)
@@ -1666,85 +1723,85 @@
p1i8xz(9) = 0
tiav4e = p1i8xz(11)
dyt0pg = p1i8xz(12)
- if(.not.((dyt0pg .ne. 1) .or. (tiav4e .ne. cqui1v)))goto 23612
+ if(.not.((dyt0pg .ne. 1) .or. (tiav4e .ne. cqui1v)))goto 23614
gqxvz8 = 4
return
-23612 continue
+23614 continue
uvnk0i = p1i8xz(15)
foej1u = p1i8xz(18)
h4fgoy = l1zvxx(3+aqk377+aqk377+2)
fiumb4 = l1zvxx(1)
zl11l0 = dsqrt(fiumb4)
- if(.not.((zvxw1l .eq. 1) .or. (zvxw1l .eq. 4)))goto 23614
+ if(.not.((zvxw1l .eq. 1) .or. (zvxw1l .eq. 4)))goto 23616
wlkaa3 = dlog(fiumb4)
-23614 continue
+23616 continue
qik6ym = l1zvxx(2)
jftq1 = l1zvxx(3)
elq2cs = 0.0d0
oht3ga = 0
gqxvz8 = 1
- do 23616 lir0o1=1,aqk377
+ do 23618 lir0o1=1,aqk377
653 epx9jf = 1.0d0
- if(.not.(ugsma5 .eq. 0))goto 23618
+ if(.not.(ugsma5 .eq. 0))goto 23620
call nbq4ua(jmwo0z, go0l1q, l1zvxx, nfiumb4, lku8xq, aqk377,
&zvxw1l, lir0o1, w8xfic, foej1u)
- goto 23619
-23618 continue
- if(.not.(ugsma5 .ne. 1))goto 23620
+ goto 23621
+23620 continue
+ if(.not.(ugsma5 .ne. 1))goto 23622
gqxvz8 = 6
return
-23620 continue
-23619 continue
+23622 continue
+23621 continue
call o47zxq(go0l1q, w5poyv, nfiumb4, lku8xq, aqk377, zvxw1l,
&lir0o1)
- if(.not.(ugsma5 .eq. 2))goto 23622
+ if(.not.(ugsma5 .eq. 2))goto 23624
call kqx20o(zvxw1l, jmwo0z, w8xfic, w5poyv, nfiumb4, lku8xq,
&aqk377, xhe4cg, go0l1q, hq710, lir0o1, fiumb4, wlkaa3, uxzze7)
- goto 23623
-23622 continue
+ goto 23625
+23624 continue
hq710 = -1.0d0
-23623 continue
- do 23624 ucgi1r=1,pga6nul
+23625 continue
+ do 23626 ucgi1r=1,pga6nul
call sptoq8(hft28, ioqzvb, nfiumb4, vi231l, cqui1v, zvxw1l)
gqai81(7) = 0
call kqsxz1(jmwo0z, w8xfic, go0l1q, w5poyv, hr83e, lj4dph, jrxg6l,
& jftq1, fiumb4, zl11l0, nfiumb4, lku8xq, aqk377, vi231l, zkjqhi,
&lir0o1, zvxw1l, gqxvz8, oht3ga, q121lc)
- if(.not.((zvxw1l .eq. 3) .or. (zvxw1l .eq. 5)))goto 23626
+ if(.not.((zvxw1l .eq. 3) .or. (zvxw1l .eq. 5)))goto 23628
ymetu2 = 2*lir0o1-1
- goto 23627
-23626 continue
+ goto 23629
+23628 continue
ymetu2 = lir0o1
-23627 continue
- do 23628 myx3od=1,h2mzlo
- do 23630 w3gohz=1,nfiumb4
+23629 continue
+ do 23630 myx3od=1,h2mzlo
+ do 23632 w3gohz=1,nfiumb4
zrcbl2(myx3od,w3gohz) = jrxg6l(ymetu2-1+myx3od,w3gohz)
nyg3mt(myx3od,w3gohz) = go0l1q(ymetu2-1+myx3od,w3gohz)
+23632 continue
23630 continue
-23628 continue
c3qxjo = tiav4e * aqk377
sglfr1 = cqui1v * (lir0o1-1)
- if(.not.(ucgi1r .eq. 1))goto 23632
+ if(.not.(ucgi1r .eq. 1))goto 23634
x1boaf = sq5cvf( sglfr1 + hwi2tb(1))
ad3xzo = sq5cvf(c3qxjo + sglfr1 + hwi2tb(1))
- if(.not.(cqui1v .eq. 2))goto 23634
+ if(.not.(cqui1v .eq. 2))goto 23636
j6gbnx = sq5cvf( sglfr1 + hwi2tb(2))
rk3jet = sq5cvf(c3qxjo + sglfr1 + hwi2tb(2))
-23634 continue
- do 23636 myx3od=1,tiav4e
- do 23638 w3gohz=1,nfiumb4
+23636 continue
+ do 23638 myx3od=1,tiav4e
+ do 23640 w3gohz=1,nfiumb4
sazp9g(w3gohz,sglfr1 + hwi2tb(myx3od)) = 0.0d0
+23640 continue
23638 continue
-23636 continue
- goto 23633
-23632 continue
+ goto 23635
+23634 continue
sq5cvf( sglfr1 + hwi2tb(1)) = x1boaf
sq5cvf(c3qxjo + sglfr1 + hwi2tb(1)) = ad3xzo
- if(.not.(cqui1v .eq. 2))goto 23640
+ if(.not.(cqui1v .eq. 2))goto 23642
sq5cvf( sglfr1 + hwi2tb(2)) = j6gbnx
sq5cvf(c3qxjo + sglfr1 + hwi2tb(2)) = rk3jet
-23640 continue
-23633 continue
+23642 continue
+23635 continue
call vbfa(d8gwha,nfiumb4,h2mzlo,gqai81, e6tljz, hr83e(1,ymetu2),
&lj4dph(1,ymetu2), sq5cvf( sglfr1 + hwi2tb(1)), sq5cvf(c3qxjo +
&sglfr1 + hwi2tb(1)), ynk9ah,uxs1iq,vliac4, vfd2pw,sazp9g(1,sglfr1
@@ -1755,43 +1812,43 @@
&qc7zyb, das4bx, vlni8d, jko0o1, mnh3up, fg3pxq)
l1zvxx(3+aqk377+aqk377+1) = das4bx
ibd3vc = gqai81(14)
- if(.not.(ibd3vc .ne. 0))goto 23642
+ if(.not.(ibd3vc .ne. 0))goto 23644
call intpr("vcao6f: exiting because of an error",-1,ibd3vc,1)
gqxvz8 = 8
return
-23642 continue
- do 23644 myx3od=1,h2mzlo
- do 23646 w3gohz=1,nfiumb4
+23644 continue
+ do 23646 myx3od=1,h2mzlo
+ do 23648 w3gohz=1,nfiumb4
go0l1q(ymetu2-1+myx3od,w3gohz) = nyg3mt(myx3od,w3gohz)
+23648 continue
23646 continue
-23644 continue
call o47zxq(go0l1q, w5poyv, nfiumb4, lku8xq, aqk377, zvxw1l,
&lir0o1)
call kqx20o(zvxw1l, jmwo0z, w8xfic, w5poyv, nfiumb4, lku8xq,
&aqk377, xhe4cg, go0l1q, nx1bat, lir0o1, fiumb4, wlkaa3, uxzze7)
xmr7cj = dabs(nx1bat - hq710) / (1.0d0 + dabs(nx1bat))
- if(.not.(xmr7cj .lt. qik6ym))goto 23648
+ if(.not.(xmr7cj .lt. qik6ym))goto 23650
gqxvz8 = 0
p1i8xz(8) = ucgi1r
- if(.not.((zvxw1l .eq. 3) .or. (zvxw1l .eq. 5)))goto 23650
+ if(.not.((zvxw1l .eq. 3) .or. (zvxw1l .eq. 5)))goto 23652
call kqx20o(zvxw1l, jmwo0z, w8xfic, w5poyv, nfiumb4, lku8xq,
&aqk377, xhe4cg, go0l1q, nx1bat,lir0o1,fiumb4,wlkaa3, oht3ga)
-23650 continue
+23652 continue
ni1qfp = ni1qfp + nx1bat
goto 1011
- goto 23649
-23648 continue
+ goto 23651
+23650 continue
hq710 = nx1bat
-23649 continue
-23624 continue
- if(.not.(ugsma5 .eq. 1))goto 23652
+23651 continue
+23626 continue
+ if(.not.(ugsma5 .eq. 1))goto 23654
ugsma5 = 0
p1i8xz(9) = 1
goto 653
-23652 continue
+23654 continue
gqxvz8 = 3
1011 epx9jf = 1.0d0
-23616 continue
+23618 continue
nx1bat = ni1qfp
return
end
@@ -1823,65 +1880,65 @@
dyt0pg = p1i8xz(12)
z2q1li = p1i8xz(13)
foej1u = p1i8xz(18)
- do 23654 pvnfr4=1,cqui1v
- do 23656 w3gohz=1,nfiumb4
+ do 23656 pvnfr4=1,cqui1v
+ do 23658 w3gohz=1,nfiumb4
wrbc3q = 0.0d0
- do 23658 s9otpy=1,p2
+ do 23660 s9otpy=1,p2
wrbc3q = wrbc3q + ize5km(w3gohz,s9otpy) * v8gzsp(s9otpy,pvnfr4)
-23658 continue
+23660 continue
ip0ox8(w3gohz,pvnfr4) = wrbc3q
hft28(w3gohz,pvnfr4) = wrbc3q
+23658 continue
23656 continue
-23654 continue
- if(.not.(dyt0pg.eq.1))goto 23660
+ if(.not.(dyt0pg.eq.1))goto 23662
call cqo1f(hft28, jmwo0z, oju3yh, w8xfic, go0l1q, q121lc, w5poyv,
&hr83e, lj4dph, jrxg6l, ur73jo, ioqzvb, i0qvzl, i83h1, nfiumb4,
&lku8xq, aqk377, vi231l, zkjqhi, gqxvz8, p1i8xz, zqve1l, vvl1li,
&gibj6t, zclbn2, t5vlzq, zxao0o, l1zvxx)
- goto 23661
-23660 continue
+ goto 23663
+23662 continue
call cqo2f(hft28, jmwo0z, oju3yh, w8xfic, go0l1q, q121lc, w5poyv,
&hr83e, lj4dph, jrxg6l, ur73jo, ioqzvb, i0qvzl, i83h1, nfiumb4,
&lku8xq, aqk377, vi231l, zkjqhi, gqxvz8, p1i8xz, zqve1l, vvl1li,
&gibj6t, zclbn2, t5vlzq, zxao0o, l1zvxx)
-23661 continue
- do 23662 s9otpy=1,p2
- do 23664 w3gohz=1,nfiumb4
+23663 continue
+ do 23664 s9otpy=1,p2
+ do 23666 w3gohz=1,nfiumb4
ize5km(w3gohz,s9otpy) = o4xmfj * ize5km(w3gohz,s9otpy)
+23666 continue
23664 continue
-23662 continue
- do 23666 pvnfr4=1,cqui1v
- do 23668 s9otpy=1,p2
- do 23670 w3gohz=1,nfiumb4
+ do 23668 pvnfr4=1,cqui1v
+ do 23670 s9otpy=1,p2
+ do 23672 w3gohz=1,nfiumb4
hft28(w3gohz,pvnfr4)=ip0ox8(w3gohz,pvnfr4)+ize5km(w3gohz,s9otpy)
-23670 continue
+23672 continue
p1i8xz(5) = 2
- do 23672 nd6mep=1,z2q1li
+ do 23674 nd6mep=1,z2q1li
lq8reh(nd6mep) = zclbn2(nd6mep)
-23672 continue
- if(.not.(dyt0pg.eq.1))goto 23674
+23674 continue
+ if(.not.(dyt0pg.eq.1))goto 23676
call cqo1f(hft28, jmwo0z, oju3yh, w8xfic, go0l1q, q121lc, w5poyv,
&hr83e, lj4dph, jrxg6l, ur73jo, ioqzvb, i0qvzl, i83h1, nfiumb4,
&lku8xq, aqk377, vi231l, zkjqhi, gqxvz8, p1i8xz, zqve1l, vvl1li,
&nx1bat, lq8reh, t5vlzq, zxao0o, l1zvxx)
- goto 23675
-23674 continue
+ goto 23677
+23676 continue
call cqo2f(hft28, jmwo0z, oju3yh, w8xfic, go0l1q, q121lc, w5poyv,
&hr83e, lj4dph, jrxg6l, ur73jo, ioqzvb, i0qvzl, i83h1, nfiumb4,
&lku8xq, aqk377, vi231l, zkjqhi, gqxvz8, p1i8xz, zqve1l, vvl1li,
&nx1bat, lq8reh, t5vlzq, zxao0o, l1zvxx)
-23675 continue
- if(.not.(gqxvz8 .ne. 0))goto 23676
+23677 continue
+ if(.not.(gqxvz8 .ne. 0))goto 23678
return
-23676 continue
+23678 continue
xt3fko(s9otpy,pvnfr4) = (nx1bat - gibj6t) / o4xmfj
-23668 continue
- if(.not.(cqui1v .gt. 1))goto 23678
- do 23680 w3gohz=1,nfiumb4
+23670 continue
+ if(.not.(cqui1v .gt. 1))goto 23680
+ do 23682 w3gohz=1,nfiumb4
hft28(w3gohz,pvnfr4) = ip0ox8(w3gohz,pvnfr4)
+23682 continue
23680 continue
-23678 continue
-23666 continue
+23668 continue
p1i8xz(5) = fiy4lc
return
end
@@ -1930,17 +1987,17 @@
foej1u = p1i8xz(18)
h4fgoy = l1zvxx(3+aqk377+aqk377+2)
o4xmfj = l1zvxx(3+aqk377+aqk377+3)
- do 23682 pvnfr4=1,cqui1v
- do 23684 w3gohz=1,nfiumb4
+ do 23684 pvnfr4=1,cqui1v
+ do 23686 w3gohz=1,nfiumb4
wrbc3q = 0.0d0
- do 23686 pp=1,p2
+ do 23688 pp=1,p2
wrbc3q = wrbc3q + ize5km(w3gohz,pp) * v8gzsp(pp,pvnfr4)
-23686 continue
+23688 continue
ip0ox8(w3gohz,pvnfr4) = wrbc3q
hft28(w3gohz,pvnfr4) = wrbc3q
+23686 continue
23684 continue
-23682 continue
- if(.not.(dyt0pg.eq.1))goto 23688
+ if(.not.(dyt0pg.eq.1))goto 23690
call vcao6f(hft28, jmwo0z, w8xfic, go0l1q, w5poyv, hr83e, lj4dph,
&jrxg6l, ioqzvb, i0qvzl, i83h1, nfiumb4, lku8xq, aqk377, vi231l,
&zkjqhi, gqxvz8, p1i8xz, gibj6t, zclbn2, t5vlzq, zxao0o, l1zvxx,
@@ -1949,21 +2006,21 @@
&ykdc2t, wk2, wzxao0o, phqco4, vb81l0, bmb, rjcq9o, mwk, n1zwoi,
&j1l0o1, qc7zyb, vlni8d, jko0o1, mnh3up, fg3pxq)
l1zvxx(3+aqk377+aqk377+1) = das4bx
- goto 23689
-23688 continue
-23689 continue
- do 23690 pp=1,p2
- do 23692 w3gohz=1,nfiumb4
+ goto 23691
+23690 continue
+23691 continue
+ do 23692 pp=1,p2
+ do 23694 w3gohz=1,nfiumb4
ize5km(w3gohz,pp) = o4xmfj * ize5km(w3gohz,pp)
+23694 continue
23692 continue
-23690 continue
- do 23694 pvnfr4=1,cqui1v
- do 23696 pp=1,p2
- do 23698 w3gohz=1,nfiumb4
+ do 23696 pvnfr4=1,cqui1v
+ do 23698 pp=1,p2
+ do 23700 w3gohz=1,nfiumb4
hft28(w3gohz,pvnfr4) = ip0ox8(w3gohz,pvnfr4) + ize5km(w3gohz,pp)
-23698 continue
+23700 continue
p1i8xz(5) = 0
- if(.not.(dyt0pg.eq.1))goto 23700
+ if(.not.(dyt0pg.eq.1))goto 23702
call vcao6f(hft28, jmwo0z, w8xfic, go0l1q, w5poyv, hr83e, lj4dph,
&jrxg6l, ioqzvb, i0qvzl, i83h1, nfiumb4, lku8xq, aqk377, vi231l,
&zkjqhi, gqxvz8, p1i8xz, nx1bat, lq8reh, t5vlzq, zxao0o, l1zvxx,
@@ -1972,20 +2029,20 @@
&ykdc2t, wk2, wzxao0o, phqco4, vb81l0, bmb, rjcq9o, mwk, n1zwoi,
&j1l0o1, qc7zyb, vlni8d, jko0o1, mnh3up, fg3pxq)
l1zvxx(3+aqk377+aqk377+1) = das4bx
- goto 23701
-23700 continue
-23701 continue
- if(.not.(gqxvz8 .ne. 0))goto 23702
- return
+ goto 23703
23702 continue
+23703 continue
+ if(.not.(gqxvz8 .ne. 0))goto 23704
+ return
+23704 continue
xt3fko(pp,pvnfr4) = (nx1bat - gibj6t) / o4xmfj
-23696 continue
- if(.not.(cqui1v .gt. 1))goto 23704
- do 23706 w3gohz=1,nfiumb4
+23698 continue
+ if(.not.(cqui1v .gt. 1))goto 23706
+ do 23708 w3gohz=1,nfiumb4
hft28(w3gohz,pvnfr4) = ip0ox8(w3gohz,pvnfr4)
+23708 continue
23706 continue
-23704 continue
-23694 continue
+23696 continue
p1i8xz(5) = fiy4lc
return
end
@@ -2014,44 +2071,44 @@
fiy4lc = p1i8xz(5)
dyt0pg = p1i8xz(12)
z2q1li = p1i8xz(13)
- if(.not.(dyt0pg.eq.1))goto 23708
+ if(.not.(dyt0pg.eq.1))goto 23710
call cqo1f(hft28, jmwo0z, oju3yh, w8xfic, go0l1q, q121lc, w5poyv,
&hr83e, lj4dph, jrxg6l, ur73jo, ioqzvb, i0qvzl, i83h1, nfiumb4,
&lku8xq, aqk377, vi231l, zkjqhi, gqxvz8, p1i8xz, zqve1l, vvl1li,
&gibj6t, zclbn2, t5vlzq, zxao0o, l1zvxx)
- goto 23709
-23708 continue
+ goto 23711
+23710 continue
call cqo2f(hft28, jmwo0z, oju3yh, w8xfic, go0l1q, q121lc, w5poyv,
&hr83e, lj4dph, jrxg6l, ur73jo, ioqzvb, i0qvzl, i83h1, nfiumb4,
&lku8xq, aqk377, vi231l, zkjqhi, gqxvz8, p1i8xz, zqve1l, vvl1li,
&gibj6t, zclbn2, t5vlzq, zxao0o, l1zvxx)
-23709 continue
- do 23710 pvnfr4=1,cqui1v
- do 23712 w3gohz=1,nfiumb4
+23711 continue
+ do 23712 pvnfr4=1,cqui1v
+ do 23714 w3gohz=1,nfiumb4
hft28(w3gohz,pvnfr4) = ip0ox8(w3gohz,pvnfr4) + o4xmfj
p1i8xz(5) = 2
- do 23714 nd6mep=1,z2q1li
+ do 23716 nd6mep=1,z2q1li
lq8reh(nd6mep) = zclbn2(nd6mep)
-23714 continue
- if(.not.(dyt0pg.eq.1))goto 23716
+23716 continue
+ if(.not.(dyt0pg.eq.1))goto 23718
call cqo1f(hft28, jmwo0z, oju3yh, w8xfic, go0l1q, q121lc, w5poyv,
&hr83e, lj4dph, jrxg6l, ur73jo, ioqzvb, i0qvzl, i83h1, nfiumb4,
&lku8xq, aqk377, vi231l, zkjqhi, gqxvz8, p1i8xz, zqve1l, vvl1li,
&nx1bat, lq8reh, t5vlzq, zxao0o, l1zvxx)
- goto 23717
-23716 continue
+ goto 23719
+23718 continue
call cqo2f(hft28, jmwo0z, oju3yh, w8xfic, go0l1q, q121lc, w5poyv,
&hr83e, lj4dph, jrxg6l, ur73jo, ioqzvb, i0qvzl, i83h1, nfiumb4,
&lku8xq, aqk377, vi231l, zkjqhi, gqxvz8, p1i8xz, zqve1l, vvl1li,
&nx1bat, lq8reh, t5vlzq, zxao0o, l1zvxx)
-23717 continue
- if(.not.(gqxvz8 .ne. 0))goto 23718
+23719 continue
+ if(.not.(gqxvz8 .ne. 0))goto 23720
return
-23718 continue
+23720 continue
xt3fko(w3gohz,pvnfr4) = (nx1bat - gibj6t) / o4xmfj
hft28(w3gohz,pvnfr4) = ip0ox8(w3gohz,pvnfr4)
+23714 continue
23712 continue
-23710 continue
p1i8xz(5) = fiy4lc
return
end
diff --git a/src/fgam.f b/src/fgam.f
index 333aadb..f6ea0d4 100644
--- a/src/fgam.f
+++ b/src/fgam.f
@@ -110,7 +110,12 @@ c dbiatx(i,m). storage of this value over the value of a b-spline
c of order m there is safe since the remaining b-spline derivat-
c ive of the same order do not use this value due to the fact
c that a(j,i) = 0 for j .lt. i .
- 30 do 40 i=1,k
+
+
+c Originally:
+c 30 do 40 i=1,k
+
+ do 40 i=1,k
sum = 0.
jlow = max0(i,m)
do 35 j=jlow,k
@@ -411,7 +416,13 @@ c
if (x .ge. xt(ilo)) go to 100
c
c **** now x .lt. xt(ilo) . decrease ilo to capture x .
- 30 istep = 1
+c
+c
+c Originally:
+c 30 istep = 1
+ istep = 1
+c
+c
31 ihi = ilo
ilo = ihi - istep
if (ilo .le. 1) go to 35
diff --git a/src/lms.f b/src/lms.f
index 183f90f..1910f2e 100644
--- a/src/lms.f
+++ b/src/lms.f
@@ -8,6 +8,8 @@
uxzze7 = 1
oht3ga = 0
fiumb4 = 1.0d-04
+ sfnva0 = 0.0d0
+ fpqrt7 = 1.0d0
cc = (psi .ge. 0.0d0)
if(.not.(cc))goto 23000
bb = dwgkz6
diff --git a/src/rgam.f b/src/rgam.f
index 1b538db..daf9c94 100644
--- a/src/rgam.f
+++ b/src/rgam.f
@@ -107,7 +107,7 @@
q = dabs(q)
r = e
e = d
-30 if(.not.((dabs(p) .ge. dabs(0.5d0*q*r)) .or.(q .eq. 0.0d0)))goto 2
+ if(.not.((dabs(p) .ge. dabs(0.5d0*q*r)) .or.(q .eq. 0.0d0)))goto 2
&3021
go to 40
23021 continue
@@ -185,7 +185,6 @@
dwgkz6 = dyb3po * dexp((-2.0d0 + x*6.0d0) * dlog(16.0d0))
n9peut = fx
return
-23012 continue
return
end
subroutine poqy8c(vf1jtn,eh6nly,mvx9at,vbxpg4,tb,nb)
@@ -396,7 +395,6 @@
23102 continue
23098 continue
return
-23092 continue
end
subroutine oipu6h(egoxa3,atqh0o,x,y,w, nfiumb4,nk,rlhz2a, knot,
&coef,sz,rjcq9o, n9peut, dwgkz6, mheq6i, n7cuql,dvpc8x,hdv8br,
@@ -507,7 +505,6 @@
23130 continue
23126 continue
return
-23118 continue
end
subroutine ak9vxi(p3vlea,hr83e,w,onyz6j, xl6qgm,nfiumb4, wevr5o,
&n7cuql,dvpc8x,hdv8br,cbg5ys)
diff --git a/src/tyeepolygamma.f b/src/tyeepolygamma.f
index 5fd2ef4..1f90e43 100644
--- a/src/tyeepolygamma.f
+++ b/src/tyeepolygamma.f
@@ -3,12 +3,11 @@
double precision x, ghry8z
integer c4uxow
double precision w, sqap4b, temp
+ c4uxow = 1
if(.not.(x .le. 0.0d0))goto 23000
c4uxow = 0
return
23000 continue
- c4uxow = 1
-23001 continue
if(.not.(x .lt. 6.0d0))goto 23002
call vdgam2(x + 6.0d0, temp, c4uxow)
ghry8z = temp - 1.0d0/x - 1.0d0/(x + 1.0d0) - 1.0d0/(x + 2.0d0) -
@@ -28,12 +27,11 @@
double precision x, ghry8z
integer c4uxow
double precision w, sqap4b, temp
+ c4uxow = 1
if(.not.(x .le. 0.0d0))goto 23004
c4uxow = 0
return
23004 continue
- c4uxow = 1
-23005 continue
if(.not.(x .lt. 6.0d0))goto 23006
call vdgam1(x + 6.0d0, temp, c4uxow)
ghry8z = temp - 1.0d0/x - 1.0d0/(x + 1.0d0) - 1.0d0/(x + 2.0d0) -
@@ -53,12 +51,11 @@
double precision x, ghry8z
integer c4uxow
double precision w, sqap4b, temp
+ c4uxow = 1
if(.not.(x .le. 0.0d0))goto 23008
c4uxow = 0
return
23008 continue
- c4uxow = 1
-23009 continue
if(.not.(x .lt. 6.0d0))goto 23010
call vtgam2(x + 6.0d0, temp, c4uxow)
ghry8z = temp + 1.0d0/x**2 + 1.0d0/(x + 1.0d0)**2 + 1.0d0/(x + 2.
@@ -79,12 +76,11 @@
double precision x, ghry8z
integer c4uxow
double precision w, sqap4b, temp
+ c4uxow = 1
if(.not.(x .le. 0.0d0))goto 23012
c4uxow = 0
return
23012 continue
- c4uxow = 1
-23013 continue
if(.not.(x .lt. 6.0d0))goto 23014
call vtgam1(x + 6.0d0, temp, c4uxow)
ghry8z = temp + 1.0d0/x**2 + 1.0d0/(x + 1.0d0)**2 + 1.0d0/(x + 2.
diff --git a/src/vmux.f b/src/vmux.f
index 7df8880..09345ed 100644
--- a/src/vmux.f
+++ b/src/vmux.f
@@ -517,13 +517,12 @@
double precision f0, t0, m0, f1, t1, m1, f2, t2, m2
double precision toobig
toobig = 20.0d0
+ gqxvz8 = 0
if(.not.(.not.(xt3fko .eq. 0 .or. xt3fko .eq. 1 .or. xt3fko .eq.
&2)))goto 23171
gqxvz8 = 1
return
23171 continue
- gqxvz8 = 0
-23172 continue
do 23173 nd6mep=1,nfiumb4
if(.not.(dabs(yg1jzv(nd6mep)) .gt. toobig))goto 23175
gqxvz8 = 1
diff --git a/src/zeta.f b/src/zeta.f
deleted file mode 100644
index 4ff9991..0000000
--- a/src/zeta.f
+++ /dev/null
@@ -1,138 +0,0 @@
- subroutine vzetawr(x, ans, deriv, nn)
- double precision x(nn), ans(nn), zeta8, dzeta8, ddzeta8
- integer deriv, nn, i
- double precision b2(12)
- call vbecoef(b2)
- if(.not.(deriv.eq.0))goto 23000
- do 23002 i=1,nn
- ans(i) = zeta8(x(i), b2)
-23002 continue
-23000 continue
- if(.not.(deriv.eq.1))goto 23004
- do 23006 i=1,nn
- ans(i) = dzeta8(x(i), b2)
-23006 continue
-23004 continue
- if(.not.(deriv.eq.2))goto 23008
- do 23010 i=1,nn
- ans(i) = ddzeta8(x(i), b2)
-23010 continue
-23008 continue
- return
- end
- double precision function zeta8(s, b2)
- double precision s
- double precision b2(12)
- integer a, k
- integer m, n, m2
- double precision sum, p, a2, fred
- a = 12
- k = 8
- a2 = a * a
- p = s / 2.0d0 / a2
- sum = 1.0d0 / (s - 1.0d0) + 0.5d0 / a + b2(1) * p
- do 23012 m = 2,k
- m2 = m + m
- p = p * (s + m2 - 3.0d0) * (s + m2 - 2.0d0) / (m2 - 1.0d0) / m2 /
- &a2
- sum = sum + p * b2(m)
-23012 continue
- fred = dexp((s - 1.0d0) * dlog( dfloat(a) ))
- sum = 1.0d0 + sum / fred
- do 23014 n = 2,(a - 1)
- sum = sum + dexp(-s * dlog( dfloat(n) ))
-23014 continue
- zeta8 = sum
- return
- end
- double precision function dzeta8(s, b2)
- double precision s
- double precision b2(12)
- integer a, k
- integer m, n, m2
- double precision sum, p, q, a2, loga, logn
- double precision fred
- a = 12
- k = 8
- loga = dlog( dfloat(a) )
- a2 = a * a
- p = s / 2.0d0 / a2
- q = 1.0d0 / s - loga
- sum = b2(1) * p * q
- do 23016 m = 2,k
- m2 = m + m
- p = p * (s + m2 - 3.0d0) * (s + m2 - 2.0d0) / (m2 - 1.0d0) / m2 /
- &a2
- q = q + 1.0d0 / (s + m2 - 3.0d0) + 1.0d0 / (s + m2 - 2.0d0)
- sum = sum + b2(m) * p * q
-23016 continue
- fred = dexp((1.0d0 - s) * loga)
- sum = (sum - 1.0d0/ (s - 1.0d0)**2 - loga * (1.0d0/(s - 1.0d0) +
- &0.50d0/a)) * fred
- do 23018 n = 2, (a - 1)
- logn = dlog( dfloat(n) )
- sum = sum - logn / dexp(logn * s)
-23018 continue
- dzeta8 = sum
- return
- end
- double precision function upsilon8(s, b2)
- double precision s, dzeta8, zeta8, b2(12)
- upsilon8 = -dzeta8(s, b2) / zeta8(s, b2)
- return
- end
- double precision function ddzeta8(s, b2)
- double precision s, b2(12)
- integer a, k
- integer m, n, m2
- double precision sum, p, q, r, a2, loga, logn
- double precision fred, fred2
- a = 12
- k = 8
- loga = dlog( dfloat(a) )
- a2 = a * a
- p = s / 2.0d0 / a2
- q = 1.0d0 / s - loga
- r = 1.0d0 / s / s
- sum = b2(1) * p * (q * q - r)
- do 23020 m = 2,k
- m2 = m + m
- p = p * (s + m2 - 3.0d0) * (s + m2 - 2.0d0) / (m2 - 1.0d0) / m2 /
- &a2
- q = q + 1.0d0 / (s + m2 - 3.0d0) + 1.0d0 / (s + m2 - 2.0d0)
- r = r + 1.0d0 / (s + m2 - 3.0d0)**2 + 1.0d0 / (s + m2 - 2.0d0)**2
- sum = sum + b2(m) * p * (q * q - r)
-23020 continue
- fred = dexp((1.0d0 - s) * loga)
- fred2 = loga**2 * (1.0d0/(s - 1.0d0) + 0.5d0/a)
- sum = (sum + 2.0d0 / (s - 1.0d0)**3 + 2.0d0 * loga / (s - 1.0d0)**
- &2 + fred2) * fred
- do 23022 n = 2,(a - 1)
- logn = dlog( dfloat(n) )
- sum = sum + (logn)**2 / dexp(logn * s)
-23022 continue
- ddzeta8 = sum
- return
- end
- double precision function duds(s, b2)
- double precision s, b2(12), zs, zeta8, dzeta8, ddzeta8
- zs = zeta8(s, b2)
- duds = (dzeta8(s, b2) / zs)**2 - ddzeta8(s, b2) / zs
- return
- end
- subroutine vbecoef(b2)
- double precision b2(12)
- b2(1) = 1.0d0 / 6.0d0
- b2(2) = -1.0d0 / 30.0d0
- b2(3) = 1.0d0 / 42.0d0
- b2(4) = -1.0d0 / 30.0d0
- b2(5) = 5.0d0 / 66.0d0
- b2(6) = -691.0d0 / 2730.0d0
- b2(7) = 7.0d0 / 6.0d0
- b2(8) = -3617.0d0 / 510.0d0
- b2(9) = 4386.7d0 / 79.8d0
- b2(10) = -1746.11d0 / 3.30d0
- b2(11) = 8545.13d0 / 1.38d0
- b2(12) = -2363.64091d0 / 0.02730d0
- return
- end
diff --git a/src/zeta4.c b/src/zeta4.c
new file mode 100644
index 0000000..a944a6f
--- /dev/null
+++ b/src/zeta4.c
@@ -0,0 +1,258 @@
+/* 20091207 Thomas W Yee */
+/* This is my attempt to convert zeta.pas into zeta.r */
+/* It seems that zeta.pas implements 2 algorithms; Ive chosen */
+/* the latest algorithm. */
+/* */
+/* 20020802; Ive added a "8" to the function names: just in case */
+/* */
+/* Adapted from zeta.c */
+/* Adapted from Garry Tees Pascal program Gram: # 1999-8-11 */
+/* It all works, since Ive compared the results to Garrys for */
+/* s=1.1,...,4.9 */
+/* */
+/* Evaluate zeta(s) by Grams method, 1903 */
+/* */
+/* gn = 20; # Stieltjes coefficients gg(0..gn) of length(gn+1) */
+/* # Stieltjes for zeta(s) O.K. for s<4 */
+/* */
+/* Note: */
+/* Subroutine vstcoef(gg) */
+/* Subroutine vzsdzs(s, zs, dzs, gg) */
+/* commented out (not needed) */
+
+/* ------------------------------------------------------------------------ */
+
+#include <math.h>
+#include <Rmath.h>
+#include <R.h>
+
+/* Function prototype */
+void aaaa_vzetawr(double x[], double *ans, long *deriv, long *nn);
+double aaaa_zeta8(double s, double B2[]);
+double aaaa_dzeta8(double s, double B2[]);
+double Upsilon8(double s, double B2[]);
+double aaaa_ddzeta8(double s, double B2[]);
+double duds(double s, double B2[]);
+void vbecoef(double B2[]);
+
+/* ------------------------------------------------------------------------ */
+
+void aaaa_vzetawr(double x[], double *ans, long *deriv, long *nn) {
+
+/* Wrapper function for the zeta function and first 2 derivs */
+
+/* double precision x(nn), ans(nn), */
+/* double x[nn-1], ans[nn-1] */
+
+ int ilocal;
+
+/* Bernoulli numbers B(2k) */
+ double B2[12];
+
+ vbecoef(B2);
+
+/* Generate the Bernoulli coefficients into B2 */
+
+ if (*deriv == 0) {
+ for (ilocal = 0; ilocal < *nn; ilocal++) {
+ ans[ilocal] = aaaa_zeta8(x[ilocal], B2);
+ }
+ }
+ else if (*deriv == 1) {
+ for (ilocal = 0; ilocal < *nn; ilocal++) {
+ ans[ilocal] = aaaa_dzeta8(x[ilocal], B2);
+ }
+ }
+ else if (*deriv == 2) {
+ for (ilocal = 0; ilocal < *nn; ilocal++) {
+ ans[ilocal] = aaaa_ddzeta8(x[ilocal], B2);
+ }
+ }
+ else {
+ Rprintf("Error: *deriv must equal 0, 1 or 2\n");
+ }
+
+}
+
+/* ------------------------------------------------------------------------ */
+
+double aaaa_zeta8(double s, double B2[]) {
+
+/* Grams method for zeta(s), s>0,s<>1 */
+/* cf Bengt Markman, BIT 5 (1965), 138-141 */
+
+/* Bernoulli numbers B(2k) assumed set */
+
+ int alocal, klocal;
+
+/* Local var */
+ int mlocal, nlocal, m2local;
+ double sum, plocal, a2local, fred;
+
+ alocal = 12;
+/* For 62 significant binary digits in zeta(s) */
+ klocal = 8;
+
+ a2local = pow(alocal, 2.0);
+ plocal = s / 2.000 / a2local;
+ sum = 1.000 / (s - 1.000) + 0.500 / alocal + B2[0] * plocal;
+
+ for (mlocal = 2; mlocal <= klocal; mlocal++){
+ m2local = mlocal + mlocal;
+ plocal *= (s + m2local - 3.000) *
+ (s + m2local - 2.000) / (m2local - 1.000) / m2local / a2local;
+ sum += plocal * B2[mlocal-1];
+ }
+ fred = exp((s - 1.000) * log( (double) alocal));
+ sum = 1.000 + sum / fred;
+
+ for (nlocal = 2; nlocal < alocal; nlocal++){
+/* nlocal ** (-s) # power(nlocal, -s) */
+ sum += exp(-s * log( (double) nlocal ));
+ }
+
+ return sum;
+}
+
+/* ------------------------------------------------------------------------ */
+
+double aaaa_dzeta8(double s, double B2[]) {
+
+/* Grams method for d zeta(s)/ds, s>0,s<>1 */
+/* cf Bengt Markman, BIT 5 (1965), 138-141 */
+
+/* Local var */
+ int alocal, klocal;
+ int mlocal, nlocal, m2local;
+ double sum, plocal, qlocal, a2local, loga, logn;
+ double fred;
+
+ alocal = 12;
+/* For 62 significant binary digits in zeta8(s) */
+ klocal = 8;
+
+ loga = log( (double) alocal );
+ a2local = alocal * alocal;
+ plocal = s / 2.000 / a2local;
+ qlocal = 1.000 / s - loga;
+ sum = B2[0] * plocal * qlocal;
+
+ for (mlocal = 2; mlocal <= klocal; mlocal++){
+ m2local = mlocal + mlocal;
+ plocal *= (s + m2local - 3.000) *
+ (s + m2local - 2.000) / (m2local - 1.000) / m2local / a2local;
+ qlocal += 1.000 / (s + m2local - 3.000) + 1.000 / (s + m2local - 2.000);
+ sum += B2[mlocal-1] * plocal * qlocal;
+ }
+ fred = exp((1.000 - s) * loga);
+/* nb. sqr in pascal is square, not square root */
+ sum = (sum - 1.000/ pow((s - 1.000), 2.0) - loga * (1.000/(s - 1.000) +
+ 0.5000/alocal)) * fred;
+
+ for (nlocal = 2; nlocal < alocal; nlocal++){
+ logn = log( (double) nlocal );
+ sum -= logn / exp(logn * s);
+ }
+
+ return sum;
+}
+
+/* ------------------------------------------------------------------------ */
+
+double Upsilon8(double s, double B2[]) {
+/* double precision dzeta8, zeta8; */
+ double Upsilon8;
+
+ Upsilon8 = -aaaa_dzeta8(s, B2) / aaaa_zeta8(s, B2);
+
+ return Upsilon8;
+}
+
+/* ------------------------------------------------------------------------ */
+
+double aaaa_ddzeta8(double s, double B2[]) {
+
+/* Grams method for zeta"(s), s>0,s<>1 */
+/* cf Bengt Markman, BIT 5 (1965), 138-141 */
+
+
+/* Local var */
+ int alocal, klocal;
+ int mlocal, nlocal, m2local;
+ double sum, plocal, qlocal, rlocal, a2local, loga, logn;
+ double fred, fred2;
+
+ alocal = 12;
+/* For 62 significant binary digits in zeta8(s) */
+ klocal = 8;
+
+ loga = log( (double) alocal );
+ a2local = alocal * alocal;
+ plocal = s / 2.000 / a2local;
+ qlocal = 1.000 / s - loga;
+ rlocal = 1.000 / s / s;
+ sum = B2[0] * plocal * (pow(qlocal, 2.0) - rlocal);
+
+ for (mlocal = 2; mlocal < klocal; mlocal++){
+ m2local = mlocal + mlocal;
+ plocal *= (s + m2local - 3.000) *
+ (s + m2local - 2.000) / (m2local - 1.000) / m2local / a2local;
+/* plocal = s(s+1)...(s+2mlocal-2)/(2mlocal)!/a^(2mlocal) */
+ qlocal += 1.000 / (s + m2local - 3.000) +
+ 1.000 / (s + m2local - 2.000);
+/* qlocal = 1/s + 1/(s+1) + ... + 1/(s+2mlocal-2) - log alocal */
+ rlocal += 1.000 / pow((s + m2local - 3.000), 2.0) +
+ 1.000 / pow((s + m2local - 2.000), 2.0);
+/* rlocal = -dq/ds = 1/s^2 + 1/(s+1)^2 + ... + 1/(s+2mlocal-2)^2 */
+ sum += B2[mlocal-1] * plocal * (qlocal * qlocal - rlocal);
+ }
+ fred = exp((1.000 - s) * loga);
+ fred2 = pow(loga, 2.0) * (1.000/(s - 1.000) + 0.500/alocal);
+ sum = (sum + 2.000 / pow((s - 1.000), 3.0) +
+ 2.000 * loga / pow((s - 1.000), 2.0) + fred2) * fred;
+
+ for (nlocal = 2; nlocal < alocal; nlocal++) {
+ logn = log( (double) nlocal );
+ sum += pow(logn, 2.0) / exp(logn * s);
+ }
+
+ return sum;
+}
+
+/* ------------------------------------------------------------------------ */
+
+double duds(double s, double B2[]) {
+/* d Upsilon / ds */
+/* double zs, zeta8, dzeta8, ddzeta8 */
+
+ double zs, duds;
+
+ zs = aaaa_zeta8(s, B2);
+ duds = pow(aaaa_dzeta8(s, B2) / zs, 2.0) - aaaa_ddzeta8(s, B2) / zs;
+
+ return duds;
+}
+
+/* ------------------------------------------------------------------------ */
+
+void vbecoef(double B2[]) {
+/* Bernoulli numbers B(2k) */
+
+/* Generate (set) the Bernoulli numbers */
+/* Reference: p.810 Abramowitz and Stegun */
+
+ B2[0] = 1.000 / 6.000;
+ B2[1] = -1.000 / 30.000;
+ B2[2] = 1.000 / 42.000;
+ B2[3] = -1.000 / 30.000;
+ B2[4] = 5.000 / 66.000;
+ B2[5] = -691.000 / 2730.000;
+ B2[6] = 7.000 / 6.000;
+ B2[7] = -3617.000 / 510.000;
+ B2[8] = 4386.700 / 79.800;
+ B2[9] = -1746.1100 / 3.3000;
+ B2[10] = 8545.1300 / 1.3800;
+ B2[11] = -2363.6409100 / 0.0273000;
+}
+
+/* ------------------------------------------------------------------------ */
--
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