[r-cran-vgam] 09/63: Import Upstream version 0.7-6
Andreas Tille
tille at debian.org
Tue Jan 24 13:54:21 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 4ee3c39f8c047806489bc6bcf22464db402fbf52
Author: Andreas Tille <tille at debian.org>
Date: Tue Jan 24 14:16:46 2017 +0100
Import Upstream version 0.7-6
---
DESCRIPTION | 8 +-
NAMESPACE | 69 +-
NEWS | 59 ++
R/aamethods.q | 54 +-
R/add1.vglm.q | 2 +-
R/attrassign.R | 2 +-
R/build.terms.vlm.q | 2 +-
R/calibrate.q | 2 +-
R/cao.R | 2 +-
R/cao.fit.q | 5 +-
R/coef.vlm.q | 2 +-
R/cqo.R | 2 +-
R/cqo.fit.q | 5 +-
R/deviance.vlm.q | 2 +-
R/effects.vglm.q | 2 +-
R/family.aunivariate.q | 808 +++++++++++++++++++
R/family.basics.q | 22 +-
R/family.binomial.q | 2 +-
R/family.bivariate.q | 597 ++++++++++++--
R/family.categorical.q | 263 ++++++-
R/family.censored.q | 157 +++-
R/family.circular.q | 292 +++++++
R/family.extremes.q | 8 +-
R/family.functions.q | 2 +-
R/family.genetic.q | 2 +-
R/family.glmgam.q | 251 +++++-
R/family.loglin.q | 2 +-
R/family.mixture.q | 443 ++++++-----
R/family.nonlinear.q | 2 +-
R/family.normal.q | 303 +++++++-
R/family.positive.q | 60 +-
R/family.qreg.q | 1509 ++++++++++++++++++++++++-----------
R/family.rcqo.q | 2 +-
R/family.rrr.q | 2 +-
R/family.survival.q | 2 +-
R/family.ts.q | 2 +-
R/family.univariate.q | 1513 ++++++++++++++++++++++++++++--------
R/family.vglm.q | 2 +-
R/family.zeroinf.q | 363 ++++++++-
R/fitted.vlm.q | 2 +-
R/generic.q | 2 +-
R/links.q | 41 +-
R/logLik.vlm.q | 2 +-
R/model.matrix.vglm.q | 3 +-
R/mux.q | 17 +-
R/plot.vglm.q | 2 +-
R/predict.vgam.q | 2 +-
R/predict.vglm.q | 2 +-
R/predict.vlm.q | 2 +-
R/print.summary.others.q | 2 +-
R/print.vglm.q | 2 +-
R/print.vlm.q | 2 +-
R/qrrvglm.control.q | 2 +-
R/qtplot.q | 12 +-
R/residuals.vlm.q | 2 +-
R/rrvglm.R | 2 +-
R/rrvglm.control.q | 2 +-
R/rrvglm.fit.q | 5 +-
R/s.q | 2 +-
R/s.vam.q | 2 +-
R/smart.R | 2 +-
R/step.vglm.q | 2 +-
R/summary.others.q | 2 +-
R/summary.vgam.q | 2 +-
R/summary.vglm.q | 13 +-
R/summary.vlm.q | 2 +-
R/uqo.R | 2 +-
R/vgam.R | 64 +-
R/vgam.control.q | 2 +-
R/vgam.fit.q | 8 +-
R/vgam.match.q | 2 +-
R/vglm.R | 44 +-
R/vglm.control.q | 2 +-
R/vglm.fit.q | 6 +-
R/vlm.R | 2 +-
R/vlm.wfit.q | 2 +-
R/vsmooth.spline.q | 2 +-
R/zzz.R | 2 +-
data/{aml.R => leukemia.R} | 6 +-
data/toxop.R | 2 +-
man/CommonVGAMffArguments.Rd | 193 +++++
man/Links.Rd | 7 +-
man/Surv.Rd | 48 +-
man/SurvS4-class.Rd | 9 +-
man/VGAM-package.Rd | 7 +-
man/alaplace3.Rd | 293 +++++++
man/alaplaceUC.Rd | 96 +++
man/alsqreg.Rd | 95 ++-
man/{fgm.Rd => amh.Rd} | 77 +-
man/amhUC.Rd | 70 ++
man/amlbinomial.Rd | 137 ++++
man/amlexponential.Rd | 144 ++++
man/amlpoisson.Rd | 150 ++++
man/{betaff.Rd => beta.ab.Rd} | 54 +-
man/betaff.Rd | 153 ++--
man/betanormUC.Rd | 4 +-
man/binomialff.Rd | 12 +-
man/borel.tanner.Rd | 113 +++
man/bortUC.Rd | 64 ++
man/cao.Rd | 11 +-
man/cardUC.Rd | 80 ++
man/cardioid.Rd | 107 +++
man/cauchit.Rd | 1 +
man/cauchy.Rd | 140 ++++
man/cauchy1.Rd | 97 ---
man/cenpoisson.Rd | 147 ++++
man/chisq.Rd | 1 +
man/constraints.Rd | 7 +-
man/cqo.Rd | 7 +-
man/cumulative.Rd | 70 +-
man/dexpbinomial.Rd | 8 +-
man/dirichlet.Rd | 2 +-
man/exponential.Rd | 3 +
man/felix.Rd | 73 ++
man/felixUC.Rd | 61 ++
man/fgm.Rd | 31 +-
man/fgmUC.Rd | 70 ++
man/fitted.vlm.Rd | 5 +-
man/fnormUC.Rd | 76 ++
man/fnormal1.Rd | 126 +++
man/frank.Rd | 17 +-
man/frankUC.Rd | 4 +-
man/freund61.Rd | 2 +-
man/gammahyp.Rd | 2 +-
man/gaussianff.Rd | 1 +
man/genpoisson.Rd | 104 ++-
man/golf.Rd | 6 +-
man/gumbelIbiv.Rd | 2 +-
man/hunua.Rd | 4 +-
man/hzeta.Rd | 22 +-
man/hzetaUC.Rd | 23 +-
man/invbinomial.Rd | 115 +++
man/kumar.Rd | 86 ++
man/kumarUC.Rd | 68 ++
man/laplace.Rd | 23 +-
man/{aml.Rd => leukemia.Rd} | 14 +-
man/lms.yjn.Rd | 47 +-
man/loge.Rd | 4 +-
man/logff.Rd | 17 +-
man/lqnorm.Rd | 131 ++++
man/mbinomial.Rd | 167 ++++
man/mccullagh89.Rd | 10 +-
man/mckaygamma2.Rd | 2 +-
man/{mix2poisson.Rd => mix2exp.Rd} | 108 +--
man/mix2normal1.Rd | 95 ++-
man/mix2poisson.Rd | 89 ++-
man/morgenstern.Rd | 4 +-
man/nbolf.Rd | 6 +-
man/negbinomial.Rd | 7 +-
man/normal1.Rd | 19 +-
man/notdocumentedyet.Rd | 13 +-
man/ordpoisson.Rd | 4 +-
man/plackUC.Rd | 75 ++
man/plackett.Rd | 115 +++
man/pneumo.Rd | 5 +-
man/poissonff.Rd | 6 +
man/polf.Rd | 6 +-
man/polonoUC.Rd | 65 +-
man/posbinomUC.Rd | 12 +-
man/posnormal1.Rd | 3 +
man/pospoisUC.Rd | 10 +-
man/pospoisson.Rd | 23 +-
man/powl.Rd | 12 +-
man/rayleigh.Rd | 1 +
man/riceUC.Rd | 63 ++
man/riceff.Rd | 99 +++
man/rrvglm-class.Rd | 5 +-
man/rrvglm.Rd | 11 +-
man/ruge.Rd | 4 +-
man/skellam.Rd | 105 +++
man/skellamUC.Rd | 64 ++
man/skewnormal1.Rd | 13 +-
man/slash.Rd | 113 +++
man/slashUC.Rd | 72 ++
man/studentt.Rd | 29 +-
man/undocumented-methods.Rd | 2 +
man/usagrain.Rd | 5 +-
man/vgam-class.Rd | 10 +-
man/vgam.Rd | 14 +-
man/vglm-class.Rd | 5 +-
man/vglm.Rd | 24 +-
man/vonmises.Rd | 3 +-
man/waitakere.Rd | 4 +-
man/yulesimon.Rd | 95 +++
man/yulesimonUC.Rd | 70 ++
man/zanegbinomial.Rd | 2 +
man/zetaff.Rd | 12 +-
man/zibinomUC.Rd | 15 +-
man/zinbUC.Rd | 92 +++
man/zinegbinomial.Rd | 146 ++++
man/zipf.Rd | 18 +-
man/zipoisUC.Rd | 18 +-
man/zipoisson.Rd | 6 +-
src/testf90.f90 | 30 +
194 files changed, 10641 insertions(+), 2012 deletions(-)
diff --git a/DESCRIPTION b/DESCRIPTION
index 0f83deb..8be3782 100755
--- a/DESCRIPTION
+++ b/DESCRIPTION
@@ -1,6 +1,6 @@
Package: VGAM
-Version: 0.7-4
-Date: 2007-10-1
+Version: 0.7-6
+Date: 2008-03-17
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>
@@ -11,8 +11,8 @@ Description: Vector generalized linear and additive models, and
distribution by maximum likelihood estimation (MLE) or
penalized MLE. Also fits constrained ordination models in
ecology.
-License: GPL version 2
+License: GPL-2
URL: http://www.stat.auckland.ac.nz/~yee/VGAM
LazyLoad: yes
LazyData: yes
-Packaged: Mon Oct 1 16:58:20 2007; yee
+Packaged: Mon Mar 17 19:11:07 2008; yee
diff --git a/NAMESPACE b/NAMESPACE
index af292b9..1e71d16 100644
--- a/NAMESPACE
+++ b/NAMESPACE
@@ -1,5 +1,5 @@
# These functions are
-# Copyright (C) 1998-2007 T.W. Yee, University of Auckland. All rights reserved.
+# Copyright (C) 1998-2008 T.W. Yee, University of Auckland. All rights reserved.
@@ -41,12 +41,16 @@ export( bs, ns, scale.default, poly )
export(iam,
fill, fill1, fill2, fill3,
+amh, damh, pamh, ramh,
freund61,
frechet2, frechet3, dfrechet, pfrechet, qfrechet, rfrechet,
frank, dfrank, pfrank, rfrank,
+plackett, dplack, pplack, rplack,
benini, dbenini, pbenini, qbenini, rbenini,
maxwell, dmaxwell, pmaxwell, qmaxwell, rmaxwell,
-morgenstern, fgm, gumbelIbiv,
+morgenstern,
+dfgm, pfgm, rfgm, fgm,
+gumbelIbiv,
erf, erfc, lerch,
tpareto1, dtpareto, qtpareto, rtpareto, ptpareto,
pareto1, dpareto, qpareto, rpareto, ppareto,
@@ -56,9 +60,12 @@ paretoII, dparetoII, qparetoII, rparetoII, pparetoII,
dparetoI, qparetoI, rparetoI, pparetoI,
cgumbel, egumbel, gumbel,
dgumbel, pgumbel, qgumbel, rgumbel,
+fnormal1, dfnorm, pfnorm, qfnorm, rfnorm,
cnormal1, dcnormal1,
recnormal1, recexp1,
crayleigh, rayleigh, drayleigh, prayleigh, qrayleigh, rrayleigh,
+drice, rrice, riceff,
+dskellam, rskellam, skellam,
dinv.gaussian, pinv.gaussian, rinv.gaussian, wald, expexp1, expexp)
@@ -71,8 +78,8 @@ betabin.ab, betabinomial,
dexpbinomial,
dbetabin, pbetabin, rbetabin, dbetabin.ab, pbetabin.ab, rbetabin.ab,
biplot.qrrvglm,
-borel.tanner,
-cauchy1, ccoef.cao, ccoef.Coef.cao,
+dbort, rbort, borel.tanner,
+cauchy, cauchy1, ccoef.cao, ccoef.Coef.cao,
ccoef.Coef.qrrvglm, ccoef.qrrvglm, cdf, cdf.lms.bcg, cdf.lms.bcn,
cdf.lms.yjn, cdf.vglm,
Coef.cao, Coefficients, coefqrrvglm,
@@ -80,7 +87,8 @@ coefvlm,
coefvsmooth.spline, coefvsmooth.spline.fit, constraints,
constraints.vlm,
deplot, deplot.default, deplot.lms.bcg, deplot.lms.bcn,
-deplot.lms.yjn, deplot.vglm,
+deplot.lms.yjn, deplot.lms.yjn2,
+deplot.vglm,
deviance.uqo, deviance.vglm, deviance.vlm, df.residual.vlm,
dirmultinomial, dirmul.old,
dnorm2,
@@ -95,6 +103,7 @@ export(ordpoisson, poissonp)
export(m2adefault,
erlang,
family.vglm,
+dfelix, felix,
fitted.values.uqo, fitted.vlm, fittedvsmooth.spline, fsqrt,
garma, gaussianff,
hypersecant, hypersecant.1,
@@ -102,7 +111,10 @@ hyperg,
invbinomial, InverseBrat, inverse.gaussianff, inv.gaussianff,
is.Numeric,
mccullagh89, leipnik, levy,
-lms.bcg.control, lms.bcn.control, lmscreg.control, lms.yjn.control,
+lms.bcg.control, lms.bcn.control, lmscreg.control,
+lms.yjn.control,
+lms.bcg, lms.bcn, lms.yjn, lms.yjn2,
+lqnorm,
dbilogis4, pbilogis4, rbilogis4, bilogistic4,
logistic1, logistic2,
logLik.vlm, lv.cao, lv.Coef.cao, lv.Coef.qrrvglm,
@@ -131,7 +143,7 @@ predictvsmooth.spline.fit,
process.binomial2.data.vgam, process.categorical.data.vgam,
qtplot,
qtplot.default, qtplot.gumbel, qtplot.lms.bcg,
-qtplot.lms.bcn, qtplot.lms.yjn, qtplot.vextremes, qtplot.vglm,
+qtplot.lms.bcn, qtplot.lms.yjn, qtplot.lms.yjn2, qtplot.vextremes, qtplot.vglm,
rlplot,
rlplot.egev, rlplot.gev,
rlplot.vextremes, rlplot.vglm,
@@ -139,8 +151,9 @@ rlplot, rlplot.vglm, rrar.control,
rrvglm.control.Gaussian)
export(
-Surv, is.SurvS4,
+Surv, is.SurvS4, as.character.SurvS4, print.SurvS4,
simple.exponential, simple.poisson,
+mbinomial,
seq2binomial, size.binomial,
stdze1, stdze2,
summary.cao, summary.grc, summary.lms, summary.qrrvglm,
@@ -185,6 +198,9 @@ export(dpolono, rpolono)
export(dgpd, pgpd, qgpd, rgpd, gpd)
export(dgev, pgev, qgev, rgev, gev, egev)
export(dlaplace, plaplace, qlaplace, rlaplace, laplace)
+export(dalaplace, palaplace, qalaplace, ralaplace,
+ alaplace1, alaplace2, alaplace3)
+export(dcard, pcard, qcard, rcard, cardioid)
export(fff, fff.control,
mbesselI0,
vonmises)
@@ -192,7 +208,7 @@ export(fff, fff.control,
export(
AA.Aa.aa, AB.Ab.aB.ab2, AB.Ab.aB.ab, ABO, acat,
-betaff, betaffqn,
+beta.ab, betaff, betaffqn,
dbetageom, pbetageom, rbetageom, betageometric,
betaprime,
betaII, binom2.or, binom2.rho, binomialff, biplot.rrvglm, brat,
@@ -200,7 +216,7 @@ bratt, Brat, calibrate.qrrvglm.control, calibrate.qrrvglm,
calibrate, cao.control,
cao, ccoef, cdf.lmscreg, cgo, chisq, clo,
Coef.qrrvglm, Coef, Coef.rrvglm, Coef.vlm,
-cratio, cumulative, deplot.lmscreg, dirichlet,
+cratio, cumulative, scumulative, deplot.lmscreg, dirichlet,
exponential, G1G2G3)
export(
@@ -219,21 +235,25 @@ grc,
dhzeta, phzeta, qhzeta, rhzeta, hzeta,
nidentity, identity,
prentice74,
-lms.bcg, lms.bcn,
-lms.yjn,
-alsqreg,
+alsqreg, amlbinomial, amlexponential, amlpoisson, Wr1, Wr2,
+dkumar, pkumar, qkumar, rkumar, kumar,
+dyules, pyules, ryules, yulesimon,
logff, dlog, plog, rlog,
loglinb2, loglinb3,
loglog, lognormal3, lvplot.qrrvglm,
lvplot, lvplot.rrvglm, lv, Max, MNSs, multinomial)
+export(
+slash, dslash, pslash, rslash)
export(
meplot, meplot.default, meplot.vlm,
guplot, guplot.default, guplot.vlm,
negbinomial, normal1, tobit, Opt,
+dzinb, pzinb, qzinb, rzinb, zinegbinomial,
persp.qrrvglm, plotdeplot.lmscreg, plotqrrvglm, plotqtplot.lmscreg,
plotvgam.control, plotvgam,
+cenpoisson,
poissonff,
dposnorm, pposnorm, qposnorm, rposnorm, posnormal1,
dposbinom, pposbinom, qposbinom, rposbinom, posbinomial,
@@ -256,7 +276,8 @@ vgam.control, vgam, vglm.control, vglm,
vsmooth.spline,
weibull, yip88, zanegbinomial, zapoisson,
dzipois, pzipois, qzipois, rzipois, zipoisson,
-mix2normal1, mix2poisson,
+mix2exp, mix2normal1, mix2poisson,
+mix2exp.control, mix2normal1.control, mix2poisson.control,
skewnormal1, dsnorm, rsnorm,
tikuv, dtikuv, ptikuv, qtikuv, rtikuv,
dzibinom, pzibinom, qzibinom, rzibinom, zibinomial)
@@ -278,11 +299,19 @@ exportClasses("vglmff", "vlm", "vglm", "vgam",
exportClasses("SurvS4")
+
exportMethods(
-"coef", "Coef", "coefficients", "constraints",
-"effects", "fitted", "fitted.values", "predict",
-"print", "resid", "residuals", "show",
-"summary", "terms", "model.frame", "model.matrix",
+"coef", "Coef", "coefficients",
+"constraints",
+"effects", "fitted", "fitted.values",
+"predict",
+"print",
+"resid",
+"residuals", "show",
+"summary",
+"terms",
+"model.frame",
+"model.matrix",
"deviance", "logLik", "vcov",
"calibrate", "cdf", "ccoef", "df.residual",
"lv", "Max", "Opt", "Tol",
@@ -291,3 +320,7 @@ exportMethods(
"weights",
"persp")
+
+
+
+
diff --git a/NEWS b/NEWS
index 104f09a..ece6420 100755
--- a/NEWS
+++ b/NEWS
@@ -5,6 +5,65 @@
**************************************************
+ CHANGES IN VGAM VERSION 0.7-6
+
+NEW FEATURES
+
+ o dpolono() has a new argument 'bigx' which implements an
+ approximation. It is for handling large values of x.
+ o vglm() and vgam() now create the response and model matrices etc.
+ in the same way as glm(). A consequence is that the response
+ does not have to be "numeric" as in lm(), e.g., a factor response
+ is now permitted.
+ o New VGAM family functions:
+ alaplace1(), alaplace2(), alaplace3(dpqr),
+ amlbinomial(), amlexponential(), amlpoisson(), amh(),
+ lqnorm(), mbinomial(), scumulative().
+ o Other VGAM family functions with argument names changed or added:
+ lms.yjn2().
+ o These VGAM family functions have been improved:
+ alsqreg() [parallel option, w argument can be a vector, link function
+ for the expectiles].
+ o The data set "aml" has been renamed "leukemia".
+ o Previously laplace(zero=NULL), now laplace(zero=2).
+
+BUG FIXES
+
+ o deplot() applied to a "lms.yjn2" object gave an unnecessary warning.
+ o In the leukemia and toxop data sets 1L is replaced by 1 and 2L by 2 etc.
+
+
+
+
+ CHANGES IN VGAM VERSION 0.7-5
+
+NEW FEATURES
+
+ o New VGAM family functions:
+ betaff(), cardioid(dpqr), cauchy(), felix(d), fnormal1(dpqr),
+ invbinomial(), kumar(dpqr), lms.yjn2(), mix2exp(), plackett(dpr),
+ riceff(dr), skellam(dr), zinegbinomial(dpqr).
+ o These VGAM family functions have been improved:
+ frank(), genpoisson(), hzeta(), mix2normal1(), mix2poisson(),
+ pospoisson(), studentt().
+ o These VGAM family functions have had their default arguments changed:
+ genpoisson(), mix2normal1().
+ o New documentation: borel.tanner(dr).
+ o expm1() used whenever possible.
+ o Renamed VGAM family functions: betaff() changed to beta.ab().
+ o cauchy1() now returns the location estimates as the fitted values
+ instead of NA (for the mean).
+
+
+BUG FIXES
+
+ o cumulative(), sratio(), cratio(), acat() had response-matrix
+ column names which got lost.
+ o lms.yjn() failed if there was not enough data.
+
+
+
+
CHANGES IN VGAM VERSION 0.7-4
NEW FEATURES
diff --git a/R/aamethods.q b/R/aamethods.q
index 543fb01..02bdfd6 100644
--- a/R/aamethods.q
+++ b/R/aamethods.q
@@ -1,5 +1,5 @@
# These functions are
-# Copyright (C) 1998-2007 T.W. Yee, University of Auckland. All rights reserved.
+# Copyright (C) 1998-2008 T.W. Yee, University of Auckland. All rights reserved.
@@ -379,10 +379,12 @@ setClass("vfamily",
if(!isGeneric("Coef"))
-setGeneric("Coef", function(object, ...) standardGeneric("Coef"))
+setGeneric("Coef", function(object, ...) standardGeneric("Coef"),
+ package="VGAM")
if(!isGeneric("Coefficients"))
setGeneric("Coefficients", function(object, ...)
- standardGeneric("Coefficients"))
+ standardGeneric("Coefficients"),
+ package="VGAM")
@@ -393,7 +395,8 @@ setGeneric("Coefficients", function(object, ...)
if(FALSE) {
if(!isGeneric("AIC"))
- setGeneric("AIC", function(object, ..., k=2) standardGeneric("AIC"))
+ setGeneric("AIC", function(object, ..., k=2) standardGeneric("AIC"),
+ package="VGAM")
AIC.vlm = function(object, ..., k=2) {
ed = object at misc$estimated.dispersion
@@ -444,13 +447,16 @@ setMethod("AIC", "qrrvglm",
}
if(!isGeneric("logLik"))
- setGeneric("logLik", function(object, ...) standardGeneric("logLik"))
+ setGeneric("logLik", function(object, ...) standardGeneric("logLik"),
+ package="VGAM")
if(!isGeneric("plot"))
- setGeneric("plot", function(x, y, ...) standardGeneric("plot"))
+ setGeneric("plot", function(x, y, ...) standardGeneric("plot"),
+ package="VGAM")
if(!isGeneric("vcov"))
- setGeneric("vcov", function(object, ...) standardGeneric("vcov"))
+ setGeneric("vcov", function(object, ...) standardGeneric("vcov"),
+ package="VGAM")
@@ -490,32 +496,39 @@ setClass(Class="cao", repr=representation("vgam", "uqo"))
if(!isGeneric("lvplot"))
-setGeneric("lvplot", function(object, ...) standardGeneric("lvplot"))
+setGeneric("lvplot", function(object, ...) standardGeneric("lvplot"),
+ package="VGAM")
if(!isGeneric("ccoef"))
- setGeneric("ccoef", function(object, ...) standardGeneric("ccoef"))
+ setGeneric("ccoef", function(object, ...) standardGeneric("ccoef"),
+ package="VGAM")
if(!isGeneric("coef"))
- setGeneric("coef", function(object, ...) standardGeneric("coef"))
+ setGeneric("coef", function(object, ...) standardGeneric("coef"),
+ package="VGAM")
if(!isGeneric("coefficients"))
setGeneric("coefficients", function(object, ...)
- standardGeneric("coefficients"))
+ standardGeneric("coefficients"),
+ package="VGAM")
if(!isGeneric("df.residual"))
setGeneric("df.residual", function(object, ...)
- standardGeneric("df.residual"))
+ standardGeneric("df.residual"),
+ package="VGAM")
if(!isGeneric("fitted"))
- setGeneric("fitted", function(object, ...) standardGeneric("fitted"))
+ setGeneric("fitted", function(object, ...) standardGeneric("fitted"),
+ package="VGAM")
if(!isGeneric("fitted.values"))
setGeneric("fitted.values", function(object, ...)
- standardGeneric("fitted.values"))
+ standardGeneric("fitted.values"),
+ package="VGAM")
if(!isGeneric("model.matrix"))
setGeneric("model.matrix", function(object, ...)
@@ -526,17 +539,24 @@ if(!isGeneric("model.frame"))
standardGeneric("model.frame"))
+
+
+
if(!isGeneric("predict"))
- setGeneric("predict", function(object, ...) standardGeneric("predict"))
+ setGeneric("predict", function(object, ...) standardGeneric("predict"))
+
+
if(!isGeneric("resid"))
setGeneric("resid", function(object, ...) standardGeneric("resid"))
if(!isGeneric("residuals"))
- setGeneric("residuals", function(object, ...) standardGeneric("residuals"))
+ setGeneric("residuals", function(object, ...) standardGeneric("residuals"),
+ package="VGAM")
if(!isGeneric("weights"))
- setGeneric("weights", function(object, ...) standardGeneric("weights"))
+ setGeneric("weights", function(object, ...) standardGeneric("weights"),
+ package="VGAM")
diff --git a/R/add1.vglm.q b/R/add1.vglm.q
index f45f384..4162d6d 100644
--- a/R/add1.vglm.q
+++ b/R/add1.vglm.q
@@ -1,5 +1,5 @@
# These functions are
-# Copyright (C) 1998-2007 T.W. Yee, University of Auckland. All rights reserved.
+# Copyright (C) 1998-2008 T.W. Yee, University of Auckland. All rights reserved.
diff --git a/R/attrassign.R b/R/attrassign.R
index c59b8cd..d568440 100644
--- a/R/attrassign.R
+++ b/R/attrassign.R
@@ -1,5 +1,5 @@
# These functions are
-# Copyright (C) 1998-2007 T.W. Yee, University of Auckland. All rights reserved.
+# Copyright (C) 1998-2008 T.W. Yee, University of Auckland. All rights reserved.
diff --git a/R/build.terms.vlm.q b/R/build.terms.vlm.q
index 030ec25..9439027 100644
--- a/R/build.terms.vlm.q
+++ b/R/build.terms.vlm.q
@@ -1,5 +1,5 @@
# These functions are
-# Copyright (C) 1998-2007 T.W. Yee, University of Auckland. All rights reserved.
+# Copyright (C) 1998-2008 T.W. Yee, University of Auckland. All rights reserved.
diff --git a/R/calibrate.q b/R/calibrate.q
index b3df9bb..9bebf9e 100644
--- a/R/calibrate.q
+++ b/R/calibrate.q
@@ -1,5 +1,5 @@
# These functions are
-# Copyright (C) 1998-2007 T.W. Yee, University of Auckland. All rights reserved.
+# Copyright (C) 1998-2008 T.W. Yee, University of Auckland. All rights reserved.
diff --git a/R/cao.R b/R/cao.R
index f4268bb..686277e 100644
--- a/R/cao.R
+++ b/R/cao.R
@@ -1,5 +1,5 @@
# These functions are
-# Copyright (C) 1998-2007 T.W. Yee, University of Auckland. All rights reserved.
+# Copyright (C) 1998-2008 T.W. Yee, University of Auckland. All rights reserved.
diff --git a/R/cao.fit.q b/R/cao.fit.q
index 8f249ca..2e42b7c 100644
--- a/R/cao.fit.q
+++ b/R/cao.fit.q
@@ -1,5 +1,5 @@
# These functions are
-# Copyright (C) 1998-2007 T.W. Yee, University of Auckland. All rights reserved.
+# Copyright (C) 1998-2008 T.W. Yee, University of Auckland. All rights reserved.
@@ -14,6 +14,7 @@ cao.fit <- function(x, y, w=rep(1, length(x[, 1])),
qr.arg=FALSE, constraints=NULL, extra=NULL,
Terms=Terms, function.name="cao", ...)
{
+ specialCM = NULL
post = list()
check.rank = TRUE #
nonparametric <- TRUE
@@ -118,7 +119,7 @@ cao.fit <- function(x, y, w=rep(1, length(x[, 1])),
rrcontrol$Cinit = control$Cinit = Cmat # Good for valt()
- Blist <- process.constraints(constraints, x, M)
+ Blist <- process.constraints(constraints, x, M, specialCM=specialCM)
nice31 = checkCMCO(Blist, control=control, modelno=modelno)
if(nice31 != 1) stop("not nice")
diff --git a/R/coef.vlm.q b/R/coef.vlm.q
index c17322c..3b5ff07 100644
--- a/R/coef.vlm.q
+++ b/R/coef.vlm.q
@@ -1,5 +1,5 @@
# These functions are
-# Copyright (C) 1998-2007 T.W. Yee, University of Auckland. All rights reserved.
+# Copyright (C) 1998-2008 T.W. Yee, University of Auckland. All rights reserved.
diff --git a/R/cqo.R b/R/cqo.R
index a543e95..f343d6c 100644
--- a/R/cqo.R
+++ b/R/cqo.R
@@ -1,5 +1,5 @@
# These functions are
-# Copyright (C) 1998-2007 T.W. Yee, University of Auckland. All rights reserved.
+# Copyright (C) 1998-2008 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 1026700..b230fcb 100644
--- a/R/cqo.fit.q
+++ b/R/cqo.fit.q
@@ -1,5 +1,5 @@
# These functions are
-# Copyright (C) 1998-2007 T.W. Yee, University of Auckland. All rights reserved.
+# Copyright (C) 1998-2008 T.W. Yee, University of Auckland. All rights reserved.
@@ -267,6 +267,7 @@ cqo.fit <- function(x, y, w=rep(1, length(x[, 1])),
Terms=Terms, function.name="cqo", ...)
{
if(!all(offset == 0)) stop("cqo.fit() cannot handle offsets")
+ specialCM = NULL
post = list()
nonparametric <- FALSE
epsilon <- control$epsilon
@@ -393,7 +394,7 @@ cqo.fit <- function(x, y, w=rep(1, length(x[, 1])),
rrcontrol$Ainit = control$Ainit = Amat # Good for valt()
rrcontrol$Cinit = control$Cinit = Cmat # Good for valt()
- Blist <- process.constraints(constraints, x, M)
+ Blist <- process.constraints(constraints, x, M, specialCM=specialCM)
nice31 = checkCMCO(Blist, control=control, modelno=modelno)
ncolBlist <- unlist(lapply(Blist, ncol))
dimB <- sum(ncolBlist)
diff --git a/R/deviance.vlm.q b/R/deviance.vlm.q
index 5d94935..646218e 100644
--- a/R/deviance.vlm.q
+++ b/R/deviance.vlm.q
@@ -1,5 +1,5 @@
# These functions are
-# Copyright (C) 1998-2007 T.W. Yee, University of Auckland. All rights reserved.
+# Copyright (C) 1998-2008 T.W. Yee, University of Auckland. All rights reserved.
diff --git a/R/effects.vglm.q b/R/effects.vglm.q
index 4a635f0..f6af963 100644
--- a/R/effects.vglm.q
+++ b/R/effects.vglm.q
@@ -1,5 +1,5 @@
# These functions are
-# Copyright (C) 1998-2007 T.W. Yee, University of Auckland. All rights reserved.
+# Copyright (C) 1998-2008 T.W. Yee, University of Auckland. All rights reserved.
diff --git a/R/family.aunivariate.q b/R/family.aunivariate.q
new file mode 100644
index 0000000..25a2457
--- /dev/null
+++ b/R/family.aunivariate.q
@@ -0,0 +1,808 @@
+# These functions are
+# Copyright (C) 1998-2008 T.W. Yee, University of Auckland. All rights reserved.
+
+
+
+
+
+
+
+dkumar = function(x, shape1, shape2) {
+ ans = shape1 * shape2 * x^(shape1-1) * (1 - x^shape1)^(shape2-1)
+ ans[(x <= 0) | (x >= 1)] = 0
+ ans[(shape1 <= 0) | (shape2 <= 0)] = NA
+ ans
+}
+
+
+rkumar = function(n, shape1, shape2) {
+ if(!is.Numeric(n, integ=TRUE,allow=1)) stop("bad input for argument \"n\"")
+ ans = (1 - (1 - runif(n))^(1/shape2))^(1/shape1)
+ ans[(shape1 <= 0) | (shape2 <= 0)] = NA
+ ans
+}
+
+
+qkumar = function(p, shape1, shape2) {
+ if(!is.Numeric(p)) stop("bad input for argument \"p\"")
+ if(!is.Numeric(shape1, posi=TRUE)) stop("bad input for argument \"shape1\"")
+ if(!is.Numeric(shape2, posi=TRUE)) stop("bad input for argument \"shape2\"")
+
+ bad = (p < 0) | (p > 1)
+ if(any(bad))
+ stop("bad input for 'p'")
+
+ ans = (1 - (1 - p)^(1/shape2))^(1/shape1)
+ ans[(shape1 <= 0) | (shape2 <= 0)] = NA
+ ans
+}
+
+
+pkumar = function(q, shape1, shape2) {
+ ans = 1 - (1 - q^shape1)^shape2
+ ans[q>=1] = 1
+ ans[q<=0] = 0
+ ans[(shape1 <= 0) | (shape2 <= 0)] = NA
+ ans
+}
+
+
+
+kumar.control <- function(save.weight=TRUE, ...)
+{
+ list(save.weight=save.weight)
+}
+
+
+kumar = function(lshape1="loge", lshape2="loge",
+ eshape1=list(), eshape2=list(),
+ ishape1=NULL, ishape2=NULL,
+ nsimEIM=500, zero=NULL)
+{
+ if(mode(lshape1) != "character" && mode(lshape1) != "name")
+ lshape1 = as.character(substitute(lshape1))
+ if(mode(lshape2) != "character" && mode(lshape2) != "name")
+ lshape2 = as.character(substitute(lshape2))
+ if(length(ishape1) && (!is.Numeric(ishape1, allow=1, positive=TRUE)))
+ stop("bad input for argument \"ishape1\"")
+ 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)
+ stop("'nsimEIM' should be an integer greater than 50")
+
+ new("vglmff",
+ blurb=c("Kumaraswamy distribution\n\n",
+ "Links: ",
+ namesof("shape1", lshape1, earg= eshape1), ", ",
+ namesof("shape2", lshape2, earg= eshape2, tag=FALSE), "\n",
+ "Mean: ",
+ "shape2 * beta(1+1/shape1, shape2)"),
+ constraints=eval(substitute(expression({
+ constraints = cm.zero.vgam(constraints, x, .zero, M)
+ }), list( .zero=zero ))),
+ initialize=eval(substitute(expression({
+ if(ncol(y <- cbind(y)) != 1)
+ stop("the response must be a vector or one-column matrix")
+ if(any((y <= 0) | (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)) {
+
+ kumar.Loglikfun = function(shape1, y, x, w, extraargs) {
+ 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
+ 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
+ log(0.5) / log1p(-(medy^shape1.init))
+ shape2.init = rep(shape2.init, length=length(y))
+ etastart = cbind(theta2eta(shape1.init, .lshape1, earg= .eshape1),
+ theta2eta(shape2.init, .lshape2, earg= .eshape2))
+ }
+ }), list( .lshape1=lshape1, .lshape2=lshape2,
+ .ishape1=ishape1, .ishape2=ishape2,
+ .eshape1=eshape1, .eshape2=eshape2 ))),
+ inverse=eval(substitute(function(eta, extra=NULL){
+ shape1 = eta2theta(eta[,1], link= .lshape1, earg= .eshape1)
+ shape2 = eta2theta(eta[,2], link= .lshape2, earg= .eshape2)
+ shape2 * (base::beta(1+1/shape1,shape2))
+ }, list( .lshape1=lshape1, .lshape2=lshape2,
+ .eshape1=eshape1, .eshape2=eshape2 ))),
+ last=eval(substitute(expression({
+ misc$link = c("shape1"= .lshape1, "shape2"= .lshape2)
+ misc$earg = list("shape1"= .eshape1, "shape2"= .eshape2)
+ misc$expected = TRUE
+ misc$nsimEIM = .nsimEIM
+ }), list( .lshape1=lshape1, .lshape2=lshape2,
+ .eshape1=eshape1, .eshape2=eshape2, .nsimEIM=nsimEIM ))),
+ loglikelihood=eval(substitute(
+ 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
+ sum(w * (log(shape1) + log(shape2) + (shape1-1)*log(y) +
+ (shape2-1)*log1p(-y^shape1)))
+ }, list( .lshape1=lshape1, .lshape2=lshape2,
+ .eshape1=eshape1, .eshape2=eshape2 ))),
+ vfamily=c("kumar"),
+ deriv=eval(substitute(expression({
+ shape1 = eta2theta(eta[,1], link= .lshape1, earg= .eshape1)
+ shape2 = eta2theta(eta[,2], link= .lshape2, earg= .eshape2)
+ dshape1.deta = dtheta.deta(shape1, link= .lshape1, earg= .eshape1)
+ dshape2.deta = dtheta.deta(shape2, link= .lshape2, earg= .eshape2)
+ dl.dshape1 = 1/shape1 + log(y) - (shape2-1) * log(y) *
+ (y^shape1) / (1-y^shape1)
+ dl.dshape2 = 1/shape2 + log1p(-y^shape1)
+ w * cbind(dl.dshape1 * dshape1.deta,
+ dl.dshape2 * dshape2.deta)
+ }), list( .lshape1=lshape1, .lshape2=lshape2,
+ .eshape1=eshape1, .eshape2=eshape2, .nsimEIM=nsimEIM ))),
+ weight = eval(substitute(expression({
+ run.mean = 0
+ for(ii in 1:( .nsimEIM )) {
+ ysim = rkumar(n, shape1=shape1, shape2=shape2)
+ dl.dshape1 = 1/shape1 + log(ysim) - (shape2-1) * log(ysim) *
+ (ysim^shape1) / (1-ysim^shape1)
+ dl.dshape2 = 1/shape2 + log1p(-ysim^shape1)
+ d2l.dshape1shape2 = ysim^shape1 * log(ysim) / (1-ysim^shape1)
+ d2l.dshape22 = 1 / shape2^2
+ d2l.dshape12 = 1 / shape1^2 +
+ (shape2-1)* ((log(ysim))^2) * (ysim^shape1) / (1 - ysim^shape1)^2
+ rm(ysim)
+ temp3 = matrix(0, n, dimm(M))
+ temp3[,iam(1,1,M=M)] = d2l.dshape12
+ temp3[,iam(2,2,M=M)] = d2l.dshape22
+ temp3[,iam(1,2,M=M)] = d2l.dshape1shape2
+ run.mean = ((ii-1) * run.mean + temp3) / ii
+ }
+ wz = if(intercept.only)
+ matrix(apply(run.mean,2,mean), n, dimm(M), byrow=TRUE) else run.mean
+
+ dtheta.detas = cbind(dshape1.deta, dshape2.deta)
+ index0 = iam(NA, NA, M=M, both=TRUE, diag=TRUE)
+ wz = wz * dtheta.detas[,index0$row] * dtheta.detas[,index0$col]
+ w * wz
+ }), list( .lshape1=lshape1, .lshape2=lshape2,
+ .eshape1=eshape1, .eshape2=eshape2, .nsimEIM=nsimEIM ))))
+}
+
+
+
+
+drice = function(x, vee, sigma) {
+ ans = (x / sigma^2) * exp(-(x^2+vee^2)/(2*sigma^2)) *
+ besselI(abs(x*vee/sigma^2), nu=0)
+ ans[(x <= 0)] = 0
+ ans[!is.finite(vee) | !is.finite(sigma) | (vee < 0) | (sigma <= 0)] = NA
+ ans
+}
+
+
+rrice = function(n, vee, sigma) {
+ 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)
+ sqrt(X^2 + Y^2)
+}
+
+
+
+riceff.control <- function(save.weight=TRUE, ...)
+{
+ list(save.weight=save.weight)
+}
+
+
+riceff = function(lvee="loge", lsigma="loge",
+ evee=list(), esigma=list(),
+ ivee=NULL, isigma=NULL,
+ nsimEIM=100, zero=NULL)
+{
+ if(mode(lvee) != "character" && mode(lvee) != "name")
+ lvee = as.character(substitute(lvee))
+ if(mode(lsigma) != "character" && mode(lsigma) != "name")
+ lsigma = as.character(substitute(lsigma))
+ if(length(ivee) && !is.Numeric(ivee, positive=TRUE))
+ stop("bad input for argument \"ivee\"")
+ if(length(isigma) && !is.Numeric(isigma, positive=TRUE))
+ stop("bad input for argument \"isigma\"")
+ if(!is.list(evee)) evee = list()
+ if(!is.list(esigma)) esigma = list()
+ if(!is.Numeric(nsimEIM, allow=1, integ=TRUE) || nsimEIM <= 50)
+ stop("'nsimEIM' should be an integer greater than 50")
+
+ new("vglmff",
+ blurb=c("Rice distribution\n\n",
+ "Links: ",
+ namesof("vee", lvee, earg= evee, tag=FALSE), ", ",
+ namesof("sigma", lsigma, earg= esigma, tag=FALSE), "\n",
+ "Mean: ",
+ "sigma*sqrt(pi/2)*exp(z/2)*((1-z)*",
+ "besselI(-z/2,nu=0)-z*besselI(-z/2,nu=1)) where z=-vee^2/(2*sigma^2)"),
+ constraints=eval(substitute(expression({
+ constraints = cm.zero.vgam(constraints, x, .zero, M)
+ }), list( .zero=zero ))),
+ initialize=eval(substitute(expression({
+ if(ncol(y <- cbind(y)) != 1)
+ stop("the response must be a vector or one-column matrix")
+ if(any((y <= 0)))
+ stop("the response must be in (0,Inf)")
+ predictors.names = c(
+ namesof("vee", .lvee, earg= .evee, tag=FALSE),
+ namesof("sigma", .lsigma, earg= .esigma, tag=FALSE))
+ if(!length(etastart)) {
+ riceff.Loglikfun = function(vee, y, x, w, extraargs) {
+ sigma.init = sd(rep(y, w))
+ sum(w * (log(y) - 2*log(sigma.init) +
+ log(besselI(y*vee/sigma.init^2, nu=0)) -
+ (y^2 + vee^2)/(2*sigma.init^2)))
+ }
+ vee.grid = seq(quantile(rep(y,w), probs = seq(0, 1, 0.2))["20%"],
+ quantile(rep(y,w), probs = seq(0, 1, 0.2))["80%"], len=11)
+ vee.init = if(length( .ivee )) .ivee else
+ getMaxMin(vee.grid, objfun=riceff.Loglikfun, y=y, x=x, w=w)
+ vee.init = rep(vee.init, length=length(y))
+ sigma.init = if(length( .isigma )) .isigma else
+ sqrt(max((weighted.mean(y^2, w) - vee.init^2)/2, 0.001))
+ sigma.init = rep(sigma.init, length=length(y))
+ etastart = cbind(theta2eta(vee.init, .lvee, earg= .evee),
+ theta2eta(sigma.init, .lsigma, earg= .esigma))
+ }
+ }), list( .lvee=lvee, .lsigma=lsigma,
+ .ivee=ivee, .isigma=isigma,
+ .evee=evee, .esigma=esigma ))),
+ inverse=eval(substitute(function(eta, extra=NULL){
+ vee = eta2theta(eta[,1], link= .lvee, earg= .evee)
+ sigma = eta2theta(eta[,2], link= .lsigma, earg= .esigma)
+ temp9 = -vee^2 / (2*sigma^2)
+
+
+ sigma * sqrt(pi/2) * ((1-temp9) * besselI(-temp9/2,nu=0,expon=TRUE) -
+ temp9 * besselI(-temp9/2,nu=1,expon=TRUE))
+ }, list( .lvee=lvee, .lsigma=lsigma,
+ .evee=evee, .esigma=esigma ))),
+ last=eval(substitute(expression({
+ misc$link = c("vee"= .lvee, "sigma"= .lsigma)
+ misc$earg = list("vee"= .evee, "sigma"= .esigma)
+ misc$expected = TRUE
+ misc$nsimEIM = .nsimEIM
+ }), list( .lvee=lvee, .lsigma=lsigma,
+ .evee=evee, .esigma=esigma, .nsimEIM=nsimEIM ))),
+ loglikelihood=eval(substitute(
+ function(mu,y,w,residuals=FALSE,eta,extra=NULL) {
+ vee = eta2theta(eta[,1], link= .lvee, earg= .evee)
+ sigma = eta2theta(eta[,2], link= .lsigma, earg= .esigma)
+ if(residuals) stop("loglikelihood residuals not implemented yet") else
+ sum(w * (log(y) - 2*log(sigma) +
+ log(besselI(y*vee/sigma^2, nu=0)) -
+ (y^2 + vee^2)/(2*sigma^2)))
+ }, list( .lvee=lvee, .lsigma=lsigma,
+ .evee=evee, .esigma=esigma ))),
+ vfamily=c("riceff"),
+ deriv=eval(substitute(expression({
+ vee = eta2theta(eta[,1], link= .lvee, earg= .evee)
+ sigma = eta2theta(eta[,2], link= .lsigma, earg= .esigma)
+ dvee.deta = dtheta.deta(vee, link= .lvee, earg= .evee)
+ dsigma.deta = dtheta.deta(sigma, link= .lsigma, earg= .esigma)
+ temp8 = y * vee / sigma^2
+ dl.dvee = -vee/sigma^2 + (y/sigma^2) *
+ besselI(temp8, nu=1) / besselI(temp8, nu=0)
+ dl.dsigma = -2/sigma + (y^2 + vee^2)/(sigma^3) - (2 * temp8 / sigma) *
+ besselI(temp8, nu=1) / besselI(temp8, nu=0)
+ w * cbind(dl.dvee * dvee.deta,
+ dl.dsigma * dsigma.deta)
+ }), list( .lvee=lvee, .lsigma=lsigma,
+ .evee=evee, .esigma=esigma, .nsimEIM=nsimEIM ))),
+ weight = eval(substitute(expression({
+ run.var = run.cov = 0
+ for(ii in 1:( .nsimEIM )) {
+ ysim = rrice(n, vee=vee, sigma=sigma)
+ temp8 = ysim * vee / sigma^2
+ dl.dvee = -vee/sigma^2 + (ysim/sigma^2) *
+ besselI(temp8, nu=1) / besselI(temp8, nu=0)
+ dl.dsigma = -2/sigma + (ysim^2 + vee^2)/(sigma^3) -
+ (2 * temp8 / sigma) *
+ besselI(temp8, nu=1) / besselI(temp8, nu=0)
+ rm(ysim)
+ temp3 = cbind(dl.dvee, dl.dsigma)
+ run.var = ((ii-1) * run.var + temp3^2) / ii
+ run.cov = ((ii-1) * run.cov + temp3[,1] * temp3[,2]) / ii
+ }
+ wz = if(intercept.only)
+ matrix(apply(cbind(run.var, run.cov), 2, mean),
+ n, dimm(M), byrow=TRUE) else cbind(run.var, run.cov)
+
+ dtheta.detas = cbind(dvee.deta, dsigma.deta)
+ index0 = iam(NA, NA, M=M, both=TRUE, diag=TRUE)
+ wz = wz * dtheta.detas[,index0$row] * dtheta.detas[,index0$col]
+ w * wz
+ }), list( .lvee=lvee, .lsigma=lsigma,
+ .evee=evee, .esigma=esigma, .nsimEIM=nsimEIM ))))
+}
+
+
+
+
+dskellam = function(x, mu1, mu2, log=FALSE) {
+ log.arg = log
+ rm(log)
+ if( !is.logical( log.arg ) || length( log.arg )!=1 )
+ stop("bad input for 'log.arg'")
+ if( log.arg ) {
+ ans = -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))
+ } else {
+ ans = (mu1/mu2)^(x/2) * exp(-mu1-mu2 + 2 * sqrt(mu1*mu2)) *
+ besselI(2 * sqrt(mu1*mu2), nu=x, expon=TRUE)
+ }
+ ans[(x != round(x))] = 0
+ ans[!is.finite(mu1) | !is.finite(mu2) | (mu1 <= 0) | (mu2 <= 0)] = NA
+ ans
+}
+
+
+rskellam = function(n, mu1, mu2) {
+ if(!is.Numeric(n, integ=TRUE,allow=1)) stop("bad input for argument \"n\"")
+ rpois(n, mu1) - rpois(n, mu2)
+}
+
+
+
+skellam.control <- function(save.weight=TRUE, ...)
+{
+ list(save.weight=save.weight)
+}
+
+
+skellam = function(lmu1="loge", lmu2="loge",
+ emu1=list(), emu2=list(),
+ imu1=NULL, imu2=NULL,
+ nsimEIM=100, parallel=FALSE, zero=NULL)
+{
+ if(mode(lmu1) != "character" && mode(lmu1) != "name")
+ lmu1 = as.character(substitute(lmu1))
+ if(mode(lmu2) != "character" && mode(lmu2) != "name")
+ lmu2 = as.character(substitute(lmu2))
+ if(length(imu1) && !is.Numeric(imu1, positive=TRUE))
+ stop("bad input for argument \"imu1\"")
+ if(length(imu2) && !is.Numeric(imu2, positive=TRUE))
+ stop("bad input for argument \"imu2\"")
+ if(!is.list(emu1)) emu1 = list()
+ if(!is.list(emu2)) emu2 = list()
+ if(!is.Numeric(nsimEIM, allow=1, integ=TRUE) || nsimEIM <= 50)
+ stop("'nsimEIM' should be an integer greater than 50")
+
+ new("vglmff",
+ blurb=c("Skellam distribution\n\n",
+ "Links: ",
+ namesof("mu1", lmu1, earg= emu1, tag=FALSE), ", ",
+ namesof("mu2", lmu2, earg= emu2, tag=FALSE), "\n",
+ "Mean: mu1-mu2", "\n",
+ "Variance: mu1+mu2"),
+ 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(ncol(y <- cbind(y)) != 1)
+ stop("the response must be a vector or one-column matrix")
+ 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)) {
+ junk = if(is.R()) lm.wfit(x=x, y=y, w=w) else
+ lm.wfit(x=x, y=y, w=w, method="qr")
+ var.y.est = sum(w * junk$resid^2) / junk$df.residual
+ mean.init = weighted.mean(y, w)
+ mu1.init = max((var.y.est + mean.init) / 2, 0.01)
+ mu2.init = max((var.y.est - mean.init) / 2, 0.01)
+ mu1.init = rep(if(length( .imu1)) .imu1 else mu1.init, length=n)
+ mu2.init = rep(if(length( .imu2)) .imu2 else mu2.init, length=n)
+ etastart = cbind(theta2eta(mu1.init, .lmu1, earg= .emu1),
+ theta2eta(mu2.init, .lmu2, earg= .emu2))
+ }
+ }), list( .lmu1=lmu1, .lmu2=lmu2,
+ .imu1=imu1, .imu2=imu2,
+ .emu1=emu1, .emu2=emu2 ))),
+ inverse=eval(substitute(function(eta, extra=NULL){
+ mu1 = eta2theta(eta[,1], link= .lmu1, earg= .emu1)
+ mu2 = eta2theta(eta[,2], link= .lmu2, earg= .emu2)
+ mu1 - mu2
+ }, list( .lmu1=lmu1, .lmu2=lmu2,
+ .emu1=emu1, .emu2=emu2 ))),
+ last=eval(substitute(expression({
+ misc$link = c("mu1"= .lmu1, "mu2"= .lmu2)
+ misc$earg = list("mu1"= .emu1, "mu2"= .emu2)
+ misc$expected = TRUE
+ misc$nsimEIM = .nsimEIM
+ }), list( .lmu1=lmu1, .lmu2=lmu2,
+ .emu1=emu1, .emu2=emu2, .nsimEIM=nsimEIM ))),
+ loglikelihood=eval(substitute(
+ 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( is.logical( .parallel ) && length( .parallel )==1 &&
+ .parallel )
+ sum(w * log(besselI(2*mu1, nu=y, expon=TRUE))) else
+ sum(w * (-mu1 - mu2 + 2 * sqrt(mu1*mu2) +
+ 0.5 * y * log(mu1) -
+ 0.5 * y * log(mu2) +
+ log(besselI(2 * sqrt(mu1*mu2), nu=y, expon=TRUE))))
+ }
+ }, list( .lmu1=lmu1, .lmu2=lmu2,
+ .parallel=parallel,
+ .emu1=emu1, .emu2=emu2 ))),
+ vfamily=c("skellam"),
+ deriv=eval(substitute(expression({
+ mu1 = eta2theta(eta[,1], link= .lmu1, earg= .emu1)
+ mu2 = eta2theta(eta[,2], link= .lmu2, earg= .emu2)
+ dmu1.deta = dtheta.deta(mu1, link= .lmu1, earg= .emu1)
+ dmu2.deta = dtheta.deta(mu2, link= .lmu2, earg= .emu2)
+ temp8 = 2 * sqrt(mu1*mu2)
+ temp9 = besselI(temp8, nu=y, expon=TRUE)
+ temp7 = (besselI(temp8, nu=y-1, expon=TRUE) +
+ besselI(temp8, nu=y+1, expon=TRUE)) / 2
+ temp6 = temp7 / temp9
+ dl.dmu1 = -1 + 0.5 * y / mu1 + sqrt(mu2/mu1) * temp6
+ dl.dmu2 = -1 - 0.5 * y / mu2 + sqrt(mu1/mu2) * temp6
+ w * cbind(dl.dmu1 * dmu1.deta,
+ dl.dmu2 * dmu2.deta)
+ }), list( .lmu1=lmu1, .lmu2=lmu2,
+ .emu1=emu1, .emu2=emu2, .nsimEIM=nsimEIM ))),
+ weight = eval(substitute(expression({
+ run.var = run.cov = 0
+ for(ii in 1:( .nsimEIM )) {
+ ysim = rskellam(n, mu1=mu1, mu2=mu2)
+ temp9 = besselI(temp8, nu=ysim, expon=TRUE)
+ temp7 = (besselI(temp8, nu=ysim-1, expon=TRUE) +
+ besselI(temp8, nu=ysim+1, expon=TRUE)) / 2
+ temp6 = temp7 / temp9
+ dl.dmu1 = -1 + 0.5 * ysim/mu1 + sqrt(mu2/mu1) * temp6
+ dl.dmu2 = -1 - 0.5 * ysim/mu2 + sqrt(mu1/mu2) * temp6
+ rm(ysim)
+ temp3 = cbind(dl.dmu1, dl.dmu2)
+ run.var = ((ii-1) * run.var + temp3^2) / ii
+ run.cov = ((ii-1) * run.cov + temp3[,1] * temp3[,2]) / ii
+ }
+ wz = if(intercept.only)
+ matrix(apply(cbind(run.var, run.cov), 2, mean),
+ n, dimm(M), byrow=TRUE) else cbind(run.var, run.cov)
+
+ dtheta.detas = cbind(dmu1.deta, dmu2.deta)
+ index0 = iam(NA, NA, M=M, both=TRUE, diag=TRUE)
+ wz = wz * dtheta.detas[,index0$row] * dtheta.detas[,index0$col]
+ w * wz
+ }), list( .lmu1=lmu1, .lmu2=lmu2,
+ .emu1=emu1, .emu2=emu2, .nsimEIM=nsimEIM ))))
+}
+
+
+
+
+dyules = function(x, rho, log=FALSE) {
+ log.arg = log
+ rm(log)
+ if( !is.logical( log.arg ) || length( log.arg )!=1 )
+ stop("bad input for 'log.arg'")
+ if( log.arg ) {
+ ans = log(rho) + lbeta(abs(x), rho+1)
+ ans[(x != round(x)) | (x < 1)] = log(0)
+ } else {
+ ans = rho * beta(x, rho+1)
+ ans[(x != round(x)) | (x < 1)] = 0
+ }
+ ans[!is.finite(rho) | (rho <= 0) | (rho <= 0)] = NA
+ ans
+}
+
+
+ryules = function(n, rho) {
+ if(!is.Numeric(n, integ=TRUE,allow=1)) stop("bad input for argument \"n\"")
+ rgeom(n, prob=exp(-rexp(n, rate=rho))) + 1
+}
+
+
+pyules = function(q, rho) {
+ tq = trunc(q)
+ ans = 1 - tq * beta(abs(tq), rho+1)
+ ans[q<1] = 0
+ ans[(rho <= 0) | (rho <= 0)] = NA
+ ans
+}
+
+
+
+
+yulesimon.control <- function(save.weight=TRUE, ...)
+{
+ list(save.weight=save.weight)
+}
+
+
+yulesimon = function(link="loge", earg=list(), irho=NULL, nsimEIM=200)
+{
+ if(length(irho) && !is.Numeric(irho, positi=TRUE))
+ stop("argument \"irho\" must be > 0")
+ 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)
+ stop("'nsimEIM' should be an integer greater than 50")
+
+ new("vglmff",
+ blurb=c("Yule-Simon distribution f(y) = rho*beta(y,rho+1), rho>0, y=1,2,..\n\n",
+ "Link: ",
+ namesof("p", link, earg=earg), "\n\n",
+ "Mean: rho/(rho-1), provided rho>1\n",
+ "Variance: rho^2 / ((rho-1)^2 * (rho-2)), provided rho>2"),
+ initialize=eval(substitute(expression({
+ y = as.numeric(y)
+ if(any(y < 1))
+ stop("all y values must be in 1,2,3,...")
+ if(any(y != round(y )))
+ warning("y should be integer-valued")
+ 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)) {
+ wmeany = weighted.mean(y,w) + 1/8
+ rho.init = wmeany / (wmeany - 1)
+ rho.init = rep( if(length( .irho )) .irho else rho.init, len=n)
+ etastart = theta2eta(rho.init, .link, earg=.earg)
+ }
+ }), list( .link=link, .earg=earg, .irho=irho ))),
+ inverse=eval(substitute(function(eta, extra=NULL) {
+ ans = rho = eta2theta(eta, .link, earg=.earg)
+ ans[rho>1] = rho / (rho - 1)
+ ans[rho<=1] = NA
+ ans
+ }, list( .link=link, .earg=earg ))),
+ last=eval(substitute(expression({
+ misc$link = c(rho= .link)
+ misc$earg = list(rho = .earg)
+ misc$expected = TRUE
+ misc$nsimEIM = .nsimEIM
+ }), list( .link=link, .earg=earg, .nsimEIM=nsimEIM ))),
+ 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
+ sum(w * (log(rho) + lbeta(y, rho+1)))
+ }, list( .link=link, .earg=earg ))),
+ vfamily=c("yulesimon"),
+ deriv=eval(substitute(expression({
+ rho = eta2theta(eta, .link, earg=.earg)
+ dl.drho = 1/rho + digamma(1+rho) - digamma(1+rho+y)
+ drho.deta = dtheta.deta(rho, .link, earg=.earg)
+ w * dl.drho * drho.deta
+ }), list( .link=link, .earg=earg ))),
+ weight = eval(substitute(expression({
+ run.var = 0
+ for(ii in 1:( .nsimEIM )) {
+ ysim = ryules(n, rho=rho)
+ dl.drho = 1/rho + digamma(1+rho) - digamma(1+rho+ysim)
+ rm(ysim)
+ temp3 = dl.drho
+ run.var = ((ii-1) * run.var + temp3^2) / ii
+ }
+ wz = if(intercept.only)
+ matrix(apply(cbind(run.var), 2, mean),
+ n, dimm(M), byrow=TRUE) else cbind(run.var)
+
+ wz = wz * drho.deta^2
+
+
+ w * wz
+ }), list( .nsimEIM=nsimEIM ))))
+}
+
+
+
+
+
+dslash <- function(x, mu=0, sigma=1, log=FALSE,
+ smallno=.Machine$double.eps*1000){
+ log.arg = log
+ rm(log)
+ if (!is.Numeric(sigma) || any(sigma <= 0))
+ stop("'sigma' must be positive")
+ L = max(length(x), length(mu), length(sigma))
+ x = rep(x, len = L); mu = rep(mu, len = L); sigma = rep(sigma, len = L)
+ zedd = (x-mu)/sigma
+ if(log.arg)
+ ifelse(abs(zedd)<smallno, -log(2*sigma*sqrt(2*pi)),
+ log1p(-exp(-zedd^2/2)) - log(sqrt(2*pi)*sigma*zedd^2)) else
+ ifelse(abs(zedd)<smallno, 1/(2*sigma*sqrt(2*pi)),
+ -expm1(-zedd^2/2)/(sqrt(2*pi)*sigma*zedd^2))
+}
+
+pslash <- function(q, mu=0, sigma=1){
+ if (!is.Numeric(sigma) || any(sigma <= 0))
+ stop("'sigma' must be positive")
+ L = max(length(q), length(mu), length(sigma))
+ q = rep(q, len = L); mu = rep(mu, len = L); sigma = rep(sigma, len = L)
+ ans = q * NA
+ for (ii in 1:L) {
+ temp = integrate(dslash, lower = -Inf, upper = q[ii])
+ if(temp$message != "OK") {
+ warning("integrate() failed")
+ } else
+ ans[ii] = temp$value
+ }
+ ans
+}
+
+rslash <- function (n, mu=0, sigma=1){
+ if (!is.Numeric(n, posit = TRUE, integ = TRUE, allow = 1))
+ stop("bad input for argument \"n\"")
+ if (any(sigma <= 0))
+ stop("argument \"sigma\" must be positive")
+ rnorm(n=n, mean=mu, sd=sigma) / runif(n=n)
+}
+
+slash.control <- function(save.weight=TRUE, ...)
+{
+ list(save.weight=save.weight)
+}
+
+slash = function(lmu="identity", lsigma="loge", emu=list(), esigma=list(),
+ imu=NULL, isigma=NULL,
+ iprobs = c(0.1, 0.9),
+ nsimEIM=250, zero=NULL,
+ smallno = .Machine$double.eps*1000)
+{
+ if(mode(lmu) != "character" && mode(lmu) != "name")
+ lmu = as.character(substitute(lmu))
+ if(mode(lsigma) != "character" && mode(lsigma) != "name")
+ lsigma = as.character(substitute(lsigma))
+ if(length(isigma) && !is.Numeric(isigma, posit=TRUE))
+ stop("'isigma' must be > 0")
+ 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)
+ stop("'nsimEIM' should be an integer greater than 50")
+ 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)
+ stop("bad input for argument \"smallno\"")
+
+ new("vglmff",
+ blurb=c("Slash distribution\n\n",
+ "Links: ",
+ namesof("mu", lmu, earg= emu), ", ",
+ namesof("sigma", lsigma, earg= esigma, tag=FALSE), "\n",
+ paste(
+ "1-exp(-(((y-mu)/sigma)^2)/2))/(sqrt(2*pi)*sigma*((y-mu)/sigma)^2)",
+ "\ty!=mu",
+ "\n1/(2*sigma*sqrt(2*pi))",
+ "\t\t\t\t\t\t\ty=mu\n")),
+ constraints=eval(substitute(expression({
+ constraints = cm.zero.vgam(constraints, x, .zero, M)
+ }), list( .zero=zero ))),
+ initialize=eval(substitute(expression({
+ if(ncol(y <- cbind(y)) != 1)
+ stop("the response must be a vector or one-column matrix")
+ predictors.names = c(
+ namesof("mu", .lmu, earg= .emu, tag=FALSE),
+ namesof("sigma", .lsigma, earg= .esigma, tag=FALSE))
+ if(!length(etastart)) {
+
+ slash.Loglikfun = function(mu, y, x, w, extraargs) {
+ sigma = if(is.Numeric(.isigma)) .isigma else
+ max(0.01, ((quantile(rep(y,w), prob=0.75)/2)-mu)/qnorm(0.75))
+ zedd = (y-mu)/sigma
+ sum(w * ifelse(abs(zedd)<.smallno, -log(2*sigma*sqrt(2*pi)),
+ log1p(-exp(-zedd^2/2)) - log(sqrt(2*pi)*sigma*zedd^2)))
+ }
+ 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
+ getMaxMin(mu.grid, objfun=slash.Loglikfun, y=y, x=x, w=w)
+ sigma.init = if(is.Numeric(.isigma)) .isigma else
+ max(0.01, ((quantile(rep(y,w), prob=0.75)/2)-mu.init)/qnorm(0.75))
+ mu.init = rep(mu.init, length=length(y))
+ etastart = matrix(0, n, 2)
+ etastart[,1] = theta2eta(mu.init, .lmu, earg=.emu)
+ etastart[,2] = theta2eta(sigma.init, .lsigma, earg=.esigma)
+ }
+ }), list( .lmu=lmu, .lsigma=lsigma,
+ .imu=imu, .isigma=isigma,
+ .emu=emu, .esigma=esigma,
+ .iprobs=iprobs, .smallno=smallno))),
+ inverse=eval(substitute(function(eta, extra=NULL){
+ NA * eta2theta(eta[,1], link= .lmu, earg= .emu)
+ }, list( .lmu=lmu, .emu=emu ))),
+ last=eval(substitute(expression({
+ misc$link = c("mu"= .lmu, "sigma"= .lsigma)
+ misc$earg = list("mu"= .emu, "sigma"= .esigma)
+ misc$expected = TRUE
+ misc$nsimEIM = .nsimEIM
+ }), list( .lmu=lmu, .lsigma=lsigma,
+ .emu=emu, .esigma=esigma, .nsimEIM=nsimEIM ))),
+ loglikelihood=eval(substitute(
+ function(mu,y,w,residuals=FALSE,eta,extra=NULL) {
+ mu = eta2theta(eta[,1], link= .lmu, earg= .emu)
+ sigma = eta2theta(eta[,2], link= .lsigma, earg= .esigma)
+ zedd = (y-mu)/sigma
+ if(residuals) stop("loglikelihood residuals not implemented yet") else
+ sum(w * ifelse(abs(zedd)<.smallno, -log(2*sigma*sqrt(2*pi)),
+ log1p(-exp(-zedd^2/2)) - log(sqrt(2*pi)*sigma*zedd^2)))
+ }, list( .lmu=lmu, .lsigma=lsigma,
+ .emu=emu, .esigma=esigma, .smallno=smallno ))),
+ vfamily=c("slash"),
+ deriv=eval(substitute(expression({
+ mu = eta2theta(eta[,1], link= .lmu, earg= .emu)
+ sigma = eta2theta(eta[,2], link= .lsigma, earg= .esigma)
+ dmu.deta = dtheta.deta(mu, link= .lmu, earg= .emu)
+ dsigma.deta = dtheta.deta(sigma, link= .lsigma, earg= .esigma)
+ zedd = (y-mu)/sigma
+ d3 = deriv3(~ w * log(1-exp(-(((y-mu)/sigma)^2)/2))-
+ log(sqrt(2*pi)*sigma*((y-mu)/sigma)^2), c("mu", "sigma"))
+ eval.d3 = eval(d3)
+ dl.dthetas = attr(eval.d3, "gradient")
+ dl.dmu = dl.dthetas[,1]
+ dl.dsigma = dl.dthetas[,2]
+ ind0 = (abs(zedd) < .smallno)
+ dl.dmu[ind0] = 0
+ dl.dsigma[ind0] = -1/sigma[ind0]
+ ans = w * cbind(dl.dmu * dmu.deta,
+ dl.dsigma * dsigma.deta)
+ ans
+ }), list( .lmu=lmu, .lsigma=lsigma,
+ .emu=emu, .esigma=esigma, .smallno=smallno ))),
+ weight=eval(substitute(expression({
+ run.varcov = 0
+ ind1 = iam(NA, NA, M=M, both=TRUE, diag=TRUE)
+ sd3 = deriv3(~ w * log(1-exp(-(((ysim-mu)/sigma)^2)/2))-
+ log(sqrt(2*pi)*sigma*((ysim-mu)/sigma)^2),
+ c("mu", "sigma"))
+ for(ii in 1:( .nsimEIM )) {
+ ysim = rslash(n, mu=mu, sigma=sigma)
+ seval.d3 = eval(sd3)
+
+ dl.dthetas = attr(seval.d3, "gradient")
+ dl.dmu = dl.dthetas[,1]
+ dl.dsigma = dl.dthetas[,2]
+
+
+
+ temp3 = cbind(dl.dmu, dl.dsigma)
+ run.varcov = ((ii-1) * run.varcov +
+ temp3[,ind1$row.index]*temp3[,ind1$col.index]) / ii
+ }
+ wz = if(intercept.only)
+ matrix(apply(run.varcov, 2, mean, na.rm=FALSE),
+ n, ncol(run.varcov), byrow=TRUE) else run.varcov
+ dthetas.detas = cbind(dmu.deta, dsigma.deta)
+ wz = wz * dthetas.detas[,ind1$row] * dthetas.detas[,ind1$col]
+ w * wz
+ }), list( .lmu=lmu, .lsigma=lsigma,
+ .emu=emu, .esigma=esigma,
+ .nsimEIM=nsimEIM, .smallno=smallno ))))
+}
+
+
+
+
+
diff --git a/R/family.basics.q b/R/family.basics.q
index 2f07d59..3b07bec 100644
--- a/R/family.basics.q
+++ b/R/family.basics.q
@@ -1,5 +1,5 @@
# These functions are
-# Copyright (C) 1998-2007 T.W. Yee, University of Auckland. All rights reserved.
+# Copyright (C) 1998-2008 T.W. Yee, University of Auckland. All rights reserved.
@@ -193,11 +193,12 @@ cm.zero.vgam <- function(constraints, x, zero, M)
}
-process.constraints <- function(constraints, x, M, by.col=TRUE)
+process.constraints <- function(constraints, x, M, by.col=TRUE, specialCM=NULL)
{
+
asgn <- attr(x, "assign")
nasgn <- names(asgn)
@@ -246,14 +247,19 @@ process.constraints <- function(constraints, x, M, by.col=TRUE)
if(!by.col)
return(temp)
-
constraints <- temp
Blist <- vector("list", ncol(x))
- for(i in 1:length(asgn)) {
- cols <- asgn[[i]]
- cm <- constraints[[i]]
- for(j in cols)
- Blist[[j]] <- cm
+ for(ii in 1:length(asgn)) {
+ cols <- asgn[[ii]]
+ ictr = 0
+ for(jay in cols) {
+ ictr = ictr + 1
+ cm = if(is.list(specialCM) && any(nasgn[ii] == names(specialCM))) {
+ slist = specialCM[[(nasgn[ii])]]
+ slist[[ictr]]
+ } else constraints[[ii]]
+ Blist[[jay]] <- cm
+ }
}
names(Blist) <- dimnames(x)[[2]]
Blist
diff --git a/R/family.binomial.q b/R/family.binomial.q
index 48123a8..e8b1dd0 100644
--- a/R/family.binomial.q
+++ b/R/family.binomial.q
@@ -1,5 +1,5 @@
# These functions are
-# Copyright (C) 1998-2007 T.W. Yee, University of Auckland. All rights reserved.
+# Copyright (C) 1998-2008 T.W. Yee, University of Auckland. All rights reserved.
diff --git a/R/family.bivariate.q b/R/family.bivariate.q
index 059d3e4..1926ade 100644
--- a/R/family.bivariate.q
+++ b/R/family.bivariate.q
@@ -1,5 +1,5 @@
# These functions are
-# Copyright (C) 1998-2007 T.W. Yee, University of Auckland. All rights reserved.
+# Copyright (C) 1998-2008 T.W. Yee, University of Auckland. All rights reserved.
@@ -412,7 +412,7 @@ rfrank = function(n, alpha) {
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) # Want to suppress column names
+ ans = matrix(c(X,Y), nrow=n, ncol=2)
if(any(index)) {
ans[index,1] = runif(sum(index)) # Uniform density for alpha==1
ans[index,2] = runif(sum(index))
@@ -471,12 +471,22 @@ dfrank = function(x1, x2, alpha) {
-frank = function(lapar="loge", eapar=list(), iapar=2) {
+frank.control <- function(save.weight=TRUE, ...)
+{
+ list(save.weight=save.weight)
+}
+
+
+
+frank = function(lapar="loge", eapar=list(), iapar=2, nsimEIM=250) {
if(mode(lapar) != "character" && mode(lapar) != "name")
lapar = as.character(substitute(lapar))
if(!is.Numeric(iapar, positive = TRUE))
stop("\"iapar\" must be positive")
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")
new("vglmff",
blurb=c("Frank's Bivariate Distribution\n",
@@ -488,6 +498,8 @@ frank = function(lapar="loge", eapar=list(), iapar=2) {
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)))
+ extra$dimnamesy2 = dimnames(y)[[2]]
if(!length(etastart)) {
apar.init = rep(.iapar, len=n)
etastart = cbind(theta2eta(apar.init, .lapar, earg= .eapar ))
@@ -495,13 +507,18 @@ frank = function(lapar="loge", eapar=list(), iapar=2) {
}), list( .lapar=lapar, .eapar=eapar, .iapar=iapar))),
inverse=eval(substitute(function(eta, extra=NULL) {
apar = eta2theta(eta, .lapar, earg= .eapar )
- cbind(rep(0.5, len=length(eta)), rep(0.5, len=length(eta)))
+ fv.matrix = matrix(0.5, length(apar), 2)
+ if(length(extra$dimnamesy2))
+ dimnames(fv.matrix) = list(names(eta), extra$dimnamesy2)
+ fv.matrix
}, list(.lapar=lapar, .eapar=eapar ))),
last=eval(substitute(expression({
misc$link = c("apar"= .lapar)
misc$earg = list("apar"= .eapar )
+ misc$expected = TRUE
+ misc$nsimEIM = .nsimEIM
misc$pooled.weight = pooled.weight
- }), list(.lapar=lapar, .eapar=eapar ))),
+ }), list(.lapar=lapar, .eapar=eapar, .nsimEIM=nsimEIM ))),
loglikelihood= eval(substitute(
function(mu, y, w, residuals = FALSE, eta, extra=NULL) {
apar = eta2theta(eta, .lapar, earg= .eapar )
@@ -515,17 +532,42 @@ frank = function(lapar="loge", eapar=list(), iapar=2) {
vfamily=c("frank"),
deriv=eval(substitute(expression({
apar = eta2theta(eta, .lapar, earg= .eapar )
+ dapar.deta = dtheta.deta(apar, .lapar, earg= .eapar )
+
+ de3 = deriv3(~ (log((apar-1) * log(apar)) + (y1+y2)*log(apar) -
+ 2 * log(apar-1 + (apar^y1 -1) * (apar^y2 -1))),
+ name="apar", hessian= TRUE)
+
denom = apar-1 + (apar^y[,1] -1) * (apar^y[,2] -1)
tmp700 = 2*apar^(y[,1]+y[,2]) - apar^y[,1] - apar^y[,2]
numerator = 1 + y[,1] * apar^(y[,1]-1) * (apar^y[,2] -1) +
y[,2] * apar^(y[,2]-1) * (apar^y[,1] -1)
Dl.dapar = 1/(apar-1) + 1/(apar*log(apar)) + (y[,1]+y[,2])/apar -
2 * numerator / denom
- dapar.deta = dtheta.deta(apar, .lapar, earg= .eapar )
-
w * Dl.dapar * dapar.deta
- }), list(.lapar=lapar, .eapar=eapar ))),
+ }), list(.lapar=lapar, .eapar=eapar, .nsimEIM=nsimEIM ))),
weight=eval(substitute(expression({
+ if( is.Numeric( .nsimEIM)) {
+
+ pooled.weight = FALSE # For @last
+
+
+ run.mean = 0
+ for(ii in 1:( .nsimEIM )) {
+ ysim = rfrank(n,alpha=apar)
+ y1 = ysim[,1]; y2 = ysim[,2];
+ eval.de3 = eval(de3)
+ d2l.dthetas2 = attr(eval.de3, "hessian")
+ rm(ysim)
+ temp3 = -d2l.dthetas2[,1,1] # M=1
+ run.mean = ((ii-1) * run.mean + temp3) / ii
+ }
+ wz = if(intercept.only)
+ matrix(mean(run.mean), n, dimm(M)) else run.mean
+
+ wz = wz * dapar.deta^2
+ w * wz
+ } else {
nump = apar^(y[,1]+y[,2]-2) * (2 * y[,1] * y[,2] +
y[,1]*(y[,1]-1) + y[,2]*(y[,2]-1)) -
y[,1]*(y[,1]-1) * apar^(y[,1]-2) -
@@ -535,7 +577,6 @@ frank = function(lapar="loge", eapar=list(), iapar=2) {
(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) {
wz = cbind(wz)
sumw = sum(w)
@@ -545,9 +586,9 @@ frank = function(lapar="loge", eapar=list(), iapar=2) {
wz = w * wz # Put back the weights
} else
pooled.weight = FALSE
-
wz
- }), list( .lapar=lapar, .eapar=eapar ))))
+ }
+ }), list( .lapar=lapar, .eapar=eapar, .nsimEIM=nsimEIM ))))
}
@@ -638,13 +679,15 @@ morgenstern = function(lapar="rhobit", earg=list(), iapar=NULL, tola0=0.01,
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)))
+ 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])
Finit = 0.01 + mean(y[,1] <= mean1 & y[,2] <= mean2)
- ((Finit-1+exp(-mean1)+exp(-mean2)) / exp(-mean1-mean2) -
- 1) / ((1-exp(-mean1)) * (1-exp(-mean2)))
+ ((Finit+expm1(-mean1)+exp(-mean2)) / exp(-mean1-mean2)-1)/(
+ expm1(-mean1) * expm1(-mean2))
}
etastart = theta2eta(rep(ainit, len=n), .lapar, earg= .earg )
}
@@ -652,8 +695,10 @@ morgenstern = function(lapar="rhobit", earg=list(), iapar=NULL, tola0=0.01,
.method.init=method.init ))),
inverse=eval(substitute(function(eta, extra=NULL) {
alpha = eta2theta(eta, .lapar, earg= .earg )
- cbind(rep(1, len=length(alpha)),
- rep(1, len=length(alpha)))
+ fv.matrix = matrix(1, length(alpha), 2)
+ if(length(extra$dimnamesy2))
+ dimnames(fv.matrix) = list(names(eta), extra$dimnamesy2)
+ fv.matrix
}, list( .lapar=lapar, .earg=earg ))),
last=eval(substitute(expression({
misc$link = c("apar"= .lapar)
@@ -703,32 +748,97 @@ morgenstern = function(lapar="rhobit", earg=list(), iapar=NULL, tola0=0.01,
-dfgm = function(x1, x2, alpha) {
+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(alpha < -1 | alpha > 1)) stop("\"alpha\" values out of range")
+ if(any(abs(alpha) > 1)) stop("\"alpha\" values out of range")
+
+ y1 = V1 = runif(n)
+ V2 = runif(n)
+ temp = 2*y1 - 1
+ A = alpha * temp - 1
+ B = sqrt(1 - 2 * alpha * temp + (alpha*temp)^2 + 4 * alpha * V2 * temp)
+ y2 = 2 * V2 / (B - A)
+ matrix(c(y1,y2), nrow=n, ncol=2)
+}
+
+
+
+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 )
+ 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)
- ans = 1 + alpha * (1-2*x1) * (1-2*x2)
- ans[(x1 <= 0) | (x1 >= 1) | (x2 <= 0) | (x2 >= 1)] = 0
- if(any(ans<0))
- stop("negative values in the density (alpha out of range)") else
+ ans = 0 * x1
+ xnok = (x1 <= 0) | (x1 >= 1) | (x2 <= 0) | (x2 >= 1)
+ 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))
+ stop("negative values in the density (alpha out of range)")
+ }
+ ans
+}
+
+
+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")
+
+ 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)
+
+ 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)) {
+ ans[!index] = q1[!index] * q2[!index] * (1 + alpha[!index] *
+ (1-q1[!index])*(1-q2[!index]))
+ }
+ ans[x>=1 & y<1] = y[x>=1 & y<1] # P(Y2 < q2) = q2
+ ans[y>=1 & x<1] = x[y>=1 & x<1] # P(Y1 < q1) = q1
+ ans[x<=0 | y<=0] = 0
+ ans[x>=1 & y>=1] = 1
ans
}
-fgm = function(lapar="identity", earg=list(), iapar=NULL,
- method.init=1) { # , tola0=0.01
+fgm.control <- function(save.weight=TRUE, ...)
+{
+ list(save.weight=save.weight)
+}
+
+
+
+fgm = function(lapar="rhobit", earg=list(), iapar=NULL,
+ method.init=1, nsimEIM=200) {
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))
- stop("'iapar' must be a single number")
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) ||
+ (!is.Numeric(nsimEIM, allow=1, integ=TRUE) || nsimEIM <= 50))
+ stop("'nsimEIM' should be an integer greater than 50")
+ if(length(iapar) &&
+ (abs(iapar) >= 1))
+ stop("'iapar' should be less than 1 in absolute value")
new("vglmff",
blurb=c("Farlie-Gumbel-Morgenstern Distribution\n",
@@ -740,46 +850,57 @@ fgm = function(lapar="identity", earg=list(), iapar=NULL,
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)))
+ 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])
- Finit = 0.01 + mean(y[,1] <= mean1 & y[,2] <= mean2)
+ 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
+ median(y[,2])
+ Finit = weighted.mean(y[,1] <= mean1 & y[,2] <= mean2, w)
(Finit / (mean1 * mean2) - 1) / ((1-mean1) * (1-mean2))
- }
+ }
+
+ ainit = min(0.95, max(ainit, -0.95))
+
etastart = theta2eta(rep(ainit, len=n), .lapar, earg= .earg )
}
}), list( .iapar=iapar, .lapar=lapar, .earg=earg,
.method.init=method.init ))),
inverse=eval(substitute(function(eta, extra=NULL) {
alpha = eta2theta(eta, .lapar, earg= .earg )
- cbind(rep(0.5, len=length(alpha)),
- rep(0.5, len=length(alpha)))
+ fv.matrix = matrix(0.5, length(alpha), 2)
+ if(length(extra$dimnamesy2))
+ dimnames(fv.matrix) = list(names(eta), extra$dimnamesy2)
+ fv.matrix
}, list( .lapar=lapar, .earg=earg ))),
last=eval(substitute(expression({
misc$link = c("apar"= .lapar)
misc$earg = list(apar = .earg)
misc$expected = FALSE
- misc$pooled.weight = pooled.weight
- }), list( .lapar=lapar, .earg=earg ))),
+ misc$nsimEIM = .nsimEIM
+ }), list(.lapar=lapar, .earg=earg, .nsimEIM=nsimEIM ))),
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 {
- denom = 1 + alpha * (1 - 2 * y[,1]) * (1 - 2 * y[,2])
- mytolerance = .Machine$double.eps
+ denm1 = alpha * (1 - 2 * y[,1]) * (1 - 2 * y[,2])
+ denom = 1 + denm1
+ mytolerance = 0.0 # .Machine$double.eps
bad <- (denom <= mytolerance) # Range violation
if(any(bad)) {
cat("There are some range violations in @loglikelihood\n")
if(exists("flush.console")) flush.console()
}
- sum(bad) * (-1.0e10) +
- sum(w[!bad] * log(denom[!bad]))
+ sum(w[bad]) * (-1.0e10) +
+ sum(w[!bad] * log1p(denm1[!bad]))
}
}, list( .lapar=lapar, .earg=earg ))),
vfamily=c("fgm"),
deriv=eval(substitute(expression({
alpha = eta2theta(eta, .lapar, earg= .earg )
+ dalpha.deta = dtheta.deta(alpha, .lapar, earg= .earg )
numerator = (1 - 2 * y[,1]) * (1 - 2 * y[,2])
denom = 1 + alpha * numerator
mytolerance = .Machine$double.eps
@@ -790,25 +911,26 @@ fgm = function(lapar="identity", earg=list(), iapar=NULL,
denom[bad] = 2 * mytolerance
}
dl.dalpha = numerator / denom
- dalpha.deta = dtheta.deta(alpha, .lapar, earg= .earg )
w * cbind(dl.dalpha * dalpha.deta)
- }), list( .lapar=lapar, .earg=earg ))),
+ }), list( .lapar=lapar, .earg=earg, .nsimEIM=nsimEIM ))),
weight=eval(substitute(expression({
- 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 &&
- intercept.only) {
- wz = cbind(wz)
- sumw = sum(w)
- for(iii in 1:ncol(wz))
- wz[,iii] = sum(wz[,iii]) / sumw
- pooled.weight = TRUE
- wz = w * wz # Put back the weights
- } else
- pooled.weight = FALSE
- wz
- }), list( .lapar=lapar, .earg=earg ))))
+ run.var = 0
+ for(ii in 1:( .nsimEIM )) {
+ ysim = rfgm(n, alpha=alpha)
+ numerator = (1 - 2 * ysim[,1]) * (1 - 2 * ysim[,2])
+ denom = 1 + alpha * numerator
+ dl.dalpha = numerator / denom
+ rm(ysim)
+ temp3 = dl.dalpha
+ run.var = ((ii-1) * run.var + temp3^2) / ii
+ }
+ wz = if(intercept.only)
+ matrix(apply(cbind(run.var), 2, mean),
+ n, dimm(M), byrow=TRUE) else cbind(run.var)
+
+ wz = wz * dalpha.deta^2
+ w * wz
+ }), list( .lapar=lapar, .earg=earg, .nsimEIM=nsimEIM ))))
}
@@ -838,7 +960,7 @@ gumbelIbiv = function(lapar="identity", earg=list(), iapar=NULL, method.init=1)
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-1+exp(-mean1)+exp(-mean2))+mean1+mean2)/(mean1*mean2)
+ (log(Finit+expm1(-mean1)+exp(-mean2))+mean1+mean2)/(mean1*mean2)
}
etastart = theta2eta(rep(ainit, len=n), .lapar, earg= .earg )
}
@@ -901,3 +1023,366 @@ gumbelIbiv = function(lapar="identity", earg=list(), iapar=NULL, method.init=1)
+
+
+
+
+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\"")
+
+ 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)
+
+ 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)) {
+ temp1 = 1 + (oratio[!index] -1) * (q1[!index] + q2[!index])
+ temp2 = temp1 - sqrt(temp1^2 - 4 * oratio[!index] *
+ (oratio[!index]-1) * q1[!index] * q2[!index])
+ ans[!index] = 0.5 * temp2 / (oratio[!index] - 1)
+ }
+
+ ind2 = (abs(oratio-1) < 1.0e-6) # .Machine$double.eps
+ ans[ind2] = x[ind2] * y[ind2]
+ ans[x>=1 & y<1] = y[x>=1 & y<1] # P(Y2 < q2) = q2
+ ans[y>=1 & x<1] = x[y>=1 & x<1] # P(Y1 < q1) = q1
+ ans[x<=0 | y<=0] = 0
+ ans[x>=1 & y>=1] = 1
+ ans
+}
+
+
+
+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)
+
+ y1 = U = runif(n)
+ V = runif(n)
+ Z = V * (1-V)
+ y2 = (2*Z*(y1*oratio^2 + 1 - y1) + oratio * (1 - 2 * Z) -
+ (1 - 2 * V) *
+ sqrt(oratio * (oratio + 4*Z*y1*(1-y1)*(1-oratio)^2))) / (oratio +
+ Z*(1-oratio)^2)
+ matrix(c(y1, 0.5 * y2), nrow=n, ncol=2)
+}
+
+
+
+dplack = function(x1, x2, oratio, log=FALSE) {
+ log.arg = log
+ rm(log)
+ 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 )
+ stop("bad input for 'log'")
+
+ 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)
+ ans[(x1 < 0) | (x1 > 1) | (x2 < 0) | (x2 > 1)] = log(0)
+ } else {
+ ans = oratio * ((oratio -1) * (x1+x2-2*x1*x2) + 1) / ((1 +
+ (x1+x2)*(oratio-1))^2 - 4 * oratio * (oratio-1)*x1*x2)^1.5
+ ans[(x1 < 0) | (x1 > 1) | (x2 < 0) | (x2 > 1)] = 0
+ }
+ ans
+}
+
+
+
+plackett.control <- function(save.weight=TRUE, ...)
+{
+ list(save.weight=save.weight)
+}
+
+
+
+plackett = function(link="loge", earg=list(),
+ ioratio=NULL, method.init=1, nsimEIM=200) {
+ 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)))
+ stop("'ioratio' must be positive")
+ 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("Plackett Distribution\n",
+ "Links: ",
+ namesof("oratio", link, earg= earg )),
+ initialize=eval(substitute(expression({
+ if(!is.matrix(y) || ncol(y) != 2)
+ stop("the response must be a 2 column matrix")
+ 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)))
+ extra$dimnamesy2 = dimnames(y)[[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)
+ } else {
+ y10 = weighted.mean(y[,1], w)
+ y20 = weighted.mean(y[,2], w)
+ (0.5 + sum(w[(y[,1] < y10) & (y[,2] < y20)])) *
+ (0.5 + sum(w[(y[,1] >= y10) & (y[,2] >= y20)])) / (
+ ((0.5 + sum(w[(y[,1] < y10) & (y[,2] >= y20)])) *
+ (0.5 + sum(w[(y[,1] >= y10) & (y[,2] < y20)]))))
+ }
+ }
+ etastart = theta2eta(rep(orinit, len=n), .link, earg= .earg)
+ }
+ }), list( .ioratio=ioratio, .link=link, .earg=earg,
+ .method.init=method.init ))),
+ 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))
+ dimnames(fv.matrix) = list(dimnames(eta)[[1]], extra$dimnamesy2)
+ fv.matrix
+ }, list( .link=link, .earg=earg ))),
+ last=eval(substitute(expression({
+ misc$link = c("oratio"= .link)
+ misc$earg = list(oratio = .earg)
+ misc$expected = FALSE
+ misc$nsimEIM = .nsimEIM
+ }), list( .link=link, .earg=earg,
+ .nsimEIM=nsimEIM ))),
+ 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 {
+ y1 = y[,1]
+ y2 = y[,2]
+ sum(w * (log(oratio) + log1p((oratio-1) * (y1+y2-2*y1*y2)) - 1.5 *
+ log((1 + (y1+y2)*(oratio-1))^2 - 4*oratio*(oratio-1)*y1*y2)))
+ }
+ }, list( .link=link, .earg=earg ))),
+ vfamily=c("plackett"),
+ deriv=eval(substitute(expression({
+ oratio = eta2theta(eta, .link, earg= .earg )
+ doratio.deta = dtheta.deta(oratio, .link, earg= .earg )
+ y1 = y[,1]
+ y2 = y[,2]
+ de3 = deriv3(~ (log(oratio) + log(1+(oratio-1) *
+ (y1+y2-2*y1*y2)) - 1.5 *
+ log((1 + (y1+y2)*(oratio-1))^2 - 4 * oratio * (oratio-1)*y1*y2)),
+ name="oratio", hessian= FALSE)
+ eval.de3 = eval(de3)
+ dl.doratio = attr(eval.de3, "gradient")
+ w * dl.doratio * doratio.deta
+ }), list( .link=link, .earg=earg ))),
+ weight=eval(substitute(expression({
+ sd3 = deriv3(~ (log(oratio) + log(1+(oratio-1) *
+ (y1sim+y2sim-2*y1sim*y2sim)) - 1.5 *
+ log((1 + (y1sim+y2sim)*(oratio-1))^2 -
+ 4 * oratio * (oratio-1)*y1sim*y2sim)),
+ name="oratio", hessian= FALSE)
+ run.var = 0
+ for(ii in 1:( .nsimEIM )) {
+ ysim = rplack(n, oratio=oratio)
+ y1sim = ysim[,1]
+ y2sim = ysim[,1]
+ eval.sd3 = eval(sd3)
+ dl.doratio = attr(eval.sd3, "gradient")
+ rm(ysim, y1sim, y2sim)
+ temp3 = dl.doratio
+ run.var = ((ii-1) * run.var + temp3^2) / ii
+ }
+ wz = if(intercept.only)
+ matrix(apply(cbind(run.var), 2, mean),
+ n, dimm(M), byrow=TRUE) else cbind(run.var)
+
+ wz = wz * doratio.deta^2
+ w * wz
+ }), list( .link=link, .earg=earg, .nsimEIM=nsimEIM ))))
+}
+
+
+
+
+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")
+ 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) {
+ ans = log1p(-alpha+2*alpha*x1*x2/temp) - 2*log(temp)
+ ans[(x1 <= 0) | (x1 >= 1) | (x2 <= 0) | (x2 >= 1)] = log(0)
+ } else {
+ ans = (1-alpha+2*alpha*x1*x2/temp) / (temp^2)
+ ans[(x1 <= 0) | (x1 >= 1) | (x2 <= 0) | (x2 >= 1)] = 0
+ }
+ ans
+}
+
+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")
+
+ 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)
+
+ 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)) {
+ ans[!index] = (q1[!index]*q2[!index]) / (1 -
+ alpha[!index]*(1-q1[!index])*(1-q2[!index]))
+ }
+ ans[x>=1 & y<1] = y[x>=1 & y<1] # P(Y2 < q2) = q2
+ ans[y>=1 & x<1] = x[y>=1 & x<1] # P(Y1 < q1) = q1
+ ans[x<=0 | y<=0] = 0
+ ans[x>=1 & y>=1] = 1
+ ans
+}
+
+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")
+
+ U1 = V1 = runif(n)
+ V2 = runif(n)
+ b = 1-V1
+ A = -alpha*(2*b*V2+1)+2*alpha^2*b^2*V2+1
+ B = alpha^2*(4*b^2*V2-4*b*V2+1)+alpha*(4*V2-4*b*V2-2)+1
+ U2 = (2*V2*(alpha*b-1)^2)/(A+sqrt(B))
+ matrix(c(U1,U2), nrow=n, ncol=2)
+}
+
+amh.control <- function(save.weight=TRUE, ...)
+{
+ list(save.weight=save.weight)
+}
+
+amh = function(lalpha="rhobit", ealpha=list(), ialpha=NULL,
+ method.init=1, nsimEIM=250)
+{
+ if(mode(lalpha) != "character" && mode(lalpha) != "name")
+ lalpha = as.character(substitute(lalpha))
+ 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) ||
+ method.init > 2) stop("method.init must be 1 or 2")
+ if(length(nsimEIM) &&
+ (!is.Numeric(nsimEIM, allow=1, integ=TRUE) || nsimEIM <= 50))
+ stop("'nsimEIM' should be an integer greater than 50")
+
+ new("vglmff",
+ blurb=c("Ali-Mikhail-Haq Distribution\n",
+ "Links: ",
+ namesof("alpha", lalpha, earg= ealpha )),
+ initialize=eval(substitute(expression({
+ if(!is.matrix(y) || ncol(y) != 2)
+ stop("the response must be a 2 column matrix")
+ 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)))
+ 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
+ median(y[,1])
+ 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))
+ }
+ ainit = min(0.95, max(ainit, -0.95))
+ etastart = theta2eta(rep(ainit, len=n), .lalpha, earg= .ealpha )
+ }
+ }), list( .lalpha=lalpha, .ealpha=ealpha, .ialpha=ialpha,
+ .method.init=method.init))),
+ 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))
+ dimnames(fv.matrix) = list(names(eta), extra$dimnamesy2)
+ fv.matrix
+ }, list(.lalpha=lalpha, .ealpha=ealpha ))),
+ last=eval(substitute(expression({
+ misc$link = c("alpha"= .lalpha)
+ misc$earg = list("alpha"= .ealpha )
+ misc$expected = TRUE
+ misc$nsimEIM = .nsimEIM
+ }), list(.lalpha=lalpha, .ealpha=ealpha, .nsimEIM=nsimEIM ))),
+ 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 {
+ denom = 1 - alpha*(1-y[,1])*(1-y[,2])
+ sum(w * (log1p(-alpha+2*alpha*y[,1]*y[,2]/denom) - 2*log(denom)))
+ }
+ }, list( .lalpha=lalpha, .earg=ealpha ))),
+ vfamily=c("amh"),
+ deriv=eval(substitute(expression({
+ alpha = eta2theta(eta, .lalpha, earg= .ealpha )
+ dalpha.deta = dtheta.deta(alpha, .lalpha, earg= .ealpha )
+ y1 = y[,1]
+ y2 = y[,2]
+ de3 = deriv3(~ (log(1-alpha+(2*alpha*y1*y2/(1-alpha*(1-y1)*(1-y2))))-
+ 2*log(1-alpha*(1-y1)*(1-y2))) ,
+ name="alpha", hessian= FALSE)
+ eval.de3 = eval(de3)
+ dl.dalpha = attr(eval.de3, "gradient")
+ w * dl.dalpha * dalpha.deta
+ }), list(.lalpha=lalpha, .ealpha=ealpha ))),
+ weight=eval(substitute(expression({
+ sd3 = deriv3(~ (log(1-alpha+
+ (2*alpha*y1sim*y2sim/(1-alpha*(1-y1sim)*(1-y2sim))))-
+ 2*log(1-alpha*(1-y1sim)*(1-y2sim))) ,
+ name="alpha", hessian= FALSE)
+ run.var = 0
+ for(ii in 1:( .nsimEIM )) {
+ ysim = ramh(n, alpha=alpha)
+ y1sim = ysim[,1]
+ y2sim = ysim[,1]
+ eval.sd3 = eval(sd3)
+ dl.alpha = attr(eval.sd3, "gradient")
+ rm(ysim, y1sim, y2sim)
+ temp3 = dl.dalpha
+ run.var = ((ii-1) * run.var + temp3^2) / ii
+ }
+ wz = if(intercept.only)
+ matrix(apply(cbind(run.var), 2, mean),
+ n, dimm(M), byrow=TRUE) else cbind(run.var)
+ wz = wz * dalpha.deta^2
+ w * wz
+ }), list( .lalpha=lalpha, .ealpha=ealpha, .nsimEIM=nsimEIM ))))
+}
+
+
+
diff --git a/R/family.categorical.q b/R/family.categorical.q
index 92dd701..53c048c 100644
--- a/R/family.categorical.q
+++ b/R/family.categorical.q
@@ -1,5 +1,5 @@
# These functions are
-# Copyright (C) 1998-2007 T.W. Yee, University of Auckland. All rights reserved.
+# Copyright (C) 1998-2008 T.W. Yee, University of Auckland. All rights reserved.
@@ -127,12 +127,15 @@ sratio = function(link="logit", earg=list(),
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 = 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)))
+ extra$dimnamesy2 = dimnames(y)[[2]]
}), list( .earg=earg, .link=link, .reverse=reverse ))),
inverse=eval(substitute( function(eta, extra=NULL) {
if(!is.matrix(eta))
eta = as.matrix(eta)
+ fv.matrix =
if( .reverse ) {
M = ncol(eta)
djr = eta2theta(eta, .link, earg= .earg )
@@ -143,6 +146,9 @@ sratio = function(link="logit", earg=list(),
temp = tapplymat1(1-dj, "cumprod")
cbind(dj,1) * cbind(1, temp)
}
+ if(length(extra$dimnamesy2))
+ dimnames(fv.matrix) = list(dimnames(eta)[[1]], extra$dimnamesy2)
+ fv.matrix
}, list( .earg=earg, .link=link, .reverse=reverse) )),
last=eval(substitute(expression({
misc$link = rep( .link, length=M)
@@ -172,18 +178,18 @@ sratio = function(link="logit", earg=list(),
sum(w * y * log(mu)),
vfamily=c("sratio", "vcategorical"),
deriv=eval(substitute(expression({
- if(!length(extra)) {
- extra = 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 ) {
djr = eta2theta(eta, .link, earg= .earg )
- Mp1 = ncol(extra)
- w * (y[,-1]/djr - extra[,-Mp1]/(1-djr)) *
+ Mp1 = ncol(extra$mymat)
+ w * (y[,-1]/djr - extra$mymat[,-Mp1]/(1-djr)) *
dtheta.deta(djr, .link, earg= .earg )
} else {
dj = eta2theta(eta, .link, earg= .earg )
- w * (y[,-ncol(y)]/dj - extra[,-1]/(1-dj)) *
+ w * (y[,-ncol(y)]/dj - extra$mymat[,-1]/(1-dj)) *
dtheta.deta(dj, .link, earg= .earg )
}
}), list( .earg=earg, .link=link, .reverse=reverse) )),
@@ -233,12 +239,15 @@ cratio = function(link="logit", earg=list(),
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 = 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)))
+ extra$dimnamesy2 = dimnames(y)[[2]]
}), list( .earg=earg, .link=link, .reverse=reverse ))),
inverse=eval(substitute( function(eta, extra=NULL) {
if(!is.matrix(eta))
eta = as.matrix(eta)
+ fv.matrix =
if( .reverse ) {
M = ncol(eta)
djrs = eta2theta(eta, .link, earg= .earg )
@@ -249,6 +258,9 @@ cratio = function(link="logit", earg=list(),
temp = tapplymat1(djs, "cumprod")
cbind(1-djs,1) * cbind(1, temp)
}
+ if(length(extra$dimnamesy2))
+ dimnames(fv.matrix) = list(dimnames(eta)[[1]], extra$dimnamesy2)
+ fv.matrix
}, list( .earg=earg, .link=link, .reverse=reverse) )),
last=eval(substitute(expression({
misc$link = rep( .link, length=M)
@@ -276,18 +288,18 @@ cratio = function(link="logit", earg=list(),
sum(w * y * log(mu)),
vfamily=c("cratio", "vcategorical"),
deriv=eval(substitute(expression({
- if(!length(extra)) {
- extra = 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 ) {
djrs = eta2theta(eta, .link, earg= .earg )
- Mp1 = ncol(extra)
- -w * (y[,-1]/(1-djrs) - extra[,-Mp1]/djrs) *
+ Mp1 = ncol(extra$mymat)
+ -w * (y[,-1]/(1-djrs) - extra$mymat[,-Mp1]/djrs) *
dtheta.deta(djrs, .link, earg= .earg )
} else {
djs = eta2theta(eta, .link, earg= .earg )
- -w * (y[,-ncol(y)]/(1-djs) - extra[,-1]/djs) *
+ -w * (y[,-ncol(y)]/(1-djs) - extra$mymat[,-1]/djs) *
dtheta.deta(djs, .link, earg= .earg )
}
}), list( .earg=earg, .link=link, .reverse=reverse) )),
@@ -510,13 +522,16 @@ cumulative = function(link="logit", earg = list(),
extra$NOS = NOS
extra$Llevels = Llevels
} else {
- delete.zero.colns = TRUE # Cannot have F since then prob(Y=jay)=0
+ delete.zero.colns=TRUE # Cannot have FALSE since then prob(Y=jay)=0
eval(process.categorical.data.vgam)
M = ncol(y)-1
mynames = if( .reverse ) 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(length(dimnames(y)))
+ extra$dimnamesy2 = dimnames(y)[[2]]
}
}), list( .link=link, .reverse=reverse, .mv = mv, .earg = earg ))),
inverse=eval(substitute( function(eta, extra=NULL) {
@@ -542,6 +557,7 @@ cumulative = function(link="logit", earg = list(),
}
fv.matrix
} else {
+ fv.matrix =
if( .reverse ) {
ccump = cbind(1, eta2theta(eta, .link, earg= .earg))
cbind(-tapplymat1(ccump, "diff"), ccump[,ncol(ccump)])
@@ -549,6 +565,9 @@ cumulative = function(link="logit", earg = list(),
cump = cbind(eta2theta(eta, .link, earg= .earg), 1)
cbind(cump[,1], tapplymat1(cump, "diff"))
}
+ if(length(extra$dimnamesy2))
+ dimnames(fv.matrix) = list(dimnames(eta)[[1]], extra$dimnamesy2)
+ fv.matrix
}
answer
}, list( .link=link, .reverse=reverse, .earg= earg, .mv = mv ))),
@@ -618,7 +637,7 @@ cumulative = function(link="logit", earg = list(),
cump = eta2theta(eta, .link, earg= .earg)
dcump.deta = dtheta.deta(cump, .link, earg= .earg)
(if( .reverse) -w else w) * dcump.deta *
- (y[,1:M]/mu.use[,1:M] - y[,-1]/mu.use[,-1])
+ (y[,-(M+1)]/mu.use[,-(M+1)] - y[,-1]/mu.use[,-1])
}
deriv.answer
}), list( .link=link, .reverse=reverse, .earg= earg, .mv=mv ))),
@@ -655,9 +674,9 @@ cumulative = function(link="logit", earg = list(),
}
} else {
- wz = w * dcump.deta[,1:M]^2 * (1/mu.use[,1:M] + 1/mu.use[,-1])
+ wz = w * dcump.deta^2 * (1/mu.use[,1:M] + 1/mu.use[,-1])
if(M > 1)
- wz = cbind(wz, -w * dcump.deta[,1:(M-1)] *
+ wz = cbind(wz, -w * dcump.deta[,-M] *
dcump.deta[,2:M] / mu.use[,2:M])
}
wz
@@ -695,11 +714,14 @@ acat = function(link="loge", earg = list(),
paste("P[Y=",2:(M+1),"]/P[Y=",1:M,"]", sep="")
predictors.names = namesof(mynames, .link, short=TRUE, earg= .earg)
y.names = paste("mu", 1:(M+1), sep="")
+ if(length(dimnames(y)))
+ extra$dimnamesy2 = dimnames(y)[[2]]
}), list( .earg=earg, .link=link, .reverse=reverse ))),
inverse=eval(substitute( function(eta, extra=NULL) {
if(!is.matrix(eta))
eta = as.matrix(eta)
M = ncol(eta)
+ fv.matrix =
if( .reverse ) {
zetar = eta2theta(eta, .link, earg= .earg )
temp = tapplymat1(zetar[,M:1], "cumprod")[,M:1,drop=FALSE]
@@ -709,6 +731,9 @@ acat = function(link="loge", earg = list(),
temp = tapplymat1(zeta, "cumprod")
cbind(1,temp) / drop(1 + temp %*% rep(1,ncol(temp)))
}
+ if(length(extra$dimnamesy2))
+ dimnames(fv.matrix) = list(dimnames(eta)[[1]], extra$dimnamesy2)
+ fv.matrix
}, list( .earg=earg, .link=link, .reverse=reverse) )),
last=eval(substitute(expression({
misc$link = rep( .link, length=M)
@@ -819,7 +844,7 @@ brat = function(refgp="last",
etastart = matrix(theta2eta(init.alpha, "loge", earg=list()), n, M, byrow=TRUE)
refgp = .refgp
if(!intercept.only)
- warning("this function only works with intercept only models")
+ 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 ) ]
@@ -936,7 +961,7 @@ bratt = function(refgp="last",
theta2eta( rep(ialpha0, len=n), "loge"))
refgp = .refgp
if(!intercept.only)
- warning("this function only works with intercept only models")
+ 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
@@ -1371,3 +1396,203 @@ ordpoissonProbs = function(extra, mu, deriv=0) {
+
+
+
+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")
+ link = as.character(substitute(link))
+ 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))
+ stop("bad input for argument \"iscale\"")
+
+
+ new("vglmff",
+ blurb=c(paste("Scaled cumulative", link, "model\n\n"),
+ "Links: ",
+ namesof(if(reverse) "P[Y>=j+1]" else "P[Y<=j]", link, earg=earg),
+ ", ",
+ namesof("scale_j", lscale, escale)),
+ constraints=eval(substitute(expression({
+ J = M / 2
+ constraints = cm.vgam(matrix(1,J,1), x, .parallel, constraints,
+ intercept.apply = FALSE)
+ constraints[["(Intercept)"]] = rbind(constraints[["(Intercept)"]],
+ matrix(0, J, ncol(constraints[["(Intercept)"]])))
+
+ cm2 = cm.vgam(matrix(1,J,1), x, .sparallel, constraints=NULL,
+ intercept.apply = FALSE)
+
+ for(ii in 2:length(constraints))
+ constraints[[ii]] =
+ cbind(rbind(constraints[[ii]],
+ matrix(0, J, ncol(constraints[[ii]]))),
+ rbind(matrix(0, J, ncol(cm2[[ii]])), cm2[[ii]]))
+
+ for(ii in 1:length(constraints))
+ constraints[[ii]] =
+ (constraints[[ii]])[interleave.VGAM(M, M=2),,drop=FALSE]
+ }), list( .parallel=parallel, .sparallel=sparallel ))),
+ deviance=eval(substitute(
+ function(mu, y, w, residuals=FALSE, eta, extra=NULL) {
+ answer =
+ Deviance.categorical.data.vgam(mu=mu, y=y, w=w, residuals=residuals,
+ eta=eta, extra=extra)
+ answer
+ }, list( .earg=earg, .link=link ) )),
+ initialize=eval(substitute(expression({
+ 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
+ paste("P[Y<=",1:J,"]", sep="")
+ predictors.names = c(
+ namesof(mynames, .link, short=TRUE, earg= .earg),
+ namesof(paste("scale_", 1:J, sep=""),
+ .lscale, short=TRUE, earg= .escale))
+ y.names = paste("mu", 1:(J+1), sep="")
+
+ if(length(dimnames(y)))
+ extra$dimnamesy2 = dimnames(y)[[2]]
+
+ predictors.names = predictors.names[interleave.VGAM(M, M=2)]
+
+ }), list( .link=link, .lscale=lscale, .reverse=reverse,
+ .earg= earg, .escale=escale ))),
+ inverse=eval(substitute( function(eta, extra=NULL) {
+ J = extra$J
+ M = 2*J
+ etamat1 = eta[,2*(1:J)-1,drop=FALSE]
+ etamat2 = eta[,2*(1:J), drop=FALSE]
+ scalemat = eta2theta(etamat2, .lscale, earg= .escale)
+ fv.matrix =
+ 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))
+ dimnames(fv.matrix) = list(dimnames(eta)[[1]], extra$dimnamesy2)
+ fv.matrix
+ }, list( .link=link, .lscale=lscale, .reverse=reverse,
+ .earg= earg, .escale=escale ))),
+ last=eval(substitute(expression({
+ J = extra$J
+ misc$link = c(rep( .link, length=J),
+ rep( .lscale, length=J))[interleave.VGAM(M, M=2)]
+ names(misc$link) = predictors.names # zz mynames
+ misc$earg = vector("list", M)
+ names(misc$earg) = names(misc$link)
+ for(ii in 1:J) misc$earg[[2*ii-1]] = .earg
+ for(ii in 1:J) misc$earg[[2*ii ]] = .escale
+ misc$parameters = mynames
+ misc$reverse = .reverse
+ misc$parallel = .parallel
+ misc$sparallel = .sparallel
+ }), list( .link=link, .lscale=lscale,
+ .reverse=reverse, .parallel=parallel, .sparallel=sparallel,
+ .earg=earg, .escale=escale ))),
+ link=eval(substitute( function(mu, extra=NULL) {
+ cump = tapplymat1(as.matrix(mu), "cumsum")
+ J = ncol(as.matrix(mu)) - 1
+ M = 2 * J
+ answer = cbind(
+ theta2eta(if( .reverse ) 1-cump[,1:J] else cump[,1:J], .link,
+ earg= .earg),
+ matrix(theta2eta( .iscale, .lscale, earg = .escale),
+ nrow(as.matrix(mu)), J, byrow=TRUE))
+ answer = answer[,interleave.VGAM(M, M=2)]
+ answer
+ }, list( .link=link, .lscale=lscale, .reverse=reverse,
+ .iscale=iscale, .earg=earg, .escale=escale ))),
+ loglikelihood= function(mu, y, w, residuals = FALSE, eta, extra=NULL)
+ if(residuals) stop("loglikelihood residuals not implemented yet") else
+ sum(w * y * log(mu)),
+ vfamily=c("scumulative", "vcategorical"),
+ deriv=eval(substitute(expression({
+ ooz = iter %% 2
+ print("ooz")
+ print( ooz )
+
+ J = extra$J
+ mu.use = pmax(mu, .Machine$double.eps * 1.0e-0)
+
+ etamat1 = eta[,2*(1:J)-1,drop=FALSE]
+ etamat2 = eta[,2*(1:J), drop=FALSE]
+ scalemat = eta2theta(etamat2, .lscale, earg= .escale)
+
+ cump = eta2theta(etamat1 / scalemat, .link, earg= .earg)
+ dcump.deta = dtheta.deta(cump, .link, earg= .earg)
+ dscale.deta = dtheta.deta(scalemat, .lscale, earg= .escale)
+ dl.dcump = (if( .reverse) -w else w) *
+ (y[,1:J]/mu.use[,1:J] - y[,-1]/mu.use[,-1])
+ dcump.dscale = -dcump.deta * etamat1 / scalemat^2
+ 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
+ ans
+ }), list( .link=link, .lscale=lscale, .reverse=reverse,
+ .earg= earg, .escale=escale ))),
+ weight= eval(substitute(expression({
+
+ wz = matrix(0, n, 2*(2*M-3))
+
+ 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 *
+ (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
+
+ 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
+ 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
+
+
+
+ wz0 = -w * (dcump.deta[,-J] / scalemat[,-J]) *
+ (dcump.dscale[,-1] * dscale.deta[,-1]) / mu.use[,2:J]
+ wz0 = as.matrix(wz0)
+ for(ii in 1:(J-1))
+ wz[,iam(2*ii-1,2*ii+2,M=M)] = if(ooz) wz0[,ii] else 0
+ wz0 = -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
+ }), list( .link=link, .lscale=lscale, .earg=earg, .escale=escale ))))
+}
+
+
+
+
+
diff --git a/R/family.censored.q b/R/family.censored.q
index 9b4d2a9..d3b15a3 100644
--- a/R/family.censored.q
+++ b/R/family.censored.q
@@ -1,5 +1,5 @@
# These functions are
-# Copyright (C) 1998-2007 T.W. Yee, University of Auckland. All rights reserved.
+# Copyright (C) 1998-2008 T.W. Yee, University of Auckland. All rights reserved.
@@ -9,6 +9,154 @@
+cenpoisson = function(link = "loge", earg = list(), imu = NULL) {
+ if(mode(link) != "character" && mode(link) != "name")
+ link = as.character(substitute(link))
+ if(!is.list(earg))
+ earg = list()
+
+ new("vglmff",
+ blurb = c("Censored Poisson distribution\n\n",
+ "Link: ", namesof("mu", link, earg = earg), "\n",
+ "Variance: mu"),
+ initialize = eval(substitute(expression({
+ if(any(is.na(y)))
+ stop("NAs are not allowed in the response")
+
+ if(any(y != round(y)))
+ warning("the response should be integer-valued")
+ centype = attr(y, "type")
+ if(centype=="right") {
+ temp = y[, 2]
+ extra$uncensored = ifelse(temp == 1, TRUE, FALSE)
+ extra$rightcensored = ifelse(temp == 0, TRUE, FALSE)
+ extra$leftcensored = rep(FALSE, len=n)
+ extra$interval = rep(FALSE, len=n)
+ init.mu = pmax(y[,1], 1/8)
+ } else
+ if(centype=="left") {
+ temp = y[, 2]
+ extra$uncensored = ifelse(temp == 1, TRUE, FALSE)
+ extra$rightcensored = rep(FALSE, len=n)
+ extra$leftcensored = ifelse(temp == 0, TRUE, FALSE)
+ extra$interval = rep(FALSE, len=n)
+ init.mu = pmax(y[,1], 1/8)
+ } else
+ 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))
+ init.mu[extra$uncensored] = pmax(y[extra$uncensored,1], 1/8)
+ if(any(extra$rightcensored))
+ init.mu[extra$rightcensored] = pmax(y[extra$rightcensored,1], 1/8)
+ if(any(extra$leftcensored))
+ init.mu[extra$leftcensored] = pmax(y[extra$leftcensored,1], 1/8)
+ } else
+ 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
+
+ predictors.names = namesof("mu", .link, earg= .earg, short=TRUE)
+ 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) {
+ mu = eta2theta(eta, link = .link, earg = .earg)
+ mu
+ }, list( .link = link, .earg = earg ))),
+ last = eval(substitute(expression({
+ misc$expected = FALSE
+ misc$link = c("mu" = .link)
+ misc$earg = list("mu" = .earg)
+ }), list( .link = link, .earg = earg ))),
+ link = eval(substitute(function(mu, extra = NULL) {
+ theta2eta(mu, link = .link, earg = .earg)
+ }, list( .link = link, .earg = earg ))),
+ loglikelihood = function(mu, y, w, residuals = FALSE, eta, extra = NULL) {
+ cen0 = extra$uncensored
+ cenL = extra$leftcensored
+ cenU = extra$rightcensored
+ cenI = extra$intervalcensored
+ if(residuals){
+ stop("loglikelihood residuals not implemented yet")
+ } else {
+ sum(w[cen0] * dpois(y[cen0,1], mu[cen0], log=TRUE)) +
+ sum(w[cenU] * log1p(-ppois(y[cenU,1] - 1, mu[cenU]))) +
+ sum(w[cenL] * ppois(y[cenL,1] - 1, mu[cenL], log=TRUE)) +
+ sum(w[cenI] * log(ppois(y[cenI,2], mu[cenI]) -
+ ppois(y[cenI,1], mu[cenI])))
+ }
+ },
+ vfamily = "cenpoisson",
+ deriv = eval(substitute(expression({
+ cen0 = extra$uncensored
+ cenL = extra$leftcensored
+ cenU = extra$rightcensored
+ cenI = extra$intervalcensored
+ lambda = eta2theta(eta, link = .link, earg = .earg)
+ dl.dlambda = (y[,1] - lambda)/lambda # uncensored
+ yllim = yulim = y[,1] # uncensored
+ 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)) {
+ 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)) {
+ yllim[cenI] = y[cenI,1]+1
+ yulim[cenI] = y[cenI,2]
+ Queue1 = ppois(yllim-1, lambda)
+ Queue2 = ppois(yulim, lambda)
+ densm02 = dpois(yulim, lambda)
+ densm12 = dpois(yllim-1, lambda)
+ dl.dlambda[cenI] =
+ (-densm02[cenI]+densm12[cenI]) / (Queue2[cenI]-Queue1[cenI])
+ }
+ dlambda.deta = dtheta.deta(theta=lambda, link= .link, earg= .earg)
+ w * dl.dlambda * dlambda.deta
+ }), list( .link = link, .earg = earg ))),
+ weight = eval(substitute(expression({
+ d2lambda.deta2 = d2theta.deta2(theta=lambda, link= .link, earg= .earg)
+ d2l.dlambda2 = 1 / lambda # uncensored; Fisher scoring
+ if(any(cenU)) {
+ densm2 = dpois(yllim-2, lambda)
+ d2l.dlambda2[cenU] = (dl.dlambda[cenU])^2 -
+ (densm2[cenU]-densm1[cenU])/queue[cenU]
+ }
+ if(any(cenL)) {
+ densm1 = dpois(yulim-1, lambda)
+ d2l.dlambda2[cenL] = (dl.dlambda[cenL])^2 -
+ (densm0[cenL]-densm1[cenL])/Queue[cenL]
+ }
+ if(any(cenI)) {
+ densm03 = dpois(yulim-1, lambda)
+ densm13 = dpois(yllim-2, lambda)
+ d2l.dlambda2[cenI] = (dl.dlambda[cenI])^2 -
+ (densm13[cenI]-densm12[cenI]-densm03[cenI] +
+ densm02[cenI]) / (Queue2[cenI]-Queue1[cenI])
+ }
+ wz = w *((dlambda.deta^2) * d2l.dlambda2)
+ wz
+ }), list( .link = link, .earg = earg ))))
+}
+
+
+
if(FALSE)
cexpon =
@@ -38,8 +186,8 @@ ecexpon = function(link="loge", location=0)
}else
if (type=="interval"){
temp <- y[,3]
- mu = ifelse(temp == 3, y[,2] + (abs(y[,2] - extra$location) < 0.001)
- / 8,y[,1] + (abs(y[,1] - extra$location) < 0.001) / 8)
+ 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))
etastart = theta2eta(1/(mu-extra$location), .link)
@@ -566,6 +714,7 @@ function (time, time2, event, type = c("right", "left", "interval",
is.SurvS4 <- function(x) inherits(x, "SurvS4")
+ setIs(class1="SurvS4", class2="matrix") # Forces vglm()@y to be a matrix
@@ -590,7 +739,7 @@ function (x, ...)
} else {
stat <- x[, 3]
temp <- c("+", "", "-", "]")[stat + 1]
- temp2 <- ifelse(stat == 3, paste("[", format(x[, 1]),
+ temp2 <- ifelse(stat == 3, paste("(", format(x[, 1]),
", ", format(x[, 2]), sep = ""), format(x[, 1]))
ifelse(is.na(stat), as.character(NA), paste(temp2, temp, sep = ""))
}
diff --git a/R/family.circular.q b/R/family.circular.q
new file mode 100644
index 0000000..2e6af92
--- /dev/null
+++ b/R/family.circular.q
@@ -0,0 +1,292 @@
+# These functions are
+# Copyright (C) 1998-2008 T.W. Yee, University of Auckland. All rights reserved.
+
+
+
+
+
+dcard = function(x, mu, rho) {
+ if(!is.Numeric(mu) || any(mu < 0) || any(mu > 2*pi))
+ stop("'mu' must be between 0 and 2*pi inclusive")
+ if(!is.Numeric(rho) || max(abs(rho) > 0.5))
+ stop("'rho' must be between -0.5 and 0.5 inclusive")
+ L = max(length(x), length(mu), length(rho))
+ x = rep(x, len=L); mu = rep(mu, len=L); rho = rep(rho, len=L);
+ ans = (1 + 2 * rho * cos(x-mu)) / (2*pi)
+ ans[x > (2*pi)] = 0
+ ans[x < 0] = 0
+ ans
+}
+
+pcard = function(q, mu, rho) {
+ if(!is.Numeric(mu) || any(mu < 0) || any(mu > 2*pi))
+ stop("'mu' must be between 0 and 2*pi inclusive")
+ if(!is.Numeric(rho) || max(abs(rho) > 0.5))
+ stop("'rho' must be between -0.5 and 0.5 inclusive")
+ ans = (q + 2 * rho * (sin(q-mu) + sin(mu))) / (2*pi)
+ ans[q >= (2*pi)] = 1
+ ans[q <= 0] = 0
+ ans
+}
+
+qcard = function(p, mu, rho, tolerance=1.0e-7, maxits=500) {
+ if(!is.Numeric(mu) || any(mu < 0) || any(mu > 2*pi))
+ stop("'mu' must be between 0 and 2*pi inclusive")
+ if(!is.Numeric(rho) || max(abs(rho) > 0.5))
+ stop("'rho' must be between -0.5 and 0.5 inclusive")
+ if(!is.Numeric(p, positive=TRUE) || any(p > 1))
+ stop("'p' must be between 0 and 1")
+ nn = max(length(p), length(mu), length(rho))
+ p = rep(p, len=nn)
+ mu = rep(mu, len=nn)
+ rho = rep(rho, len=nn)
+
+
+ oldans = 2 * pi * p
+
+ for(its in 1:maxits) {
+ 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)) {
+ ans[index] = runif(sum(index), 0, 2*pi)
+ }
+ 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))
+ stop("'mu' must be between 0 and 2*pi inclusive")
+ if(!is.Numeric(rho) || max(abs(rho) > 0.5))
+ stop("'rho' must be between -0.5 and 0.5 inclusive")
+ if(!is.Numeric(n, positive=TRUE, integer=TRUE, allow=1))
+ stop("'n' must be a single positive integer")
+ mu = rep(mu, len=n)
+ rho = rep(rho, len=n)
+ qcard(runif(n), mu=mu, rho=rho, ...)
+}
+
+
+
+cardioid.control <- function(save.weight=TRUE, ...)
+{
+ list(save.weight=save.weight)
+}
+
+
+cardioid = function(lmu="elogit", lrho="elogit",
+ emu=if(lmu=="elogit") list(min=0, max=2*pi) else list(),
+ erho=if(lmu=="elogit") list(min=-0.5, max=0.5) else list(),
+ imu=NULL, irho=0.3,
+ nsimEIM=100, zero=NULL)
+{
+ if(mode(lmu) != "character" && mode(lmu) != "name")
+ lmu = as.character(substitute(lmu))
+ if(mode(lrho) != "character" && mode(lrho) != "name")
+ lrho = as.character(substitute(lrho))
+ if(length(imu) && (!is.Numeric(imu, positive=TRUE) || any(imu > 2*pi)))
+ stop("bad input for argument \"imu\"")
+ if(!is.Numeric(irho) || max(abs(irho)) > 0.5)
+ stop("bad input for argument \"irho\"")
+ if(!is.list(emu)) emu = list()
+ if(!is.list(erho)) erho = list()
+ if(!is.Numeric(nsimEIM, allow=1, integ=TRUE) || nsimEIM <= 50)
+ stop("'nsimEIM' should be an integer greater than 50")
+
+ new("vglmff",
+ blurb=c("Cardioid distribution\n\n",
+ "Links: ",
+ namesof("mu", lmu, earg= emu), ", ",
+ namesof("rho", lrho, earg= erho, tag=FALSE), "\n",
+ "Mean: ",
+ "pi + (rho/pi) *",
+ "((2*pi-mu)*sin(2*pi-mu)+cos(2*pi-mu)-mu*sin(mu)-cos(mu))"),
+ constraints=eval(substitute(expression({
+ constraints = cm.zero.vgam(constraints, x, .zero, M)
+ }), list( .zero=zero ))),
+ initialize=eval(substitute(expression({
+ if(ncol(y <- cbind(y)) != 1)
+ stop("the response must be a vector or one-column matrix")
+ if(any((y <= 0) | (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)) {
+ rho.init = rep(if(length(.irho)) .irho else 0.3, length=n)
+
+ cardioid.Loglikfun = function(mu, y, x, w, extraargs) {
+ rho = extraargs$irho
+ 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
+ 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))
+ etastart = cbind(theta2eta(mu.init, .lmu, earg= .emu),
+ theta2eta(rho.init, .lrho, earg= .erho))
+ }
+ }), list( .lmu=lmu, .lrho=lrho,
+ .imu=imu, .irho=irho,
+ .emu=emu, .erho=erho ))),
+ inverse=eval(substitute(function(eta, extra=NULL){
+ mu = eta2theta(eta[,1], link= .lmu, earg= .emu)
+ rho = eta2theta(eta[,2], link= .lrho, earg= .erho)
+ pi + (rho/pi) *
+ ((2*pi-mu)*sin(2*pi-mu) + cos(2*pi-mu) - mu*sin(mu) - cos(mu))
+ }, list( .lmu=lmu, .lrho=lrho,
+ .emu=emu, .erho=erho ))),
+ last=eval(substitute(expression({
+ misc$link = c("mu"= .lmu, "rho"= .lrho)
+ misc$earg = list("mu"= .emu, "rho"= .erho)
+ misc$expected = TRUE
+ misc$nsimEIM = .nsimEIM
+ }), list( .lmu=lmu, .lrho=lrho,
+ .emu=emu, .erho=erho, .nsimEIM=nsimEIM ))),
+ loglikelihood=eval(substitute(
+ function(mu,y,w,residuals=FALSE,eta,extra=NULL) {
+ mu = eta2theta(eta[,1], link= .lmu, earg= .emu)
+ rho = eta2theta(eta[,2], link= .lrho, earg= .erho)
+ if(residuals) stop("loglikelihood residuals not implemented yet") else
+ sum(w * (-log(2*pi) + log1p(2*rho*cos(y-mu))))
+ }, list( .lmu=lmu, .lrho=lrho,
+ .emu=emu, .erho=erho ))),
+ vfamily=c("cardioid"),
+ deriv=eval(substitute(expression({
+ mu = eta2theta(eta[,1], link= .lmu, earg= .emu)
+ rho = eta2theta(eta[,2], link= .lrho, earg= .erho)
+ dmu.deta = dtheta.deta(mu, link= .lmu, earg= .emu)
+ drho.deta = dtheta.deta(rho, link= .lrho, earg= .erho)
+ dl.dmu = 2 * rho * sin(y-mu) / (1 + 2 * rho * cos(y-mu))
+ dl.drho = 2 * cos(y-mu) / (1 + 2 * rho * cos(y-mu))
+ w * cbind(dl.dmu * dmu.deta,
+ dl.drho * drho.deta)
+ }), list( .lmu=lmu, .lrho=lrho,
+ .emu=emu, .erho=erho, .nsimEIM=nsimEIM ))),
+ weight = eval(substitute(expression({
+ run.varcov = 0
+ ind1 = iam(NA, NA, M=M, both=TRUE, diag=TRUE)
+ index0 = iam(NA, NA, M=M, both=TRUE, diag=TRUE)
+ for(ii in 1:( .nsimEIM )) {
+ ysim = rcard(n, mu=mu, rho=rho)
+ dl.dmu = 2 * rho * sin(ysim-mu) / (1 + 2 * rho * cos(ysim-mu))
+ dl.drho = 2 * cos(ysim-mu) / (1 + 2 * rho * cos(ysim-mu))
+ rm(ysim)
+ temp3 = cbind(dl.dmu, dl.drho)
+ run.varcov = ((ii-1) * run.varcov +
+ temp3[,ind1$row.index]*temp3[,ind1$col.index]) / ii
+ }
+ wz = if(intercept.only)
+ matrix(apply(run.varcov, 2, mean),
+ n, ncol(run.varcov), byrow=TRUE) else run.varcov
+
+ dtheta.detas = cbind(dmu.deta, drho.deta)
+ wz = wz * dtheta.detas[,index0$row] * dtheta.detas[,index0$col]
+ w * wz
+ }), list( .lmu=lmu, .lrho=lrho,
+ .emu=emu, .erho=erho, .nsimEIM=nsimEIM ))))
+}
+
+
+
+vonmises = function(llocation="elogit",
+ lscale="loge",
+ elocation=if(llocation=="elogit") list(min=0, max=2*pi) else list(),
+ escale=list(),
+ ilocation=NULL, iscale=NULL,
+ method.init=1, zero=NULL) {
+ if(mode(llocation) != "character" && mode(llocation) != "name")
+ llocation = as.character(substitute(llocation))
+ if(mode(lscale) != "character" && mode(lscale) != "name")
+ lscale = as.character(substitute(lscale))
+ if(!is.Numeric(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))
+ stop("bad input for argument \"zero\"")
+ if(!is.list(escale)) escale = list()
+
+ new("vglmff",
+ blurb=c("Von Mises distribution\n\n",
+ "Links: ",
+ namesof("location", llocation, earg= elocation), ", ",
+ namesof("scale", lscale, earg=escale),
+ "\n", "\n",
+ "Mean: location"),
+ constraints=eval(substitute(expression({
+ constraints = cm.zero.vgam(constraints, x, .zero, M)
+ }), list( .zero=zero ))),
+ initialize=eval(substitute(expression({
+ if(ncol(cbind(y)) != 1)
+ stop("response must be a vector or a one-column matrix")
+ predictors.names =
+ c(namesof("location", .llocation, earg= .elocation, tag=FALSE),
+ namesof("scale", .lscale, earg=.escale, tag=FALSE))
+ 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)
+ } else {
+ 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
+ rep(location.init, len=n)
+ scale.init= if(length(.iscale)) rep(.iscale,len=n) else rep(1,len=n)
+ etastart = cbind(
+ theta2eta(location.init, .llocation, earg= .elocation),
+ theta2eta(scale.init, .lscale, earg= .escale))
+ }
+ y = y %% (2*pi) # Coerce after initial values have been computed
+ }), list( .method.init=method.init, .ilocation=ilocation,
+ .escale=escale, .iscale=iscale,
+ .lscale=lscale, .llocation=llocation, .elocation=elocation ))),
+ inverse=eval(substitute(function(eta, extra=NULL) {
+ eta2theta(eta[,1], .llocation, earg= .elocation) %% (2*pi)
+ }, list( .escale=escale, .lscale=lscale,
+ .llocation=llocation, .elocation=elocation ))),
+ last=eval(substitute(expression({
+ misc$link = c(location= .llocation, scale= .lscale)
+ misc$earg = list(location= .elocation, scale= .escale )
+ }), list( .escale=escale, .lscale=lscale,
+ .llocation=llocation, .elocation=elocation ))),
+ loglikelihood=eval(substitute(
+ function(mu,y,w,residuals= FALSE,eta, extra=NULL) {
+ location = eta2theta(eta[,1], .llocation, earg= .elocation)
+ Scale = eta2theta(eta[,2], .lscale, earg= .escale)
+ if(residuals) stop("loglikelihood residuals not implemented yet") else
+ sum(w * (Scale * cos(y - location) -
+ log(mbesselI0(x=Scale ))))
+ }, list( .escale=escale, .lscale=lscale,
+ .llocation=llocation, .elocation=elocation ))),
+ vfamily=c("vonmises"),
+ deriv=eval(substitute(expression({
+ location = eta2theta(eta[,1], .llocation, earg= .elocation)
+ Scale = eta2theta(eta[,2], .lscale, earg= .escale)
+ tmp6 = mbesselI0(x=Scale, deriv=2)
+ dl.dlocation = Scale * sin(y - location)
+ dlocation.deta = dtheta.deta(location, .llocation, earg= .elocation)
+ dl.dscale = cos(y - location) - tmp6[,2] / tmp6[,1]
+ dscale.deta = dtheta.deta(Scale, .lscale, earg= .escale)
+ w * cbind(dl.dlocation * dlocation.deta,
+ dl.dscale * dscale.deta)
+ }), list( .escale=escale, .lscale=lscale,
+ .llocation=llocation, .elocation=elocation ))),
+ weight=eval(substitute(expression({
+ d2l.location2 = Scale * tmp6[,2] / tmp6[,1]
+ d2l.dscale2 = tmp6[,3] / tmp6[,1] - (tmp6[,2] / tmp6[,1])^2
+ wz = matrix(as.numeric(NA), nrow=n, ncol=2) # diagonal
+ wz[,iam(1,1,M)] = d2l.location2 * dlocation.deta^2
+ wz[,iam(2,2,M)] = d2l.dscale2 * dscale.deta^2
+ w * wz
+ }), list( .escale=escale, .lscale=lscale,
+ .llocation=llocation, .elocation=elocation ))))
+}
+
+
+
diff --git a/R/family.extremes.q b/R/family.extremes.q
index 4456330..c6895d6 100644
--- a/R/family.extremes.q
+++ b/R/family.extremes.q
@@ -1,5 +1,5 @@
# These functions are
-# Copyright (C) 1998-2007 T.W. Yee, University of Auckland. All rights reserved.
+# Copyright (C) 1998-2008 T.W. Yee, University of Auckland. All rights reserved.
@@ -854,7 +854,7 @@ pgpd = function(q, location=0, scale=1, shape=0) {
if(nscase) {
pos = q>=0
ind9 = pos & scase
- ans[ind9] = 1 - exp(-q[ind9]/scale[ind9])
+ ans[ind9] = -expm1(-q[ind9]/scale[ind9])
ind9 = !pos & scase
ans[ind9] = 0
}
@@ -1433,7 +1433,7 @@ egumbel = function(llocation="identity",
loc = eta2theta(eta[,1], .llocation, earg= .elocation)
sc = eta2theta(eta[,2], .lscale, earg= .escale )
zedd = (y-loc) / sc
- temp2 = 1 - exp(-zedd)
+ temp2 = -expm1(-zedd)
dl.dloc = temp2 / sc
dl.dsc = -1/sc + temp2 * zedd / sc
dloc.deta = dtheta.deta(loc, .llocation, earg= .elocation)
@@ -1571,7 +1571,7 @@ cgumbel = function(llocation="identity",
loc = eta2theta(eta[,1], .llocation, earg= .elocation )
sc = eta2theta(eta[,2], .lscale, earg= .escale )
zedd = (y-loc) / sc
- temp2 = 1 - exp(-zedd)
+ temp2 = -expm1(-zedd)
dl.dloc = temp2 / sc
dl.dsc = -1/sc + temp2 * zedd / sc
dloc.deta = dtheta.deta(loc, .llocation, earg= .elocation )
diff --git a/R/family.functions.q b/R/family.functions.q
index 8861fa4..90cd86d 100644
--- a/R/family.functions.q
+++ b/R/family.functions.q
@@ -1,5 +1,5 @@
# These functions are
-# Copyright (C) 1998-2007 T.W. Yee, University of Auckland. All rights reserved.
+# Copyright (C) 1998-2008 T.W. Yee, University of Auckland. All rights reserved.
diff --git a/R/family.genetic.q b/R/family.genetic.q
index d0eb84c..3a83dbd 100644
--- a/R/family.genetic.q
+++ b/R/family.genetic.q
@@ -1,5 +1,5 @@
# These functions are
-# Copyright (C) 1998-2007 T.W. Yee, University of Auckland. All rights reserved.
+# Copyright (C) 1998-2008 T.W. Yee, University of Auckland. All rights reserved.
diff --git a/R/family.glmgam.q b/R/family.glmgam.q
index 87d7d02..a3d8c67 100644
--- a/R/family.glmgam.q
+++ b/R/family.glmgam.q
@@ -1,5 +1,5 @@
# These functions are
-# Copyright (C) 1998-2007 T.W. Yee, University of Auckland. All rights reserved.
+# Copyright (C) 1998-2008 T.W. Yee, University of Auckland. All rights reserved.
@@ -1064,3 +1064,252 @@ dexpbinomial <- function(lmean="logit", ldispersion="logit",
.ldispersion=ldispersion, .edispersion=edispersion ))))
}
+
+
+
+mbinomial <- function(mvar=NULL, link="logit", earg=list(),
+ parallel = TRUE, smallno = .Machine$double.eps^(3/4))
+{
+ if(mode(link )!= "character" && mode(link )!= "name")
+ link <- as.character(substitute(link))
+ if(!is.list(earg)) earg = list()
+ if(!is.Numeric(smallno, positive=TRUE, allow=1) || smallno > 1e-4)
+ stop("bad input for 'smallno'")
+ if(is.logical(parallel) && !parallel)
+ stop("'parallel' must be TRUE")
+
+ temp = terms(mvar)
+ mvar = attr(temp,"term.labels")
+ if(length(mvar) != 1) stop("cannot obtain the matching variable")
+ if(!is.character(mvar) || length(mvar) != 1) {
+ stop("bad input for 'mvar'")
+ }
+
+ new("vglmff",
+ blurb= c("Matched binomial model (intercepts fitted)\n\n",
+ "Link: ", namesof("mu[,j]", link, earg= earg)),
+ constraints=eval(substitute(expression({
+ constraints <- cm.vgam(matrix(1,M,1), x, .parallel, constraints,
+ intercept.apply=TRUE)
+ constraints[[extra$mvar]] <- diag(M)
+
+ specialCM = list(a = vector("list", M-1))
+ for(ii in 1:(M-1)) {
+ specialCM[[1]][[ii]] = (constraints[[extra$mvar]])[,1+ii,drop=FALSE]
+ }
+ names(specialCM) = extra$mvar
+ }), list( .parallel=parallel ))),
+ initialize=eval(substitute(expression({
+ mvar = .mvar
+
+ NCOL = function (x)
+ if(is.array(x) && length(dim(x)) > 1 ||
+ is.data.frame(x)) ncol(x) else as.integer(1)
+
+ if(NCOL(y) == 1) {
+ if(is.factor(y)) y = y != levels(y)[1]
+ nn = rep(1, n)
+ 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))
+ stop("Number of successes must be integer-valued")
+ } 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)
+ w = w * nn
+ mustart = (0.5 + nn * y) / (1 + nn)
+ } else
+ stop("Response not of the right form")
+
+ temp1 = attr(x, "assign")
+ 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)
+ temp9 = apply(temp9, 1, max)
+ temp9[temp9 == 0] = 1
+ extra$NoMatchedSets = CCC
+ extra$n = n
+ extra$M = M
+ extra$mvar = mvar
+ extra$index9 = temp9
+
+ predictors.names = namesof("mu", .link, earg= .earg, short=TRUE)
+ predictors.names = rep(predictors.names, len=M)
+ }), list( .link=link, .earg=earg, .mvar=mvar ))),
+ inverse=eval(substitute(function(eta, extra=NULL) {
+ mu = eta2theta(eta, link= .link, earg = .earg)
+ mu[cbind(1:extra$n, extra$index9)]
+ }, 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 ",
+ 1:M, ")", sep="") else "mu"
+ misc$earg = vector("list", M)
+ names(misc$earg) = names(misc$link)
+ for(ii in 1:M) misc$earg[[ii]] = .earg
+
+ misc$expected = TRUE
+ }), list( .link=link, .earg = earg ))),
+ link=eval(substitute(function(mu, extra=NULL) {
+ temp = theta2eta(mu, .link, earg = .earg )
+ matrix(temp, extra$n, extra$M)
+ }, list( .link=link, .earg = earg ))),
+ loglikelihood= function(mu, y, w, residuals = FALSE, eta, extra=NULL) {
+ 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") {
+ w * (y - mu)
+ } else if( .link == "cloglog") {
+ mu.use = mu
+ smallno = 100 * .Machine$double.eps
+ mu.use[mu.use < smallno] = smallno
+ mu.use[mu.use > 1 - smallno] = 1 - smallno
+ -w * (y - mu) * log1p(-mu.use) / mu.use
+ } else
+ w * dtheta.deta(mu, link= .link, earg = .earg )* (y/mu - 1)/(1-mu)
+ result = matrix(0, n, M)
+ result[cbind(1:n, extra$index9)] = answer
+ result
+ }), list( .link=link, .earg = earg ))),
+ weight=eval(substitute(expression({
+ tmp100 = mu*(1-mu)
+ answer = if( .link == "logit") {
+ cbind(w * tmp100)
+ } 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)
+ }
+
+ result = matrix( .smallno, n, M)
+ result[cbind(1:n, extra$index9)] = answer
+ result
+ }), list( .link=link, .earg = earg, .smallno=smallno ))))
+}
+
+
+
+
+mypool = function(x, index) {
+ answer = x
+ uindex = unique(index)
+ for(i in uindex) {
+ ind0 = index == i
+ answer[ind0] = sum(x[ind0])
+ }
+ answer
+}
+
+
+mbino <- function()
+{
+ link = "logit"
+ earg = list()
+ parallel = TRUE
+
+ if(mode(link )!= "character" && mode(link )!= "name")
+ link <- as.character(substitute(link))
+ if(!is.list(earg)) earg = list()
+ if(is.logical(parallel) && !parallel)
+ stop("'parallel' must be TRUE")
+
+
+ new("vglmff",
+ blurb= c("Matched binomial model (intercepts not fitted)\n\n",
+ "Link: ", namesof("mu[,j]", link, earg= earg)),
+ constraints=eval(substitute(expression({
+ constraints <- cm.vgam(matrix(1,M,1), x, .parallel, constraints,
+ intercept.apply=FALSE)
+ }), list( .parallel=parallel ))),
+ initialize=eval(substitute(expression({
+ 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 ||
+ is.data.frame(x)) ncol(x) else as.integer(1)
+
+ if(NCOL(y) == 1) {
+ if(is.factor(y)) y = y != levels(y)[1]
+ nn = rep(1, n)
+ 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))
+ stop("Number of successes must be integer-valued")
+ } 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)
+ w = w * nn
+ mustart = (0.5 + nn * y) / (1 + nn)
+ } else
+ stop("Response not of the right form")
+
+ 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(any(y != 0 & y != 1))
+ stop("response vector must have 0 or 1 values only")
+ xrle = rle(mvar)
+ if(length(unique(mvar)) != length(xrel$zz))
+ stop("extra$mvar must take on contiguous values")
+
+ temp9 = factor(mvar)
+ extra$NoMatchedSets = levels(temp9)
+ extra$n = n
+ extra$M = M
+ extra$rlex = xrle
+ extra$index9 = temp9
+ predictors.names = namesof("mu", .link, earg= .earg, short=TRUE)
+ }), list( .link=link, .earg=earg, .mvar=mvar ))),
+ inverse=eval(substitute(function(eta, extra=NULL) {
+ denominator = exp(eta)
+ numerator = mypool(denominator, extra$mvar)
+ numerator / denominator
+ }, list( .link=link, .earg = earg ))),
+ last=eval(substitute(expression({
+ misc$link = c(mu = .link)
+ misc$earg = list( mu = .earg )
+ 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
+ sum(w*(y*log(mu) + (1-y)*log1p(-mu)))
+ },
+ vfamily=c("mbin", "vcategorical"),
+ deriv=eval(substitute(expression({
+ answer =
+ 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") {
+ cbind(w * tmp100)
+ } else stop("can only handle the logit link")
+
+ result = matrix( .smallno, n, M)
+ result[cbind(1:n, extra$index9)] = answer
+ result
+ }), list( .link=link, .earg = earg, .smallno=smallno ))))
+}
+
+
diff --git a/R/family.loglin.q b/R/family.loglin.q
index 2b79836..b9167b3 100644
--- a/R/family.loglin.q
+++ b/R/family.loglin.q
@@ -1,5 +1,5 @@
# These functions are
-# Copyright (C) 1998-2007 T.W. Yee, University of Auckland. All rights reserved.
+# Copyright (C) 1998-2008 T.W. Yee, University of Auckland. All rights reserved.
diff --git a/R/family.mixture.q b/R/family.mixture.q
index 9f948d4..09e8ac2 100644
--- a/R/family.mixture.q
+++ b/R/family.mixture.q
@@ -1,23 +1,27 @@
# These functions are
-# Copyright (C) 1998-2007 T.W. Yee, University of Auckland. All rights reserved.
+# Copyright (C) 1998-2008 T.W. Yee, University of Auckland. All rights reserved.
-mix2normal1.control <- function(save.weight=TRUE, ...)
+
+mix2normal1.control <- function(trace=TRUE, ...)
{
- list(save.weight=save.weight)
+ list(trace=trace)
}
+
mix2normal1 = function(lphi="logit",
lmu="identity",
lsd="loge",
- ephi=list(), emu1=list(), emu2=list(), esd1=list(), esd2=list(),
+ ephi=list(), emu1=list(), emu2=list(),
+ esd1=list(), esd2=list(),
iphi=0.5, imu1=NULL, imu2=NULL, isd1=NULL, isd2=NULL,
qmu=c(0.2, 0.8),
- esd=FALSE,
+ ESD=TRUE,
+ nsimEIM=100,
zero=1)
{
if(mode(lphi) != "character" && mode(lphi) != "name")
@@ -43,22 +47,26 @@ mix2normal1 = function(lphi="logit",
if(!is.list(emu2)) emu2 = list()
if(!is.list(esd1)) esd1 = list()
if(!is.list(esd2)) esd2 = list()
+ if(!is.logical(ESD) || length(ESD) != 1)
+ stop("bad input for argument \"ESD\"")
+ if(!is.Numeric(nsimEIM, allow=1, integ=TRUE) || nsimEIM <= 10)
+ stop("'nsimEIM' should be an integer greater than 10")
new("vglmff",
blurb=c("Mixture of two univariate normals\n\n",
"Links: ",
- namesof("phi",lphi, earg= ephi), ", ",
- namesof("mu1", lmu, earg= emu1, tag=FALSE), ", ",
- namesof("sd1", lsd, earg= esd1, tag=FALSE), ", ",
- namesof("mu2", lmu, earg= emu2, tag=FALSE), ", ",
- namesof("sd2", lsd, earg= esd2, tag=FALSE), "\n",
+ namesof("phi", lphi, earg= ephi, tag=FALSE), ", ",
+ namesof("mu1", lmu, earg= emu1, tag=FALSE), ", ",
+ namesof("sd1", lsd, earg= esd1, tag=FALSE), ", ",
+ namesof("mu2", lmu, earg= emu2, tag=FALSE), ", ",
+ namesof("sd2", lsd, earg= esd2, tag=FALSE), "\n",
"Mean: phi*mu1 + (1-phi)*mu2\n",
"Variance: phi*sd1^2 + (1-phi)*sd2^2 + phi*(1-phi)*(mu1-mu2)^2"),
constraints=eval(substitute(expression({
- constraints = cm.vgam(rbind(diag(4), c(0,0,1,0)), x, .esd,
+ constraints = cm.vgam(rbind(diag(4), c(0,0,1,0)), x, .ESD,
constraints, int=TRUE)
constraints = cm.zero.vgam(constraints, x, .zero, M)
- }), list(.zero=zero, .esd=esd))),
+ }), list(.zero=zero, .ESD=ESD))),
initialize=eval(substitute(expression({
if(ncol(y <- cbind(y)) != 1)
stop("the response must be a vector or one-column matrix")
@@ -70,39 +78,35 @@ mix2normal1 = function(lphi="logit",
namesof("sd2", .lsd, earg= .esd2, tag=FALSE))
if(!length(etastart)) {
qy = quantile(y, prob= .qmu)
- init.phi = if(length(.iphi)) rep(.iphi, length=n) else {
- 0.5
- }
- init.mu1 = if(length(.imu1)) rep(.imu1, length=n) else {
- rep(qy[1], length=n)
- }
- init.mu2 = if(length(.imu2)) rep(.imu2, length=n) else {
- rep(qy[2], length=n)
- }
+ 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
round(n* init.phi[1]):n
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 = if(length(.isd1)) rep(.isd1, length=n) else {
- sd(sorty[ind.1])
- }
- init.sd2 = if(length(.isd2)) rep(.isd2, length=n) else {
- sd(sorty[ind.2])
+ 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( .ESD ) {
+ init.sd1 = init.sd2 = (init.sd1 + init.sd2)/2
+ if(!all.equal( .esd1, .esd2 ))
+ stop("'esd1' and 'esd2' must be equal if ESD=TRUE")
}
etastart = cbind(theta2eta(init.phi, .lphi, earg= .ephi),
- theta2eta(init.mu1, .lmu, earg= .emu1),
- theta2eta(init.sd1, .lsd, earg= .esd1),
- theta2eta(init.mu2, .lmu, earg= .emu2),
- theta2eta(init.sd2, .lsd, earg= .esd2))
+ theta2eta(init.mu1, .lmu, earg= .emu1),
+ theta2eta(init.sd1, .lsd, earg= .esd1),
+ theta2eta(init.mu2, .lmu, earg= .emu2),
+ theta2eta(init.sd2, .lsd, earg= .esd2))
}
}), list(.lphi=lphi, .lmu=lmu, .iphi=iphi, .imu1=imu1, .imu2=imu2,
.ephi=ephi, .emu1=emu1, .emu2=emu2, .esd1=esd1, .esd2=esd2,
+ .ESD=ESD,
.lsd=lsd, .isd1=isd1, .isd2=isd2, .qmu=qmu))),
inverse=eval(substitute(function(eta, extra=NULL){
phi = eta2theta(eta[,1], link= .lphi, earg= .ephi)
- mu1 = eta2theta(eta[,2], link= .lmu, earg= .emu1)
- mu2 = eta2theta(eta[,4], link= .lmu, earg= .emu2)
+ mu1 = eta2theta(eta[,2], link= .lmu, earg= .emu1)
+ mu2 = eta2theta(eta[,4], link= .lmu, earg= .emu2)
phi*mu1 + (1-phi)*mu2
}, list(.lphi=lphi, .lmu=lmu,
.ephi=ephi, .emu1=emu1, .emu2=emu2, .esd1=esd1, .esd2=esd2 ))),
@@ -111,18 +115,19 @@ mix2normal1 = function(lphi="logit",
"sd1"= .lsd, "mu2"= .lmu, "sd2"= .lsd)
misc$earg = list("phi"= .ephi, "mu1"= .emu1,
"sd1"= .esd1, "mu2"= .emu2, "sd2"= .esd2)
- misc$expected = FALSE
- misc$esd = .esd
- misc$BFGS = TRUE
- }), list(.lphi=lphi, .lmu=lmu, .lsd=lsd, .esd=esd,
- .ephi=ephi, .emu1=emu1, .emu2=emu2, .esd1=esd1, .esd2=esd2 ))),
+ misc$expected = TRUE
+ misc$ESD = .ESD
+ misc$nsimEIM = .nsimEIM
+ }), list(.lphi=lphi, .lmu=lmu, .lsd=lsd, .ESD=ESD,
+ .ephi=ephi, .emu1=emu1, .emu2=emu2, .esd1=esd1, .esd2=esd2,
+ .nsimEIM=nsimEIM ))),
loglikelihood=eval(substitute(
function(mu,y,w,residuals=FALSE,eta,extra=NULL) {
phi = eta2theta(eta[,1], link= .lphi, earg= .ephi)
- mu1 = eta2theta(eta[,2], link= .lmu, earg= .emu1)
- sd1 = eta2theta(eta[,3], link= .lsd, earg= .esd1)
- mu2 = eta2theta(eta[,4], link= .lmu, earg= .emu2)
- sd2 = eta2theta(eta[,5], link= .lsd, earg= .esd2)
+ mu1 = eta2theta(eta[,2], link= .lmu, earg= .emu1)
+ sd1 = eta2theta(eta[,3], link= .lsd, earg= .esd1)
+ mu2 = eta2theta(eta[,4], link= .lmu, earg= .emu2)
+ sd2 = eta2theta(eta[,5], link= .lsd, earg= .esd2)
f1 = dnorm(y, mean=mu1, sd=sd1)
f2 = dnorm(y, mean=mu2, sd=sd2)
if(residuals) stop("loglikelihood residuals not implemented yet") else
@@ -133,66 +138,81 @@ mix2normal1 = function(lphi="logit",
vfamily=c("mix2normal1"),
deriv=eval(substitute(expression({
phi = eta2theta(eta[,1], link= .lphi, earg= .ephi)
- mu1 = eta2theta(eta[,2], link= .lmu, earg= .emu1)
- sd1 = eta2theta(eta[,3], link= .lsd, earg= .esd1)
- mu2 = eta2theta(eta[,4], link= .lmu, earg= .emu2)
- sd2 = eta2theta(eta[,5], link= .lsd, earg= .esd2)
+ mu1 = eta2theta(eta[,2], link= .lmu, earg= .emu1)
+ sd1 = eta2theta(eta[,3], link= .lsd, earg= .esd1)
+ mu2 = eta2theta(eta[,4], link= .lmu, earg= .emu2)
+ sd2 = eta2theta(eta[,5], link= .lsd, earg= .esd2)
+ dphi.deta = dtheta.deta(phi, link= .lphi, earg= .ephi)
+ dmu1.deta = dtheta.deta(mu1, link= .lmu, earg= .emu1)
+ dmu2.deta = dtheta.deta(mu2, link= .lmu, earg= .emu2)
+ dsd1.deta = dtheta.deta(sd1, link= .lsd, earg= .esd1)
+ dsd2.deta = dtheta.deta(sd2, link= .lsd, earg= .esd2)
f1 = dnorm(y, mean=mu1, sd=sd1)
f2 = dnorm(y, mean=mu2, sd=sd2)
pdf = phi*f1 + (1-phi)*f2
- df1.dmu1 = (y-mu1) * f1 / sd1^2
- df2.dmu2 = (y-mu2) * f2 / sd2^2
+ z1 = (y-mu1) / sd1
+ z2 = (y-mu2) / sd2
+ df1.dmu1 = z1 * f1 / sd1
+ df2.dmu2 = z2 * f2 / sd2
+ df1.dsd1 = (z1^2 - 1) * f1 / sd1
+ df2.dsd2 = (z2^2 - 1) * f2 / sd2
dl.dphi = (f1-f2) / pdf
dl.dmu1 = phi * df1.dmu1 / pdf
dl.dmu2 = (1-phi) * df2.dmu2 / pdf
- dl.dsd1 = phi * f1 * (((y-mu1)/sd1)^2 - 1) / (sd1 * pdf)
- dl.dsd2 = (1-phi) * f2 * (((y-mu2)/sd2)^2 - 1) / (sd2 * pdf)
- dphi.deta = dtheta.deta(phi, link= .lphi, earg= .ephi)
- dmu1.deta = dtheta.deta(mu1, link= .lmu, earg= .emu1)
- dmu2.deta = dtheta.deta(mu2, link= .lmu, earg= .emu2)
- dsd1.deta = dtheta.deta(sd1, link= .lsd, earg= .esd1)
- dsd2.deta = dtheta.deta(sd2, link= .lsd, earg= .esd2)
- if(iter == 1) {
- etanew = eta
- } else {
- derivold = derivnew
- etaold = etanew
- etanew = eta
- }
- derivnew = w * cbind(dl.dphi * dphi.deta,
- dl.dmu1 * dmu1.deta,
- dl.dsd1 * dsd1.deta,
- dl.dmu2 * dmu2.deta,
- dl.dsd2 * dsd2.deta)
- derivnew
+ dl.dsd1 = phi * df1.dsd1 / pdf
+ dl.dsd2 = (1-phi) * df2.dsd2 / pdf
+ w * cbind(dl.dphi * dphi.deta,
+ dl.dmu1 * dmu1.deta,
+ dl.dsd1 * dsd1.deta,
+ dl.dmu2 * dmu2.deta,
+ dl.dsd2 * dsd2.deta)
}), list(.lphi=lphi, .lmu=lmu, .lsd=lsd,
- .ephi=ephi, .emu1=emu1, .emu2=emu2, .esd1=esd1, .esd2=esd2 ))),
+ .ephi=ephi, .emu1=emu1, .emu2=emu2, .esd1=esd1, .esd2=esd2,
+ .nsimEIM=nsimEIM ))),
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
+
+ d3 = deriv3(~ log(
+ phi * dnorm((ysim-mu1)/sd1) / sd1 +
+ (1-phi) * dnorm((ysim-mu2)/sd2) / sd2),
+ c("phi","mu1","sd1","mu2","sd2"), hessian= TRUE)
+ run.mean = 0
+ for(ii in 1:( .nsimEIM )) {
+ ysim = ifelse(runif(n) < phi, rnorm(n,mu1,sd1), rnorm(n,mu2,sd2))
+
+ eval.d3 = eval(d3)
+ d2l.dthetas2 = attr(eval.d3, "hessian")
+ rm(ysim)
+
+ temp3 = matrix(0, n, dimm(M))
+ for(ss in 1:M)
+ for(tt in ss:M)
+ temp3[,iam(ss,tt,M)] = -d2l.dthetas2[,ss,tt]
+
+ run.mean = ((ii-1) * run.mean + temp3) / ii
}
- wznew
- }), list(.lphi=lphi, .lmu=lmu))))
+ wz = if(intercept.only)
+ matrix(apply(run.mean,2,mean), n, dimm(M), byrow=TRUE) else run.mean
+
+ dtheta.detas = cbind(dphi.deta,dmu1.deta,dsd1.deta,dmu2.deta,dsd2.deta)
+ index0 = iam(NA, NA, M=M, both=TRUE, diag=TRUE)
+ wz = wz * dtheta.detas[,index0$row] * dtheta.detas[,index0$col]
+ w * wz
+ }), list(.lphi=lphi, .lmu=lmu, .nsimEIM=nsimEIM ))))
}
-mix2poisson.control <- function(save.weight=TRUE, ...)
+mix2poisson.control <- function(trace=TRUE, ...)
{
- list(save.weight=save.weight)
+ list(trace=trace)
}
mix2poisson = function(lphi="logit", llambda="loge",
ephi=list(), el1=list(), el2=list(),
iphi=0.5, il1=NULL, il2=NULL,
- qmu=c(0.2, 0.8), zero=1)
+ qmu=c(0.2, 0.8), nsimEIM=100, zero=1)
{
if(mode(lphi) != "character" && mode(lphi) != "name")
lphi = as.character(substitute(lphi))
@@ -209,15 +229,16 @@ mix2poisson = function(lphi="logit", llambda="loge",
if(!is.list(ephi)) ephi = list()
if(!is.list(el1)) el1 = list()
if(!is.list(el2)) el2 = list()
+ if(!is.Numeric(nsimEIM, allow=1, integ=TRUE) || nsimEIM <= 10)
+ stop("'nsimEIM' should be an integer greater than 10")
new("vglmff",
- blurb=c("Mixture of two univariate normals\n\n",
+ blurb=c("Mixture of two Poisson distributions\n\n",
"Links: ",
namesof("phi",lphi, earg= ephi), ", ",
namesof("lambda1", llambda, earg= el1, tag=FALSE), ", ",
namesof("lambda2", llambda, earg= el2, tag=FALSE), "\n",
- "Mean: phi*lambda1 + (1-phi)*lambda2\n",
- "Variance: phi*lambda1^2 + (1-phi)*lambda2^2 + phi*(1-phi)*(lambda1-lambda2)^2"),
+ "Mean: phi*lambda1 + (1-phi)*lambda2"),
constraints=eval(substitute(expression({
constraints = cm.zero.vgam(constraints, x, .zero, M)
}), list(.zero=zero ))),
@@ -225,19 +246,14 @@ mix2poisson = function(lphi="logit", llambda="loge",
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))
+ namesof("lambda1", .llambda, earg= .el1, tag=FALSE),
+ namesof("lambda2", .llambda, earg= .el2, tag=FALSE))
if(!length(etastart)) {
qy = quantile(y, prob= .qmu)
- init.phi = if(length(.iphi)) rep(.iphi, length=n) else {
- 0.5
- }
- init.lambda1 = if(length(.il1)) rep(.il1, length=n) else {
- rep(qy[1], length=n)
- }
- init.lambda2 = if(length(.il2)) rep(.il2, length=n) else {
- rep(qy[2], length=n)
- }
+ init.phi = rep(if(length(.iphi)) .iphi else 0.5, length=n)
+ init.lambda1 = rep(if(length(.il1)) .il1 else qy[1], length=n)
+ init.lambda2 = rep(if(length(.il2)) .il2 else qy[2], length=n)
+ if(!length(etastart))
etastart = cbind(theta2eta(init.phi, .lphi, earg= .ephi),
theta2eta(init.lambda1, .llambda, earg= .el1),
theta2eta(init.lambda2, .llambda, earg= .el2))
@@ -255,10 +271,10 @@ mix2poisson = function(lphi="logit", llambda="loge",
last=eval(substitute(expression({
misc$link = c("phi"= .lphi, "lambda1"= .llambda, "lambda2"= .llambda)
misc$earg = list("phi"= .ephi, "lambda1"= .el1, "lambda2"= .el2)
- misc$expected = FALSE
- misc$BFGS = TRUE
+ misc$expected = TRUE
+ misc$nsimEIM = .nsimEIM
}), list(.lphi=lphi, .llambda=llambda,
- .ephi=ephi, .el1=el1, .el2=el2 ))),
+ .ephi=ephi, .el1=el1, .el2=el2, .nsimEIM=nsimEIM ))),
loglikelihood=eval(substitute(
function(mu,y,w,residuals=FALSE,eta,extra=NULL) {
phi = eta2theta(eta[,1], link= .lphi, earg= .ephi)
@@ -275,6 +291,9 @@ mix2poisson = function(lphi="logit", llambda="loge",
phi = eta2theta(eta[,1], link= .lphi, earg= .ephi)
lambda1 = eta2theta(eta[,2], link= .llambda, earg= .el1)
lambda2 = eta2theta(eta[,3], link= .llambda, earg= .el2)
+ dphi.deta = dtheta.deta(phi, link= .lphi, earg= .ephi)
+ dlambda1.deta = dtheta.deta(lambda1, link= .llambda, earg= .el1)
+ dlambda2.deta = dtheta.deta(lambda2, link= .llambda, earg= .el2)
f1 = dpois(x=y, lam=lambda1)
f2 = dpois(x=y, lam=lambda2)
pdf = phi*f1 + (1-phi)*f2
@@ -283,40 +302,71 @@ mix2poisson = function(lphi="logit", llambda="loge",
dl.dphi = (f1-f2) / pdf
dl.dlambda1 = phi * df1.dlambda1 / pdf
dl.dlambda2 = (1-phi) * df2.dlambda2 / pdf
- dphi.deta = dtheta.deta(phi, link= .lphi, earg= .ephi)
- dlambda1.deta = dtheta.deta(lambda1, link= .llambda, earg= .el1)
- dlambda2.deta = dtheta.deta(lambda2, link= .llambda, earg= .el2)
- if(iter == 1) {
- etanew = eta
- } else {
- derivold = derivnew
- etaold = etanew
- etanew = eta
- }
- derivnew = w * cbind(dl.dphi * dphi.deta,
- dl.dlambda1 * dlambda1.deta,
- dl.dlambda2 * dlambda2.deta)
- derivnew
+ w * cbind(dl.dphi * dphi.deta,
+ dl.dlambda1 * dlambda1.deta,
+ dl.dlambda2 * dlambda2.deta)
}), list(.lphi=lphi, .llambda=llambda,
- .ephi=ephi, .el1=el1, .el2=el2 ))),
+ .ephi=ephi, .el1=el1, .el2=el2, .nsimEIM=nsimEIM ))),
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.mean = 0
+ for(ii in 1:( .nsimEIM )) {
+ ysim = ifelse(runif(n) < phi, rpois(n,lambda1), rpois(n,lambda2))
+ f1 = dpois(x=ysim, lam=lambda1)
+ f2 = dpois(x=ysim, lam=lambda2)
+ pdf = phi*f1 + (1-phi)*f2
+ df1.dlambda1 = dpois(ysim-1, lam=lambda1) - f1
+ df2.dlambda2 = dpois(ysim-1, lam=lambda2) - f2
+ dl.dphi = (f1-f2) / pdf
+ dl.dlambda1 = phi * df1.dlambda1 / pdf
+ dl.dlambda2 = (1-phi) * df2.dlambda2 / pdf
+ d2f1.dlambda12 = dpois(ysim-2,lambda1) - 2*dpois(ysim-1,lambda1) +
+ dpois(ysim,lambda1)
+ d2f2.dlambda22 = dpois(ysim-2,lambda2) - 2*dpois(ysim-1,lambda2) +
+ dpois(ysim,lambda2)
+ d2l.dphi2 = dl.dphi^2
+ d2l.dlambda12 = phi * (phi * df1.dlambda1^2 / pdf -
+ d2f1.dlambda12) / pdf
+ d2l.dlambda22 = (1-phi) * ((1-phi) * df2.dlambda2^2 / pdf -
+ d2f2.dlambda22) / pdf
+ d2l.dlambda1lambda2 = phi * (1-phi) *
+ df1.dlambda1 * df2.dlambda2 / pdf^2
+ d2l.dphilambda1 = df1.dlambda1 * (phi*(f1-f2)/pdf - 1) / pdf
+ d2l.dphilambda2 = df2.dlambda2 * ((1-phi)*(f1-f2)/pdf - 1) / pdf
+
+ rm(ysim)
+ temp3 = matrix(0, n, dimm(M))
+ temp3[,iam(1,1,M=3)] = d2l.dphi2
+ temp3[,iam(2,2,M=3)] = d2l.dlambda12
+ temp3[,iam(3,3,M=3)] = d2l.dlambda22
+ temp3[,iam(1,2,M=3)] = d2l.dphilambda1
+ temp3[,iam(1,3,M=3)] = d2l.dphilambda2
+ temp3[,iam(2,3,M=3)] = d2l.dlambda1lambda2
+ run.mean = ((ii-1) * run.mean + temp3) / ii
}
- wznew
- }), list(.lphi=lphi, .llambda=llambda))))
+ wz = if(intercept.only)
+ matrix(apply(run.mean,2,mean), n, dimm(M), byrow=TRUE) else run.mean
+
+ dtheta.detas = cbind(dphi.deta, dlambda1.deta, dlambda2.deta)
+ index0 = iam(NA, NA, M=M, both=TRUE, diag=TRUE)
+ wz = wz * dtheta.detas[,index0$row] * dtheta.detas[,index0$col]
+ w * wz
+ }), list(.lphi=lphi, .llambda=llambda,
+ .ephi=ephi, .el1=el1, .el2=el2, .nsimEIM=nsimEIM ))))
}
+
+
+
+mix2exp.control <- function(trace=TRUE, ...)
+{
+ list(trace=trace)
+}
+
mix2exp = function(lphi="logit", llambda="loge",
ephi=list(), el1=list(), el2=list(),
iphi=0.5, il1=NULL, il2=NULL,
- qmu=c(0.2, 0.8), zero=1)
+ qmu=c(0.8, 0.2), nsimEIM=100, zero=1)
{
if(mode(lphi) != "character" && mode(lphi) != "name")
lphi = as.character(substitute(lphi))
@@ -333,6 +383,8 @@ mix2exp = function(lphi="logit", llambda="loge",
if(!is.list(ephi)) ephi = list()
if(!is.list(el1)) el1 = list()
if(!is.list(el2)) el2 = list()
+ if(!is.Numeric(nsimEIM, allow=1, integ=TRUE) || nsimEIM <= 10)
+ stop("'nsimEIM' should be an integer greater than 10")
new("vglmff",
blurb=c("Mixture of two univariate exponentials\n\n",
@@ -348,24 +400,17 @@ mix2exp = function(lphi="logit", llambda="loge",
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))
+ namesof("lambda1", .llambda, earg= .el1,tag=FALSE),
+ namesof("lambda2", .llambda, earg= .el2,tag=FALSE))
if(!length(etastart)) {
qy = quantile(y, prob= .qmu)
- init.phi = if(length(.iphi)) rep(.iphi, length=n) else {
- 0.5
- }
- init.lambda1 = if(length(.il1)) rep(.il1, length=n) else {
- rep(qy[1], length=n)
- }
- init.lambda2 = if(length(.il2)) rep(.il2, length=n) else {
- rep(qy[2], length=n)
- }
+ init.phi = rep(if(length(.iphi)) .iphi else 0.5, length=n)
+ init.lambda1 = rep(if(length(.il1)) .il1 else 1/qy[1], length=n)
+ init.lambda2 = rep(if(length(.il2)) .il2 else 1/qy[2], length=n)
+ if(!length(etastart))
etastart = cbind(theta2eta(init.phi, .lphi, earg= .ephi),
theta2eta(init.lambda1, .llambda, earg= .el1),
theta2eta(init.lambda2, .llambda, earg= .el2))
- print("etastart[1:4,]")
- print( etastart[1:4,] )
}
}), list(.lphi=lphi, .llambda=llambda, .iphi=iphi, .il1=il1, .il2=il2,
.ephi=ephi, .el1=el1, .el2=el2,
@@ -380,9 +425,9 @@ mix2exp = function(lphi="logit", llambda="loge",
last=eval(substitute(expression({
misc$link = c("phi"= .lphi, "lambda1"= .llambda, "lambda2"= .llambda)
misc$earg = list("phi"= .ephi, "lambda1"= .el1, "lambda2"= .el2)
- misc$expected = FALSE
- misc$pooled.weight = pooled.weight
- }), list(.lphi=lphi, .llambda=llambda,
+ misc$expected = TRUE
+ misc$nsimEIM = .nsimEIM
+ }), list(.lphi=lphi, .llambda=llambda, .nsimEIM=nsimEIM,
.ephi=ephi, .el1=el1, .el2=el2 ))),
loglikelihood=eval(substitute(
function(mu,y,w,residuals=FALSE,eta,extra=NULL) {
@@ -400,89 +445,63 @@ mix2exp = function(lphi="logit", llambda="loge",
phi = eta2theta(eta[,1], link= .lphi, earg= .ephi)
lambda1 = eta2theta(eta[,2], link= .llambda, earg= .el1)
lambda2 = eta2theta(eta[,3], link= .llambda, earg= .el2)
- pdf1 = dexp(x=y, rate=lambda1) * phi
- pdf2 = dexp(x=y, rate=lambda2) * (1-phi)
- delta = pdf1 / (pdf1 + pdf2)
- expy = phi / lambda1 + (1-phi) / lambda2 # E(Y)
- expy2 = phi * 2 / lambda1^2 + (1-phi) * 2 / lambda2^2 # E(Y^2)
- dl.dphi = (delta - phi) / (phi * (1-phi))
- dl.dlambda1 = -(y - 1/lambda1) * delta
- dl.dlambda2 = -(y - 1/lambda2) * (1-delta)
dphi.deta = dtheta.deta(phi, link= .lphi, earg= .ephi)
dlambda1.deta = dtheta.deta(lambda1, link= .llambda, earg= .el1)
dlambda2.deta = dtheta.deta(lambda2, link= .llambda, earg= .el2)
+ f1 = dexp(x=y, rate=lambda1)
+ f2 = dexp(x=y, rate=lambda2)
+ pdf = phi*f1 + (1-phi)*f2
+ df1.dlambda1 = exp(-lambda1*y) - y * dexp(y, rate=lambda1)
+ df2.dlambda2 = exp(-lambda2*y) - y * dexp(y, rate=lambda2)
+ dl.dphi = (f1-f2) / pdf
+ dl.dlambda1 = phi * df1.dlambda1 / pdf
+ dl.dlambda2 = (1-phi) * df2.dlambda2 / pdf
w * cbind(dl.dphi * dphi.deta,
dl.dlambda1 * dlambda1.deta,
dl.dlambda2 * dlambda2.deta)
}), list(.lphi=lphi, .llambda=llambda,
.ephi=ephi, .el1=el1, .el2=el2 ))),
weight = eval(substitute(expression({
- d2phi.deta2 = d2theta.deta2(phi, link= .lphi, earg= .ephi)
- d2lambda1.deta2 = d2theta.deta2(lambda1, link= .llambda, earg= .el1)
- d2lambda2.deta2 = d2theta.deta2(lambda2, link= .llambda, earg= .el2)
- wz = matrix(0, n, dimm(M))
- d2l.dphi2 = ((delta-phi) / (phi*(1-phi)))^2
- d2l.dlambda12 = delta / lambda1^2 - delta * (1-delta) *
- (y - 1 / lambda1)^2
- d2l.dlambda22 = (1-delta) / lambda2^2 - delta * (1-delta) *
- (y - 1 / lambda2)^2
- d2l.dphidlambda1 = delta * (1-delta) *
- (y - 1 / lambda1) / (phi * (1-phi))
- d2l.dphidlambda2 = -delta * (1-delta) *
- (y - 1 / lambda2) / (phi * (1-phi))
- d2l.dlambda1dlambda2 = delta * (1-delta) *
- (y - 1 / lambda1) * (y - 1 / lambda2)
- wz[,iam(1,1,M)] = d2l.dphi2 * dphi.deta^2 - dl.dphi * d2phi.deta2
- wz[,iam(2,2,M)] = d2l.dlambda12 * dlambda1.deta^2 -
- dl.dlambda1 * d2lambda1.deta2
- wz[,iam(3,3,M)] = d2l.dlambda22 * dlambda2.deta^2 -
- dl.dlambda2 * d2lambda2.deta2
- wz[,iam(1,2,M)] = d2l.dphidlambda1 * dphi.deta * dlambda1.deta
- wz[,iam(1,3,M)] = d2l.dphidlambda2 * dphi.deta * dlambda2.deta
- wz[,iam(2,3,M)] = d2l.dlambda1dlambda2 * dlambda1.deta * dlambda2.deta
- wz = w * wz
-
-
-
-
- wz = matrix(0, n, dimm(M))
- d2l.dphi2 = ((delta-phi) / (phi*(1-phi)))^2
- d2l.dlambda12 = delta / lambda1^2 - delta * (1-delta) *
- (expy2 - 2 * expy / lambda1 + 1/lambda1^2)
- d2l.dlambda22 = (1-delta) / lambda2^2 - delta * (1-delta) *
- (expy2 - 2 * expy / lambda2 + 1/lambda2^2)
- d2l.dphidlambda1 = delta * (1-delta) *
- (expy - 1 / lambda1) / (phi * (1-phi))
- d2l.dphidlambda2 = -delta * (1-delta) *
- (expy - 1 / lambda2) / (phi * (1-phi))
- d2l.dlambda1dlambda2 = delta * (1-delta) *
- (expy2 - expy / lambda1 - expy / lambda2 +
- 1 / (lambda1 * lambda2))
- wz[,iam(1,1,M)] = d2l.dphi2 * dphi.deta^2
- wz[,iam(2,2,M)] = d2l.dlambda12 * dlambda1.deta^2
- wz[,iam(3,3,M)] = d2l.dlambda22 * dlambda2.deta^2
- wz[,iam(1,2,M)] = d2l.dphidlambda1 * dphi.deta * dlambda1.deta
- wz[,iam(1,3,M)] = d2l.dphidlambda2 * dphi.deta * dlambda2.deta
- wz[,iam(2,3,M)] = d2l.dlambda1dlambda2 * dlambda1.deta * dlambda2.deta
- print("wz[1:3,]")
- print( wz[1:3,] )
- wz = w * wz
-
-
-
- if(TRUE && intercept.only) {
- sumw = sum(w)
- for(i in 1:ncol(wz))
- wz[,i] = sum(wz[,i]) / sumw
- pooled.weight = TRUE
- wz = w * wz # Put back the weights
- } else
- pooled.weight = FALSE
- print("pooled wz[1:3,]")
- print( wz[1:3,] )
-
- wz
+ run.mean = 0
+ for(ii in 1:( .nsimEIM )) {
+ ysim = ifelse(runif(n) < phi, rexp(n,lambda1), rexp(n,lambda2))
+ f1 = dexp(x=ysim, rate=lambda1)
+ f2 = dexp(x=ysim, rate=lambda2)
+ pdf = phi*f1 + (1-phi)*f2
+ df1.dlambda1 = exp(-lambda1*ysim) - ysim * dexp(ysim, rate=lambda1)
+ df2.dlambda2 = exp(-lambda2*ysim) - ysim * dexp(ysim, rate=lambda2)
+ dl.dphi = (f1-f2) / pdf
+ dl.dlambda1 = phi * df1.dlambda1 / pdf
+ dl.dlambda2 = (1-phi) * df2.dlambda2 / pdf
+ d2f1.dlambda12 = ysim*(ysim*lambda1-2)*exp(-lambda1*ysim)
+ d2f2.dlambda22 = ysim*(ysim*lambda2-2)*exp(-lambda2*ysim)
+ d2l.dphi2 = dl.dphi^2
+ d2l.dlambda12 = phi * (phi * df1.dlambda1^2 / pdf -
+ d2f1.dlambda12) / pdf
+ d2l.dlambda22 = (1-phi) * ((1-phi) * df2.dlambda2^2 / pdf -
+ d2f2.dlambda22) / pdf
+ d2l.dlambda1lambda2 = phi * (1-phi) *
+ df1.dlambda1 * df2.dlambda2 / pdf^2
+ d2l.dphilambda1 = df1.dlambda1 * (phi*(f1-f2)/pdf - 1) / pdf
+ d2l.dphilambda2 = df2.dlambda2 * ((1-phi)*(f1-f2)/pdf - 1) / pdf
+ rm(ysim)
+ temp3 = matrix(0, n, dimm(M))
+ temp3[,iam(1,1,M=3)] = d2l.dphi2
+ temp3[,iam(2,2,M=3)] = d2l.dlambda12
+ temp3[,iam(3,3,M=3)] = d2l.dlambda22
+ temp3[,iam(1,2,M=3)] = d2l.dphilambda1
+ temp3[,iam(1,3,M=3)] = d2l.dphilambda2
+ temp3[,iam(2,3,M=3)] = d2l.dlambda1lambda2
+ run.mean = ((ii-1) * run.mean + temp3) / ii
+ }
+ wz = if(intercept.only)
+ matrix(apply(run.mean,2,mean), n, dimm(M), byrow=TRUE) else run.mean
+
+ dtheta.detas = cbind(dphi.deta, dlambda1.deta, dlambda2.deta)
+ index0 = iam(NA, NA, M=M, both=TRUE, diag=TRUE)
+ wz = wz * dtheta.detas[,index0$row] * dtheta.detas[,index0$col]
+ w * wz
}), list(.lphi=lphi, .llambda=llambda,
- .ephi=ephi, .el1=el1, .el2=el2))))
+ .ephi=ephi, .el1=el1, .el2=el2, .nsimEIM=nsimEIM ))))
}
diff --git a/R/family.nonlinear.q b/R/family.nonlinear.q
index 02317e8..bc42c64 100644
--- a/R/family.nonlinear.q
+++ b/R/family.nonlinear.q
@@ -1,5 +1,5 @@
# These functions are
-# Copyright (C) 1998-2007 T.W. Yee, University of Auckland. All rights reserved.
+# Copyright (C) 1998-2008 T.W. Yee, University of Auckland. All rights reserved.
diff --git a/R/family.normal.q b/R/family.normal.q
index 914ccf0..65fabe6 100644
--- a/R/family.normal.q
+++ b/R/family.normal.q
@@ -1,5 +1,5 @@
# These functions are
-# Copyright (C) 1998-2007 T.W. Yee, University of Auckland. All rights reserved.
+# Copyright (C) 1998-2008 T.W. Yee, University of Auckland. All rights reserved.
@@ -247,9 +247,11 @@ posnormal1 = function(lmean="identity", lsd="loge",
-dbetanorm = function(x, shape1, shape2, mean=0, sd=1, log.arg=FALSE) {
+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)
- stop("bad input for argument \"log.arg\"")
+ stop("bad input for argument \"log\"")
ans =
if(is.R() && log.arg) {
dnorm(x=x, mean=mean, sd=sd, log=TRUE) +
@@ -259,8 +261,7 @@ dbetanorm = function(x, shape1, shape2, mean=0, sd=1, log.arg=FALSE) {
} else {
dnorm(x=x, mean=mean, sd=sd) *
pnorm(q=x, mean=mean, sd=sd)^(shape1-1) *
- pnorm(q=x, mean=mean, sd=sd, lower=FALSE)^(shape2-1) /
- beta(shape1, shape2)
+ pnorm(q=x, mean=mean, sd=sd, lower=FALSE)^(shape2-1) / beta(shape1, shape2)
}
if(!is.R() && log.arg) ans = log(ans)
ans
@@ -486,3 +487,295 @@ 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))
+ stop("bad input for arguments 'a1' and 'a2'")
+ if(any(a1 <= 0 | a2 <= 0))
+ stop("arguments 'a1' and 'a2' must have positive values only")
+ ans = dnorm(x=x/(a1*sd) - mean/sd)/(a1*sd) +
+ dnorm(x=x/(a2*sd) + mean/sd)/(a2*sd)
+ ans[x < 0] = 0
+ ans[a1 <= 0 | a2 <= 0 | is.na(a1) | is.na(a2)] = NA
+ ans
+}
+
+pfnorm = function(q, mean=0, sd=1, a1=1, a2=1) {
+ if(!is.Numeric(a1, posit=TRUE) || !is.Numeric(a2, posit=TRUE))
+ stop("bad input for arguments 'a1' and 'a2'")
+ if(any(a1 <= 0 | a2 <= 0))
+ stop("arguments 'a1' and 'a2' must have positive values only")
+ L = max(length(q), length(mean), length(sd))
+ q = rep(q, len=L); mean = rep(mean, len=L); sd = rep(sd, len=L);
+ ifelse(q < 0, 0, pnorm(q=q/(a1*sd) - mean/sd) - pnorm(q=-q/(a2*sd) - mean/sd))
+}
+
+qfnorm = function(p, mean=0, sd=1, a1=1, a2=1, ...) {
+ if(!is.Numeric(p, posit=TRUE) || max(p) >= 1)
+ stop("bad input for argument \"p\"")
+ 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))
+ stop("arguments 'a1' and 'a2' must have positive values only")
+
+ L = max(length(p), length(mean), length(sd), length(a1), length(a2))
+ p = rep(p, len=L); mean = rep(mean, len=L); sd = rep(sd, len=L);
+ a1 = rep(a1, len=L); a2 = rep(a2, len=L);
+ ans = rep(0.0, len=L)
+ myfun = function(x, mean=0, sd=1, a1=1, a2=2, p)
+ pfnorm(q=x, mean=mean, sd=sd, a1=a1, a2=a2) - p
+ for(i in 1:L) {
+ mytheta = mean[i]/sd[i]
+ EY = sd[i] * ((a1[i]+a2[i]) * (mytheta * pnorm(mytheta) + dnorm(mytheta)) -
+ a2[i] * mytheta)
+ Upper = 2 * EY
+ while(pfnorm(q=Upper, mean=mean[i], sd=sd[i], a1=a1[i], a2=a2[i]) < p[i])
+ Upper = Upper + sd[i]
+ ans[i] = uniroot(f=myfun, lower=0, upper=Upper,
+ mean=mean[i], sd=sd[i], a1=a1[i], a2=a2[i], p=p[i], ...)$root
+ }
+ ans
+}
+
+rfnorm = function(n, mean=0, sd=1, a1=1, a2=1) {
+ if(!is.Numeric(n, integ=TRUE, posit=TRUE))
+ stop("bad input for argument \"n\"")
+ 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))
+ stop("arguments 'a1' and 'a2' must have positive values only")
+ X = rnorm(n, mean=mean, sd=sd)
+ pmax(a1 * X, -a2*X)
+}
+
+
+fnormal1 = function(lmean="identity", lsd="loge", emean=list(), esd=list(),
+ imean=NULL, isd=NULL, a1=1, a2=1, nsimEIM=500,
+ method.init=1, zero=NULL)
+{
+ 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))
+ stop("arguments 'a1' and 'a2' must each be a positive value")
+ 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")
+ lmean = as.character(substitute(lmean))
+ if(mode(lsd) != "character" && mode(lsd) != "name")
+ lsd = as.character(substitute(lsd))
+ 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)
+ stop("'nsimEIM' should be an integer greater than 10")
+ if(length(imean) && !is.Numeric(imean))
+ stop("bad input for 'imean'")
+ if(length(isd) && !is.Numeric(isd, posit=TRUE))
+ stop("bad input for 'isd'")
+
+ new("vglmff",
+ blurb=c("(Generalized) folded univariate normal distribution\n\n",
+ "Link: ",
+ namesof("mean", lmean, earg=emean, tag= TRUE), "; ",
+ namesof("sd", lsd, earg=esd, tag= TRUE)),
+ 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))
+ 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
+ lm.wfit(x=x, y=y, w=w, method="qr")
+
+
+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)
+ stddev = sqrt( sum(w * junk$resid^2) / junk$df.residual )
+ Ahat = m1d^2 / m2d
+ thetahat = sqrt(max(1/Ahat -1, 0.1))
+ mean.init = rep(if(length( .imean)) .imean else
+ thetahat * sqrt((stddev^2 + meany^2) * Ahat), len=n)
+ sd.init = rep(if(length( .isd)) .isd else
+ sqrt((stddev^2 + meany^2) * Ahat), len=n)
+}
+
+
+ stddev = sqrt( sum(w * junk$resid^2) / junk$df.residual )
+ meany = weighted.mean(y, w)
+ mean.init = rep(if(length( .imean)) .imean else
+ {if( .method.init == 1) median(y) else meany}, len=n)
+ sd.init = rep(if(length( .isd)) .isd else
+ {if( .method.init == 1) stddev else 1.2*sd(y)}, len=n)
+ etastart = cbind(theta2eta(mean.init, .lmean, earg= .emean),
+ theta2eta(sd.init, .lsd, earg= .esd))
+ }
+ }), list( .lmean=lmean, .lsd=lsd, .emean=emean, .esd=esd,
+ .imean=imean, .isd=isd, .a1=a1, .a2=a2,
+ .method.init=method.init ))),
+ inverse=eval(substitute(function(eta, extra=NULL) {
+ mymu = eta2theta(eta[,1], .lmean, earg= .emean)
+ mysd = eta2theta(eta[,2], .lsd, earg= .esd)
+ mytheta = mymu/mysd
+ mysd * (( .a1+ .a2) * (mytheta * pnorm(mytheta) +
+ dnorm(mytheta)) - .a2 * mytheta)
+ }, list( .lmean=lmean, .lsd=lsd, .emean=emean, .esd=esd, .a1=a1, .a2=a2 ))),
+ last=eval(substitute(expression({
+ misc$link = c("mu"= .lmean, "sd"= .lsd)
+ misc$earg = list("mu"= .emean, "sd"= .esd)
+ misc$expected = TRUE
+ misc$nsimEIM = .nsimEIM
+ misc$simEIM = TRUE
+ misc$method.init = .method.init
+ misc$a1 = .a1
+ misc$a2 = .a2
+ }), list( .lmean=lmean, .lsd=lsd, .emean=emean, .esd=esd,
+ .method.init=method.init, .nsimEIM=nsimEIM, .a1=a1, .a2=a2 ))),
+ loglikelihood=eval(substitute(
+ function(mu,y,w,residuals= FALSE,eta, extra=NULL) {
+ mymu = eta2theta(eta[,1], .lmean, earg= .emean)
+ mysd = eta2theta(eta[,2], .lsd, earg= .esd)
+ a1vec = .a1
+ a2vec = .a2
+ 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)))
+ }
+ }, list( .lmean=lmean, .lsd=lsd, .emean=emean, .esd=esd, .a1=a1, .a2=a2 ))),
+ vfamily=c("fnormal1"),
+ deriv=eval(substitute(expression({
+ mymu = eta2theta(eta[,1], .lmean, earg= .emean)
+ mysd = eta2theta(eta[,2], .lsd, earg= .esd)
+ dmu.deta = dtheta.deta(mymu, .lmean, earg= .emean)
+ dsd.deta = dtheta.deta(mysd, .lsd, earg= .esd)
+ a1vec = .a1
+ a2vec = .a2
+ d3 = deriv3(~ log((exp(-0.5*(y/(a1vec*mysd) - mymu/mysd)^2)/a1vec +
+ exp(-0.5*(y/(a2vec*mysd) +
+ mymu/mysd)^2)/a2vec)/(mysd*sqrt(2*pi))),
+ name=c("mymu","mysd"), hessian= FALSE)
+ eval.d3 = eval(d3)
+ dl.dthetas = attr(eval.d3, "gradient") # == cbind(dl.dmu, dl.dsd)
+ dtheta.detas = cbind(dmu.deta, dsd.deta)
+ w * dtheta.detas * dl.dthetas
+ }), list( .lmean=lmean, .lsd=lsd, .emean=emean, .esd=esd, .a1=a1, .a2=a2 ))),
+ weight=eval(substitute(expression({
+ de3 = deriv3(~ log((exp(-0.5*(ysim/(a1vec*mysd) - mymu/mysd)^2)/a1vec +
+ exp(-0.5*(ysim/(a2vec*mysd) + mymu/mysd)^2)/a2vec)/(mysd*sqrt(2*pi))),
+ name=c("mymu","mysd"), hessian= TRUE)
+ run.mean = 0
+ for(ii in 1:( .nsimEIM )) {
+ ysim = rfnorm(n=n, mean=mymu, sd=mysd, a1= a1vec, a2= a2vec)
+ eval.de3 = eval(de3)
+ d2l.dthetas2 = attr(eval.de3, "hessian")
+ rm(ysim)
+
+ temp3 = matrix(0, n, dimm(M))
+ for(ss in 1:M)
+ for(tt in ss:M)
+ temp3[,iam(ss,tt,M)] = -d2l.dthetas2[,ss,tt]
+
+ run.mean = ((ii-1) * run.mean + temp3) / ii
+ }
+
+ wz = if(intercept.only)
+ matrix(apply(run.mean,2,mean), n, dimm(M), byrow=TRUE) else run.mean
+
+ index0 = iam(NA, NA, M=M, both=TRUE, diag=TRUE)
+ wz = wz * dtheta.detas[,index0$row] * dtheta.detas[,index0$col]
+ w * wz
+ }), list( .nsimEIM=nsimEIM, .a1=a1, .a2=a2 ))))
+}
+
+
+
+
+
+lqnorm.control = function(trace=TRUE, ...)
+{
+ list(trace=trace)
+}
+
+
+lqnorm = function(qpower=2, link="identity", earg=list(),
+ method.init=1, imu=NULL, shrinkage.init=0.95)
+{
+ 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)
+ stop("bad input for argument 'qpower'")
+ 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 ||
+ shrinkage.init > 1) stop("bad input for argument \"shrinkage.init\"")
+
+ new("vglmff",
+ blurb=c("Minimizing the q-norm of residuals\n",
+ "Links: ",
+ namesof("Y1", link, earg=earg, tag= TRUE)),
+ initialize=eval(substitute(expression({
+ 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
+ paste("mu", 1:M, sep="")
+ predictors.names = namesof(predictors.names, link= .link,
+ earg= .earg, short=TRUE)
+ 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
+ .sinit * meany + (1 - .sinit) * y
+ }, len=n)
+ etastart = theta2eta(mean.init, link= .link, earg= .earg)
+ }
+ }), list( .method.init=method.init, .imu=imu, .sinit=shrinkage.init,
+ .link=link, .earg=earg ))),
+ inverse=eval(substitute(function(eta, extra=NULL) {
+ mu = eta2theta(eta, link= .link, earg= .earg)
+ mu
+ }, list( .link=link, .earg=earg ))),
+ last=eval(substitute(expression({
+ dy = dimnames(y)
+ if(!is.null(dy[[2]]))
+ dimnames(fit$fitted.values) = dy
+ misc$link = rep( .link, length=M)
+ names(misc$link) = predictors.names
+ misc$earg = list(mu = .earg)
+ misc$qpower = .qpower
+ misc$method.init = .method.init
+ misc$objectiveFunction = sum( w * (abs(y - mu))^(.qpower) )
+ }), list( .qpower=qpower,
+ .link=link, .earg=earg,
+ .method.init=method.init ))),
+ link=eval(substitute(function(mu, extra=NULL) {
+ theta2eta(mu, link= .link, earg=.earg)
+ }, list( .link=link, .earg=earg ))),
+ vfamily="lqnorm",
+ deriv=eval(substitute(expression({
+ dmu.deta = dtheta.deta(theta=mu, link=.link, earg= .earg )
+ myresid = y - mu
+ signresid = sign(myresid)
+ temp2 = (abs(myresid))^(.qpower-1)
+ .qpower * w * temp2 * signresid * dmu.deta
+ }), list( .qpower=qpower, .link=link, .earg=earg ))),
+ weight=eval(substitute(expression({
+ temp3 = (abs(myresid))^(.qpower-2)
+ wz = .qpower * (.qpower - 1) * w * temp3 * dmu.deta^2
+ wz
+ }), list( .qpower=qpower, .link=link, .earg=earg ))))
+}
+
+
+
+
+
diff --git a/R/family.positive.q b/R/family.positive.q
index b58b61c..36923fc 100644
--- a/R/family.positive.q
+++ b/R/family.positive.q
@@ -1,5 +1,5 @@
# These functions are
-# Copyright (C) 1998-2007 T.W. Yee, University of Auckland. All rights reserved.
+# Copyright (C) 1998-2008 T.W. Yee, University of Auckland. All rights reserved.
@@ -181,7 +181,7 @@ dpospois = function(x, lambda) {
stop("bad input for argument \"lambda\"")
L = max(length(x), length(lambda))
x = rep(x, len=L); lambda = rep(lambda, len=L);
- ans = ifelse(x==0, 0, dpois(x, lambda) / (1 - exp(-lambda)))
+ ans = ifelse(x==0, 0, -dpois(x, lambda) / expm1(-lambda))
ans
}
@@ -191,7 +191,7 @@ ppospois = function(q, lambda) {
stop("bad input for argument \"lambda\"")
L = max(length(q), length(lambda))
q = rep(q, len=L); lambda = rep(lambda, len=L);
- ifelse(q<1, 0, (ppois(q, lambda) - exp(-lambda)) / (1 - exp(-lambda)))
+ ifelse(q<1, 0, (ppois(q, lambda) - exp(-lambda)) / (-expm1(-lambda)))
}
qpospois = function(p, lambda) {
@@ -199,7 +199,7 @@ qpospois = function(p, lambda) {
stop("bad input for argument \"lambda\"")
if(!is.Numeric(p, posit=TRUE) || any(p >= 1))
stop("bad input for argument \"p\"")
- qpois(p * (1 - exp(-lambda)) + exp(-lambda), lambda)
+ qpois(p * (-expm1(-lambda)) + exp(-lambda), lambda)
}
@@ -222,11 +222,18 @@ rpospois = function(n, lambda) {
-pospoisson = function(link="loge", earg=list())
+pospoisson = function(link="loge", earg=list(), expected=TRUE,
+ ilambda=NULL, method.init=1)
{
if(!missing(link))
link = as.character(substitute(link))
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))
+ stop("bad input for argument \"ilambda\"")
+ if(!is.Numeric(method.init, allow=1, integ=TRUE, posit=TRUE) ||
+ method.init > 2) stop("argument \"method.init\" must be 1 or 2")
new("vglmff",
blurb=c("Positive-Poisson distribution\n\n",
@@ -238,40 +245,55 @@ pospoisson = function(link="loge", earg=list())
predictors.names = namesof(if(ncol(y)==1) "lambda"
else paste("lambda", 1:ncol(y), sep=""), .link,
earg= .earg, tag=FALSE)
+ if( .method.init == 1) {
+ lambda.init = apply(y, 2, weighted.mean, w=w)
+ lambda.init = matrix(lambda.init, n, ncol(y), byrow=TRUE)
+ } else {
+ lambda.init = -y / expm1(-y)
+ }
if(!length(etastart))
- etastart = theta2eta(y / (1-exp(-y)), .link, earg= .earg )
- }), list( .link=link, .earg= earg ))),
+ etastart = theta2eta(if(length( .ilambda)) (y*0 + .ilambda) else
+ lambda.init, .link, earg= .earg)
+ }), list( .link=link, .earg= earg,
+ .ilambda=ilambda, .method.init=method.init ))),
inverse=eval(substitute(function(eta, extra=NULL) {
lambda = eta2theta(eta, .link, earg= .earg )
- lambda / (1-exp(-lambda))
+ -lambda / expm1(-lambda)
}, list( .link=link, .earg= earg ))),
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="")
misc$earg = vector("list", M)
names(misc$earg) = names(misc$link)
for(ii in 1:M)
misc$earg[[ii]] = .earg
- }), list( .link=link, .earg= earg ))),
+ }), list( .link=link, .earg= earg, .expected=expected ))),
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
- sum(w * (-log1p(-exp(-lambda)) - lambda + y*log(lambda)))
+ sum(w * (y*log(lambda) - log1p(-exp(-lambda)) - lambda))
}, list( .link=link, .earg= earg ))),
vfamily=c("pospoisson"),
deriv=eval(substitute(expression({
- lambda = eta2theta(eta, .link, earg= .earg )
- dl.dlambda = y/lambda - 1 - 1/(exp(lambda)-1)
- dlambda.deta = dtheta.deta(lambda, .link, earg= .earg )
- w * dl.dlambda * dlambda.deta
+ lambda = eta2theta(eta, .link, earg= .earg )
+ temp = exp(lambda)
+ dl.dlambda = y/lambda - 1 - 1/(temp-1)
+ dlambda.deta = dtheta.deta(lambda, .link, earg= .earg )
+ w * dl.dlambda * dlambda.deta
}), list( .link=link, .earg= earg ))),
weight=eval(substitute(expression({
- temp = exp(lambda)
- ed2l.dlambda2 = -temp * (1/lambda - 1/(temp-1)) / (temp-1)
- wz = -w * (dlambda.deta^2) * ed2l.dlambda2
- wz
- }), list( .link=link, .earg= earg ))))
+ if( .expected ) {
+ ed2l.dlambda2 = temp * (1/lambda - 1/(temp-1)) / (temp-1)
+ wz = (dlambda.deta^2) * ed2l.dlambda2
+ } else {
+ d2l.dlambda2 = y/lambda^2 - temp/(temp-1)^2
+ d2lambda.deta2 = d2theta.deta2(lambda, .link, earg=.earg)
+ wz = (dlambda.deta^2) * d2l.dlambda2 - dl.dlambda * d2lambda.deta2
+ }
+ w * wz
+ }), list( .link=link, .earg= earg, .expected=expected ))))
}
diff --git a/R/family.qreg.q b/R/family.qreg.q
index 522374d..cb99344 100644
--- a/R/family.qreg.q
+++ b/R/family.qreg.q
@@ -1,5 +1,5 @@
# These functions are
-# Copyright (C) 1998-2007 T.W. Yee, University of Auckland. All rights reserved.
+# Copyright (C) 1998-2008 T.W. Yee, University of Auckland. All rights reserved.
@@ -31,20 +31,21 @@ lms.bcn <- function(percentiles=c(25,50,75),
init.sigma=NULL)
{
if(mode(link.sigma) != "character" && mode(link.sigma) != "name")
- link.sigma <- as.character(substitute(link.sigma))
+ link.sigma = as.character(substitute(link.sigma))
if(mode(link.mu) != "character" && mode(link.mu) != "name")
- link.mu <- as.character(substitute(link.mu))
+ link.mu = as.character(substitute(link.mu))
if(!is.list(emu)) emu = list()
if(!is.list(esigma)) esigma = list()
new("vglmff",
- blurb=c("LMS Quantile Regression (Box-Cox transformation to normality)\n",
+ blurb=c("LMS Quantile Regression ",
+ "(Box-Cox transformation to normality)\n",
"Links: ",
"lambda", ", ",
namesof("mu", link=link.mu, earg= emu), ", ",
namesof("sigma", link=link.sigma, earg= esigma)),
constraints=eval(substitute(expression({
- constraints <- cm.zero.vgam(constraints, x, .zero, M)
+ constraints = cm.zero.vgam(constraints, x, .zero, M)
}), list(.zero=zero))),
initialize=eval(substitute(expression({
if(ncol(cbind(y)) != 1)
@@ -52,7 +53,7 @@ lms.bcn <- function(percentiles=c(25,50,75),
if(any(y<0, na.rm = TRUE))
stop("negative responses not allowed")
- predictors.names <-
+ predictors.names =
c(namesof("lambda", "identity"),
namesof("mu", .link.mu, earg= .emu, short= TRUE),
namesof("sigma", .link.sigma, earg= .esigma, short= TRUE))
@@ -63,8 +64,8 @@ lms.bcn <- function(percentiles=c(25,50,75),
fv.init = c(predict(fit500, x=x[,min(ncol(x),2)])$y)
lambda.init = if(is.Numeric( .init.lambda)) .init.lambda else 1.0
- sigma.init <- if(is.null(.init.sigma)) {
- myratio <- ((y/fv.init)^lambda.init - 1) / lambda.init
+ sigma.init = if(is.null(.init.sigma)) {
+ myratio = ((y/fv.init)^lambda.init - 1) / lambda.init
if(is.Numeric( .dfsigma.init)) {
fit600 = vsmooth.spline(x=x[,min(ncol(x),2)], y=myratio^2,
w=w, df= .dfsigma.init)
@@ -73,7 +74,7 @@ lms.bcn <- function(percentiles=c(25,50,75),
sqrt(var(myratio))
} else .init.sigma
- etastart <- cbind(lambda.init,
+ etastart = cbind(lambda.init,
theta2eta(fv.init, .link.mu, earg= .emu),
theta2eta(sigma.init, .link.sigma, earg= .esigma))
}
@@ -85,18 +86,18 @@ lms.bcn <- function(percentiles=c(25,50,75),
.init.lambda=init.lambda,
.init.sigma=init.sigma))),
inverse=eval(substitute(function(eta, extra=NULL) {
- eta[,2] <- eta2theta(eta[,2], .link.mu, earg= .emu)
- eta[,3] <- eta2theta(eta[,3], .link.sigma, earg= .esigma)
+ eta[,2] = eta2theta(eta[,2], .link.mu, earg= .emu)
+ eta[,3] = eta2theta(eta[,3], .link.sigma, earg= .esigma)
qtplot.lms.bcn(percentiles= .percentiles, eta=eta)
}, list(.percentiles=percentiles,
.link.mu=link.mu,
.esigma=esigma, .emu=emu,
.link.sigma=link.sigma))),
last=eval(substitute(expression({
- misc$percentiles <- .percentiles
- misc$links <- c(lambda = "identity", mu = .link.mu, sigma = .link.sigma)
+ misc$percentiles = .percentiles
+ misc$links = c(lambda = "identity", mu = .link.mu, sigma = .link.sigma)
misc$earg = list(lambda = list(), mu = .emu, sigma = .esigma)
- misc$true.mu <- FALSE # $fitted is not a true mu
+ misc$true.mu = FALSE # $fitted is not a true mu
if(control$cdf) {
post$cdf = cdf.lms.bcn(y, eta0=matrix(c(lambda,mymu,sigma),
ncol=3, dimnames=list(dimnames(x)[[1]], NULL)))
@@ -107,10 +108,10 @@ lms.bcn <- function(percentiles=c(25,50,75),
.link.sigma=link.sigma))),
loglikelihood=eval(substitute(
function(mu,y,w, residuals= FALSE, eta, extra=NULL) {
- lambda <- eta[,1]
- mu <- eta2theta(eta[,2], .link.mu, earg= .emu)
- sigma <- eta2theta(eta[,3], .link.sigma, earg= .esigma)
- z <- ((y/mu)^lambda - 1) / (lambda * sigma)
+ lambda = eta[,1]
+ mu = eta2theta(eta[,2], .link.mu, earg= .emu)
+ sigma = eta2theta(eta[,3], .link.sigma, earg= .esigma)
+ z = ((y/mu)^lambda - 1) / (lambda * sigma)
if(residuals) stop("loglikelihood residuals not implemented yet") else
sum(w * (lambda * log(y/mu) - log(sigma) - 0.5*z^2))
}, list(.link.sigma=link.sigma,
@@ -118,31 +119,31 @@ lms.bcn <- function(percentiles=c(25,50,75),
.link.mu=link.mu))),
vfamily=c("lms.bcn", "lmscreg"),
deriv=eval(substitute(expression({
- lambda <- eta[,1]
- mymu <- eta2theta(eta[,2], .link.mu, earg= .emu)
- sigma <- eta2theta(eta[,3], .link.sigma, earg= .esigma)
- z <- ((y/mymu)^lambda - 1) / (lambda * sigma)
- z2m1 <- z * z - 1
- d1 <- z*(z - log(y/mymu) / sigma) / lambda - z2m1 * log(y/mymu)
- d2 <- z / (mymu * sigma) + z2m1 * lambda / mymu
- d2 <- d2 * dtheta.deta(mymu, .link.mu, earg= .emu)
- d3 <- z2m1 / sigma
- d3 <- d3 * dtheta.deta(sigma, .link.sigma, earg= .esigma)
+ lambda = eta[,1]
+ mymu = eta2theta(eta[,2], .link.mu, earg= .emu)
+ sigma = eta2theta(eta[,3], .link.sigma, earg= .esigma)
+ z = ((y/mymu)^lambda - 1) / (lambda * sigma)
+ z2m1 = z * z - 1
+ d1 = z*(z - log(y/mymu) / sigma) / lambda - z2m1 * log(y/mymu)
+ d2 = z / (mymu * sigma) + z2m1 * lambda / mymu
+ d2 = d2 * dtheta.deta(mymu, .link.mu, earg= .emu)
+ d3 = z2m1 / sigma
+ d3 = d3 * dtheta.deta(sigma, .link.sigma, earg= .esigma)
w * cbind(d1, d2, d3)
}), list(.link.sigma=link.sigma, .link.mu=link.mu,
.esigma=esigma, .emu=emu ))),
weight=eval(substitute(expression({
- wz <- matrix(as.numeric(NA), n, 6)
- wz[,iam(1,1,M)] <- (7 * sigma^2 / 4)
- wz[,iam(2,2,M)] <- (1 + 2*(lambda * sigma)^2) / (mymu*sigma)^2 *
+ wz = matrix(as.numeric(NA), n, 6)
+ wz[,iam(1,1,M)] = (7 * sigma^2 / 4)
+ wz[,iam(2,2,M)] = (1 + 2*(lambda * sigma)^2) / (mymu*sigma)^2 *
dtheta.deta(mymu, .link.mu, earg= .emu)^2
- wz[,iam(3,3,M)] <- (2 / sigma^2) *
+ wz[,iam(3,3,M)] = (2 / sigma^2) *
dtheta.deta(sigma, .link.sigma, earg= .esigma)^2
- wz[,iam(1,2,M)] <- (-1 / (2 * mymu)) *
+ wz[,iam(1,2,M)] = (-1 / (2 * mymu)) *
dtheta.deta(mymu, .link.mu, earg= .emu)
- wz[,iam(1,3,M)] <- (lambda * sigma) *
+ wz[,iam(1,3,M)] = (lambda * sigma) *
dtheta.deta(sigma, .link.sigma, earg= .esigma)
- wz[,iam(2,3,M)] <- (2 * lambda / (mymu * sigma)) *
+ wz[,iam(2,3,M)] = (2 * lambda / (mymu * sigma)) *
dtheta.deta(sigma, .link.sigma, earg= .esigma) *
dtheta.deta(mymu, .link.mu, earg= .emu)
wz * w
@@ -152,7 +153,7 @@ lms.bcn <- function(percentiles=c(25,50,75),
-lms.bcg <- function(percentiles=c(25,50,75),
+lms.bcg = function(percentiles=c(25,50,75),
zero=NULL,
link.mu="identity",
link.sigma="loge",
@@ -163,14 +164,15 @@ lms.bcg <- function(percentiles=c(25,50,75),
init.sigma=NULL)
{
if(mode(link.sigma) != "character" && mode(link.sigma) != "name")
- link.sigma <- as.character(substitute(link.sigma))
+ link.sigma = as.character(substitute(link.sigma))
if(mode(link.mu) != "character" && mode(link.mu) != "name")
- link.mu <- as.character(substitute(link.mu))
+ link.mu = as.character(substitute(link.mu))
if(!is.list(emu)) emu = list()
if(!is.list(esigma)) esigma = list()
new("vglmff",
- blurb=c("LMS Quantile Regression (Box-Cox transformation to a Gamma distribution)\n",
+ blurb=c("LMS Quantile Regression ",
+ "(Box-Cox transformation to a Gamma distribution)\n",
"Links: ",
"lambda",
", ",
@@ -178,7 +180,7 @@ lms.bcg <- function(percentiles=c(25,50,75),
", ",
namesof("sigma", link=link.sigma, earg= esigma)),
constraints=eval(substitute(expression({
- constraints <- cm.zero.vgam(constraints, x, .zero, M)
+ constraints = cm.zero.vgam(constraints, x, .zero, M)
}), list(.zero=zero))),
initialize=eval(substitute(expression({
if(ncol(cbind(y)) != 1)
@@ -186,7 +188,7 @@ lms.bcg <- function(percentiles=c(25,50,75),
if(any(y<0, na.rm = TRUE))
stop("negative responses not allowed")
- predictors.names <- c(namesof("lambda", "identity"),
+ predictors.names = c(namesof("lambda", "identity"),
namesof("mu", .link.mu, earg= .emu, short=TRUE),
namesof("sigma", .link.sigma, earg= .esigma, short=TRUE))
@@ -197,7 +199,7 @@ lms.bcg <- function(percentiles=c(25,50,75),
lambda.init = if(is.Numeric( .init.lambda)) .init.lambda else 1.0
- sigma.init <- if(is.null(.init.sigma)) {
+ sigma.init = if(is.null(.init.sigma)) {
myratio=((y/fv.init)^lambda.init-1)/lambda.init #~(0,var=sigma^2)
if(is.numeric( .dfsigma.init) && is.finite( .dfsigma.init)) {
fit600 = vsmooth.spline(x=x[,min(ncol(x),2)],
@@ -208,9 +210,9 @@ lms.bcg <- function(percentiles=c(25,50,75),
sqrt(var(myratio))
} else .init.sigma
- etastart <- cbind(lambda.init,
- theta2eta(fv.init, .link.mu, earg= .emu),
- theta2eta(sigma.init, .link.sigma, earg= .esigma))
+ etastart = cbind(lambda.init,
+ theta2eta(fv.init, .link.mu, earg= .emu),
+ theta2eta(sigma.init, .link.sigma, earg= .esigma))
}
}), list(.link.sigma=link.sigma,
.link.mu=link.mu,
@@ -220,18 +222,18 @@ lms.bcg <- function(percentiles=c(25,50,75),
.init.lambda=init.lambda,
.init.sigma=init.sigma))),
inverse=eval(substitute(function(eta, extra=NULL) {
- eta[,2] <- eta2theta(eta[,2], .link.mu, earg= .emu)
- eta[,3] <- eta2theta(eta[,3], .link.sigma, earg= .esigma)
+ eta[,2] = eta2theta(eta[,2], .link.mu, earg= .emu)
+ eta[,3] = eta2theta(eta[,3], .link.sigma, earg= .esigma)
qtplot.lms.bcg(percentiles= .percentiles, eta=eta)
}, list(.percentiles=percentiles,
.link.mu=link.mu,
.esigma=esigma, .emu=emu,
.link.sigma=link.sigma))),
last=eval(substitute(expression({
- misc$percentiles <- .percentiles
+ misc$percentiles = .percentiles
misc$link = c(lambda = "identity", mu = .link.mu, sigma = .link.sigma)
misc$earg = list(lambda = list(), mu = .emu, sigma = .esigma)
- misc$true.mu <- FALSE # $fitted is not a true mu
+ misc$true.mu = FALSE # $fitted is not a true mu
if(control$cdf) {
post$cdf = cdf.lms.bcg(y, eta0=matrix(c(lambda,mymu,sigma),
ncol=3, dimnames=list(dimnames(x)[[1]], NULL)))
@@ -242,11 +244,11 @@ lms.bcg <- function(percentiles=c(25,50,75),
.link.sigma=link.sigma))),
loglikelihood=eval(substitute(
function(mu,y,w, residuals= FALSE, eta, extra=NULL) {
- lambda <- eta[,1]
- mu <- eta2theta(eta[,2], .link.mu, earg= .emu)
- sigma <- eta2theta(eta[,3], .link.sigma, earg= .esigma)
- g <- (y/mu)^lambda
- theta <- 1 / (sigma * lambda)^2
+ lambda = eta[,1]
+ mu = eta2theta(eta[,2], .link.mu, earg= .emu)
+ sigma = eta2theta(eta[,3], .link.sigma, earg= .esigma)
+ g = (y/mu)^lambda
+ theta = 1 / (sigma * lambda)^2
if(residuals) stop("loglikelihood residuals not implemented yet") else
sum(w * (log(abs(lambda)) + theta*(log(theta)+log(g)-g) -
lgamma(theta) - log(y)))
@@ -255,19 +257,19 @@ lms.bcg <- function(percentiles=c(25,50,75),
.link.mu=link.mu))),
vfamily=c("lms.bcg", "lmscreg"),
deriv=eval(substitute(expression({
- lambda <- eta[,1]
- mymu <- eta2theta(eta[,2], .link.mu, earg= .emu)
- sigma <- eta2theta(eta[,3], .link.sigma, earg= .esigma)
+ lambda = eta[,1]
+ mymu = eta2theta(eta[,2], .link.mu, earg= .emu)
+ sigma = eta2theta(eta[,3], .link.sigma, earg= .esigma)
- g <- (y/mymu)^lambda
- theta <- 1 / (sigma * lambda)^2
- dd <- digamma(theta)
+ g = (y/mymu)^lambda
+ theta = 1 / (sigma * lambda)^2
+ dd = digamma(theta)
- dl.dlambda <- (1 + 2*theta*(dd+g-1-log(theta) -
+ dl.dlambda = (1 + 2*theta*(dd+g-1-log(theta) -
0.5 * (g+1)*log(g))) / lambda
- dl.dmu <- lambda * theta * (g-1) / mymu
- dl.dsigma <- 2*theta*(dd+g-log(theta * g)-1) / sigma
- dsigma.deta <- dtheta.deta(sigma, link=.link.sigma, earg= .esigma)
+ dl.dmu = lambda * theta * (g-1) / mymu
+ dl.dsigma = 2*theta*(dd+g-log(theta * g)-1) / sigma
+ dsigma.deta = dtheta.deta(sigma, link=.link.sigma, earg= .esigma)
cbind(dl.dlambda,
dl.dmu * dtheta.deta(mymu, link= .link.mu, earg= .emu),
@@ -275,27 +277,27 @@ lms.bcg <- function(percentiles=c(25,50,75),
}), list(.link.sigma=link.sigma, .link.mu=link.mu,
.esigma=esigma, .emu=emu ))),
weight=eval(substitute(expression({
- tt <- trigamma(theta)
+ tt = trigamma(theta)
- wz <- matrix(0, n, 6)
+ wz = matrix(0, n, 6)
if(TRUE) {
- part2 <- dd + 2/theta - 2*log(theta)
- wz[,iam(1,1,M)] <- (1 + theta*(tt*(1+4*theta) - 4*(1+1/theta) -
+ part2 = dd + 2/theta - 2*log(theta)
+ wz[,iam(1,1,M)] = (1 + theta*(tt*(1+4*theta) - 4*(1+1/theta) -
log(theta)*(2/theta - log(theta)) + dd*part2)) / lambda^2
} else {
- temp <- mean( g*(log(g))^2 )
- wz[,iam(1,1,M)] <- (4*theta*(theta*tt-1) -1+ theta*temp)/lambda^2
+ temp = mean( g*(log(g))^2 )
+ wz[,iam(1,1,M)] = (4*theta*(theta*tt-1) -1+ theta*temp)/lambda^2
}
- wz[,iam(2,2,M)] <- 1 / (mymu*sigma)^2 *
+ wz[,iam(2,2,M)] = 1 / (mymu*sigma)^2 *
dtheta.deta(mymu, .link.mu, earg= .emu)^2
- wz[,iam(3,3,M)] <- (4*theta*(theta*tt-1) / sigma^2) *
+ wz[,iam(3,3,M)] = (4*theta*(theta*tt-1) / sigma^2) *
dtheta.deta(sigma, .link.sigma, earg= .esigma)^2
- wz[,iam(1,2,M)] <- -theta * (dd + 1/theta - log(theta)) / mymu
- wz[,iam(1,2,M)] <- wz[,iam(1,2,M)] *
+ wz[,iam(1,2,M)] = -theta * (dd + 1/theta - log(theta)) / mymu
+ wz[,iam(1,2,M)] = wz[,iam(1,2,M)] *
dtheta.deta(mymu, .link.mu, earg= .emu)
- wz[,iam(1,3,M)] <- 2 * theta^1.5 * (2 * theta * tt - 2 -
+ wz[,iam(1,3,M)] = 2 * theta^1.5 * (2 * theta * tt - 2 -
1/theta) * dtheta.deta(sigma, .link.sigma, earg= .esigma)
wz * w
}), list(.link.sigma=link.sigma, .link.mu=link.mu,
@@ -303,11 +305,7 @@ lms.bcg <- function(percentiles=c(25,50,75),
}
-
-
-
-
-dy.dyj <- function(psi, lambda, epsilon=sqrt(.Machine$double.eps)) {
+dy.dpsi.yeojohnson = function(psi, lambda) {
L = max(length(psi), length(lambda))
psi = rep(psi, len=L); lambda = rep(lambda, len=L);
@@ -315,98 +313,98 @@ dy.dyj <- function(psi, lambda, epsilon=sqrt(.Machine$double.eps)) {
(1 - (2-lambda) * psi)^((lambda - 1)/(2-lambda)))
}
-dyj.dy <- function(y, lambda) {
+dyj.dy.yeojohnson = function(y, lambda) {
L = max(length(y), length(lambda))
y = rep(y, len=L); lambda = rep(lambda, len=L);
ifelse(y>0, (1 + y)^(lambda - 1), (1 - y)^(1 - lambda))
}
-yeo.johnson <- function(y, lambda, derivative=0,
+yeo.johnson = function(y, lambda, derivative=0,
epsilon=sqrt(.Machine$double.eps), inverse= FALSE)
{
- if(length(derivative)!=1 || derivative<0 || round(derivative)!=derivative)
- stop("derivative must be a non-negative integer")
- ans <- y
-
- if((length(epsilon) != 1) || (epsilon <= 0))
- stop("epsilon must be a single positive number")
- lambda <- rep(lambda, len=length(y)) # lambda may be of length 1
+ 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))
+ 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(inverse) {
if(derivative!=0)
stop("derivative must 0 when inverse=TRUE")
- index <- y >= 0 & abs(lambda) > epsilon
- ans[index] <- (y[index]*lambda[index] + 1)^(1/lambda[index]) - 1
- index <- y >= 0 & abs(lambda) <= epsilon
- ans[index] <- exp(y[index]) - 1
- index <- y < 0 & abs(lambda-2) > epsilon
- ans[index] <- 1-(-(2-lambda[index])*y[index]+1)^(1/(2-lambda[index]))
- index <- y < 0 & abs(lambda-2) <= epsilon
- ans[index] <- 1 - exp(-y[index])
+ 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))
+ ans[index] = expm1(y[index])
+ if(any(index <- y < 0 & abs(lambda-2) > epsilon))
+ ans[index] = 1-(-(2-lambda[index])*y[index]+1)^(1/(2-lambda[index]))
+ if(any(index <- y < 0 & abs(lambda-2) <= epsilon))
+ ans[index] = -expm1(-y[index])
return(ans)
}
if(derivative==0) {
- index <- y >= 0 & abs(lambda) > epsilon
- ans[index] <- ((y[index]+1)^(lambda[index]) - 1) / lambda[index]
- index <- y >= 0 & abs(lambda) <= epsilon
- ans[index] <- log(y[index]+1)
- index <- y < 0 & abs(lambda-2) > epsilon
- ans[index] <- -((-y[index]+1)^(2-lambda[index]) - 1) / (2-lambda[index])
- index <- y < 0 & abs(lambda-2) <= epsilon
- ans[index] <- -log(-y[index]+1)
+ 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))
+ ans[index] = log1p(y[index])
+ if(any(index <- y < 0 & abs(lambda-2) > epsilon))
+ ans[index] = -((-y[index]+1)^(2-lambda[index])-1)/(2-lambda[index])
+ if(any(index <- y < 0 & abs(lambda-2) <= epsilon))
+ ans[index] = -log1p(-y[index])
} else {
- psi <- yeo.johnson(y, lambda, derivative=derivative-1,
- epsilon=epsilon, inverse=inverse)
- index <- y >= 0 & abs(lambda) > epsilon
- ans[index] <- ( (y[index]+1)^(lambda[index]) *
- (log(y[index]+1))^(derivative) - derivative *
- psi[index] ) / lambda[index]
- index <- y >= 0 & abs(lambda) <= epsilon
- ans[index] <- (log(y[index]+1))^(derivative + 1) / (derivative + 1)
- index <- y < 0 & abs(lambda-2) > epsilon
- ans[index] <- -( (-y[index]+1)^(2-lambda[index]) *
- (-log(-y[index]+1))^(derivative) - derivative *
- psi[index] ) / (2-lambda[index])
- index <- y < 0 & abs(lambda-2) <= epsilon
- ans[index] <- (-log(-y[index]+1))^(derivative + 1) / (derivative + 1)
+ psi <- Recall(y=y, lambda=lambda, derivative=derivative-1,
+ epsilon=epsilon, inverse=inverse)
+ if(any(index <- y >= 0 & abs(lambda) > epsilon))
+ ans[index] = ( (y[index]+1)^(lambda[index]) *
+ (log1p(y[index]))^(derivative) - derivative *
+ psi[index] ) / lambda[index]
+ 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))
+ ans[index] = -( (-y[index]+1)^(2-lambda[index]) *
+ (-log1p(-y[index]))^(derivative) - derivative *
+ psi[index] ) / (2-lambda[index])
+ if(any(index <- y < 0 & abs(lambda-2) <= epsilon))
+ ans[index] = (-log1p(-y[index]))^(derivative + 1) / (derivative + 1)
}
ans
}
-dpsi.dlambda.yjn = function(psi, lambda, mymu, sigma, derivative=0, small=1e-8) {
+dpsi.dlambda.yjn = function(psi, lambda, mymu, sigma,
+ derivative=0, smallno=1.0e-8) {
- answer = matrix(as.numeric(NA), length(mymu), derivative+1)
+ if(!is.Numeric(derivative, allow=1, integ=TRUE) || derivative<0)
+ stop("'derivative' must be a non-negative integer")
+ if(!is.Numeric(smallno, allow=1, posit=TRUE))
+ stop("'smallno' must be a single positive number")
- if(length(psi) < length(lambda))
- psi = rep(psi, length=length(lambda))
+ 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)
+ answer = matrix(as.numeric(NA), L, derivative+1)
CC = psi >= 0
BB = ifelse(CC, lambda, -2+lambda)
- AA = 1 + psi * BB
-
- if(derivative>0) {
+ AA = psi * BB
+ temp8 = if(derivative > 0) {
answer[,1:derivative] =
Recall(psi=psi, lambda=lambda, mymu=mymu, sigma=sigma,
- derivative=derivative-1, small=small)
- temp8 = answer[,derivative] * derivative
+ derivative=derivative-1, smallno=smallno)
+ answer[,derivative] * derivative
} else {
- temp8 = 0
+ 0
}
+ answer[,1+derivative] = ((AA+1) * (log1p(AA)/BB)^derivative - temp8) / BB
- answer[,1+derivative] =
- (AA * (log(AA)/BB)^derivative -
- temp8) / BB
-
-
-
- pos = (CC & abs(lambda) <= small) | (!CC & abs(lambda-2) <= small)
+ pos = (CC & abs(lambda) <= smallno) | (!CC & abs(lambda-2) <= smallno)
if(any(pos))
- answer[pos,1+derivative] = (answer[pos,1]^(1+derivative))/(derivative+1)
-
-
-
+ answer[pos,1+derivative] = (answer[pos,1]^(1+derivative))/(derivative+1)
answer
}
@@ -527,6 +525,194 @@ gleg.weight.yjn.13 = function(z, lambda, mymu, sigma, derivmat=NULL) {
}
+
+lms.yjn2.control <- function(save.weight=TRUE, ...)
+{
+ list(save.weight=save.weight)
+}
+
+lms.yjn2 = function(percentiles=c(25,50,75),
+ zero=NULL,
+ link.lambda="identity",
+ link.mu="identity",
+ link.sigma="loge",
+ elambda=list(), emu=list(), esigma=list(),
+ dfmu.init=4,
+ dfsigma.init=2,
+ init.lambda=1.0,
+ init.sigma=NULL,
+ yoffset=NULL,
+ nsimEIM=250)
+{
+
+ if(mode(link.lambda) != "character" && mode(link.lambda) != "name")
+ link.lambda = as.character(substitute(link.lambda))
+ if(mode(link.mu) != "character" && mode(link.mu) != "name")
+ link.mu = as.character(substitute(link.mu))
+ if(mode(link.sigma) != "character" && mode(link.sigma) != "name")
+ link.sigma = as.character(substitute(link.sigma))
+ if(!is.list(elambda)) elambda = list()
+ if(!is.list(emu)) emu = list()
+ if(!is.list(esigma)) esigma = list()
+
+ new("vglmff",
+ blurb=c("LMS Quantile Regression (Yeo-Johnson transformation",
+ " to normality)\n",
+ "Links: ",
+ namesof("lambda", link=link.lambda, earg= elambda),
+ ", ",
+ namesof("mu", link=link.mu, earg= emu),
+ ", ",
+ namesof("sigma", link=link.sigma, earg= esigma)),
+ constraints=eval(substitute(expression({
+ constraints = cm.zero.vgam(constraints, x, .zero, M)
+ }), list(.zero=zero))),
+ initialize=eval(substitute(expression({
+ if(ncol(cbind(y)) != 1)
+ stop("response must be a vector or a one-column matrix")
+ predictors.names =
+ c(namesof("lambda", .link.lambda, earg= .elambda, short= TRUE),
+ namesof("mu", .link.mu, earg= .emu, short= TRUE),
+ namesof("sigma", .link.sigma, earg= .esigma, short= TRUE))
+
+ y.save = y
+ yoff = if(is.Numeric( .yoffset)) .yoffset else -median(y)
+ extra$yoffset = yoff
+ y = y + yoff
+
+ if(!length(etastart)) {
+ lambda.init = if(is.Numeric( .init.lambda)) .init.lambda else 1.
+
+ y.tx = yeo.johnson(y, lambda.init)
+ fv.init =
+ if(smoothok <- (length(unique(sort(x[,min(ncol(x),2)]))) > 7)) {
+ fit700=vsmooth.spline(x=x[,min(ncol(x),2)],
+ y=y.tx, w=w, df= .dfmu.init)
+ c(predict(fit700, x=x[,min(ncol(x),2)])$y)
+ } else {
+ rep(weighted.mean(y, w), len=n)
+ }
+
+ sigma.init = if(!is.Numeric(.init.sigma)) {
+ if(is.Numeric( .dfsigma.init) && smoothok) {
+ fit710 = vsmooth.spline(x=x[,min(ncol(x),2)],
+ y=(y.tx - fv.init)^2,
+ w=w, df= .dfsigma.init)
+ sqrt(c(abs(predict(fit710,
+ x=x[,min(ncol(x),2)])$y)))
+ } else {
+ sqrt( sum( w * (y.tx - fv.init)^2 ) / sum(w) )
+ }
+ } else
+ .init.sigma
+
+ etastart = matrix(0, n, 3)
+ etastart[,1] = theta2eta(lambda.init, .link.lambda, earg=.elambda)
+ etastart[,2] = theta2eta(fv.init, .link.mu, earg=.emu)
+ etastart[,3] = theta2eta(sigma.init, .link.sigma, earg=.esigma)
+
+ }
+ }), list(.link.lambda=link.lambda, .link.mu=link.mu, .link.sigma=link.sigma,
+ .elambda=elambda, .emu=emu, .esigma=esigma,
+ .dfmu.init=dfmu.init,
+ .dfsigma.init=dfsigma.init,
+ .init.lambda=init.lambda,
+ .yoffset=yoffset,
+ .init.sigma=init.sigma))),
+ inverse=eval(substitute(function(eta, extra=NULL) {
+ eta[,1] = eta2theta(eta[,1], .link.lambda, earg= .elambda)
+ eta[,3] = eta2theta(eta[,3], .link.sigma, earg= .esigma)
+ qtplot.lms.yjn(percentiles= .percentiles, eta=eta, yoffset= extra$yoff)
+ }, list(.percentiles=percentiles,
+ .esigma=esigma, .elambda=elambda,
+ .link.lambda=link.lambda,
+ .link.sigma=link.sigma))),
+ last=eval(substitute(expression({
+ misc$expected = TRUE
+ misc$nsimEIM = .nsimEIM
+ misc$percentiles = .percentiles
+ misc$link = c(lambda= .link.lambda, mu= .link.mu, sigma= .link.sigma)
+ misc$earg = list(lambda = .elambda, mu = .emu, sigma = .esigma)
+ misc$true.mu = FALSE # $fitted is not a true mu
+ misc[["yoffset"]] = extra$yoffset
+
+ y = y.save # Restore back the value; to be attached to object
+
+ if(control$cdf) {
+ post$cdf = cdf.lms.yjn(y + misc$yoffset,
+ eta0=matrix(c(lambda,mymu,sigma),
+ ncol=3, dimnames=list(dimnames(x)[[1]], NULL)))
+ }
+ }), list(.percentiles=percentiles,
+ .elambda=elambda, .emu=emu, .esigma=esigma,
+ .nsimEIM=nsimEIM,
+ .link.lambda=link.lambda, .link.mu=link.mu, .link.sigma=link.sigma ))),
+ loglikelihood=eval(substitute(
+ function(mu,y,w, residuals= FALSE, eta, extra=NULL) {
+ lambda = eta2theta(eta[,1], .link.lambda, earg= .elambda)
+ mu = eta2theta(eta[,2], .link.mu, earg= .emu)
+ sigma = eta2theta(eta[,3], .link.sigma, earg= .esigma)
+ psi = yeo.johnson(y, lambda)
+ 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,
+ .link.lambda=link.lambda, .link.mu=link.mu,
+ .link.sigma=link.sigma ))),
+ vfamily=c("lms.yjn2", "lmscreg"),
+ deriv=eval(substitute(expression({
+ lambda = eta2theta(eta[,1], .link.lambda, earg= .elambda)
+ mymu = eta2theta(eta[,2], .link.mu, earg= .emu)
+ sigma = eta2theta(eta[,3], .link.sigma, earg= .esigma)
+ dlambda.deta = dtheta.deta(lambda, link=.link.lambda, earg= .elambda)
+ dmu.deta = dtheta.deta(mymu, link=.link.mu, earg= .emu)
+ dsigma.deta = dtheta.deta(sigma, link=.link.sigma, earg= .esigma)
+
+ psi = yeo.johnson(y, lambda)
+ d1 = yeo.johnson(y, lambda, deriv=1)
+ AA = (psi - mymu) / sigma
+ dl.dlambda = -AA * d1 /sigma + sign(y) * log1p(abs(y))
+ dl.dmu = AA / sigma
+ dl.dsigma = (AA^2 -1) / sigma
+ dthetas.detas = cbind(dlambda.deta, dmu.deta, dsigma.deta)
+ w * cbind(dl.dlambda, dl.dmu, dl.dsigma) * dthetas.detas
+ }), list( .elambda=elambda, .emu=emu, .esigma=esigma,
+ .link.lambda=link.lambda, .link.mu=link.mu,
+ .link.sigma=link.sigma ))),
+ weight=eval(substitute(expression({
+
+
+ run.varcov = 0
+ ind1 = iam(NA, NA, M=M, both=TRUE, diag=TRUE)
+ for(ii in 1:( .nsimEIM )) {
+ psi = rnorm(n, mymu, sigma)
+ ysim = yeo.johnson(y=psi, lam=lambda, inv=TRUE)
+ d1 = yeo.johnson(ysim, lambda, deriv=1)
+ AA = (psi - mymu) / sigma
+ dl.dlambda = -AA * d1 /sigma + sign(ysim) * log1p(abs(ysim))
+ dl.dmu = AA / sigma
+ dl.dsigma = (AA^2 -1) / sigma
+ rm(ysim)
+ temp3 = cbind(dl.dlambda, dl.dmu, dl.dsigma)
+ run.varcov = ((ii-1) * run.varcov +
+ temp3[,ind1$row.index]*temp3[,ind1$col.index]) / ii
+ }
+
+ if(intercept.only)
+ run.varcov = matrix(apply(run.varcov, 2, mean),
+ nr=n, nc=ncol(run.varcov), byrow=TRUE)
+
+
+ wz = run.varcov * dthetas.detas[,ind1$row] * dthetas.detas[,ind1$col]
+ dimnames(wz) = list(rownames(wz), NULL) # Remove the colnames
+ wz * w
+ }), list(.link.sigma=link.sigma,
+ .esigma=esigma, .elambda=elambda,
+ .nsimEIM=nsimEIM,
+ .link.lambda=link.lambda))))
+}
+
+
lms.yjn <- function(percentiles=c(25,50,75),
zero=NULL,
link.lambda="identity",
@@ -544,9 +730,9 @@ lms.yjn <- function(percentiles=c(25,50,75),
if(mode(link.sigma) != "character" && mode(link.sigma) != "name")
- link.sigma <- as.character(substitute(link.sigma))
+ link.sigma = as.character(substitute(link.sigma))
if(mode(link.lambda) != "character" && mode(link.lambda) != "name")
- link.lambda <- as.character(substitute(link.lambda))
+ link.lambda = as.character(substitute(link.lambda))
if(!is.list(elambda)) elambda = list()
if(!is.list(esigma)) esigma = list()
@@ -555,37 +741,43 @@ lms.yjn <- function(percentiles=c(25,50,75),
stop("only rule=5 or 10 is supported")
new("vglmff",
- blurb=c("LMS Quantile Regression (Yeo-Johnson transformation to normality)\n",
+ blurb=c("LMS Quantile Regression ",
+ "(Yeo-Johnson transformation to normality)\n",
"Links: ",
namesof("lambda", link=link.lambda, earg= elambda),
", mu, ",
namesof("sigma", link=link.sigma, earg= esigma)),
constraints=eval(substitute(expression({
- constraints <- cm.zero.vgam(constraints, x, .zero, M)
+ constraints = cm.zero.vgam(constraints, x, .zero, M)
}), list(.zero=zero))),
initialize=eval(substitute(expression({
if(ncol(cbind(y)) != 1)
stop("response must be a vector or a one-column matrix")
- predictors.names <-
+ predictors.names =
c(namesof("lambda", .link.lambda, earg= .elambda, short= TRUE),
"mu",
namesof("sigma", .link.sigma, earg= .esigma, short= TRUE))
- y.save <- y
+ y.save = y
yoff = if(is.Numeric( .yoffset)) .yoffset else -median(y)
extra$yoffset = yoff
- y <- y + yoff
+ y = y + yoff
if(!length(etastart)) {
lambda.init = if(is.Numeric( .init.lambda)) .init.lambda else 1.0
y.tx = yeo.johnson(y, lambda.init)
- 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)
+ 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)
+ } else {
+ fv.init = rep(weighted.mean(y, w), len=n)
+ }
sigma.init = if(!is.Numeric(.init.sigma)) {
- if(is.Numeric( .dfsigma.init)) {
+ 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)
@@ -597,9 +789,9 @@ lms.yjn <- function(percentiles=c(25,50,75),
} else
.init.sigma
- etastart <- cbind(theta2eta(lambda.init, .link.lambda, earg= .elambda),
- fv.init,
- theta2eta(sigma.init, .link.sigma, earg= .esigma))
+ etastart = cbind(theta2eta(lambda.init,.link.lambda, earg=.elambda),
+ fv.init,
+ theta2eta(sigma.init, .link.sigma, earg=.esigma))
}
}), list(.link.sigma=link.sigma,
@@ -619,13 +811,13 @@ lms.yjn <- function(percentiles=c(25,50,75),
.link.lambda=link.lambda,
.link.sigma=link.sigma))),
last=eval(substitute(expression({
- misc$percentiles <- .percentiles
+ misc$percentiles = .percentiles
misc$link = c(lambda= .link.lambda, mu= "identity", sigma= .link.sigma)
misc$earg = list(lambda = .elambda, mu = list(), sigma = .esigma)
- misc$true.mu <- FALSE # $fitted is not a true mu
- misc[["yoffset"]] = extra$yoff # zz Splus6.0 bug: sometimes the name is lost
+ misc$true.mu = FALSE # $fitted is not a true mu
+ misc[["yoffset"]] = extra$yoff
- y <- y.save # Restore back the value; to be attached to object
+ y = y.save # Restore back the value; to be attached to object
if(control$cdf) {
post$cdf = cdf.lms.yjn(y + misc$yoffset,
@@ -638,30 +830,30 @@ lms.yjn <- function(percentiles=c(25,50,75),
.link.sigma=link.sigma))),
loglikelihood=eval(substitute(
function(mu,y,w, residuals= FALSE, eta, extra=NULL) {
- lambda <- eta2theta(eta[,1], .link.lambda, earg= .elambda)
- mu <- eta[,2]
- sigma <- eta2theta(eta[,3], .link.sigma, earg= .esigma)
- psi <- yeo.johnson(y, lambda)
+ lambda = eta2theta(eta[,1], .link.lambda, earg= .elambda)
+ mu = eta[,2]
+ sigma = eta2theta(eta[,3], .link.sigma, earg= .esigma)
+ psi = yeo.johnson(y, lambda)
if(residuals) stop("loglikelihood residuals not implemented yet") else
sum(w * (-log(sigma) - 0.5 * ((psi-mu)/sigma)^2 +
- (lambda-1) * sign(y) * log(abs(y)+1)))
+ (lambda-1) * sign(y) * log1p(abs(y))))
}, list( .esigma=esigma, .elambda=elambda,
.link.sigma=link.sigma, .link.lambda=link.lambda))),
vfamily=c("lms.yjn", "lmscreg"),
deriv=eval(substitute(expression({
- lambda <- eta2theta(eta[,1], .link.lambda, earg= .elambda)
- mymu <- eta[,2]
- sigma <- eta2theta(eta[,3], .link.sigma, earg= .esigma)
+ lambda = eta2theta(eta[,1], .link.lambda, earg= .elambda)
+ mymu = eta[,2]
+ sigma = eta2theta(eta[,3], .link.sigma, earg= .esigma)
- psi <- yeo.johnson(y, lambda)
- d1 <- yeo.johnson(y, lambda, deriv=1)
+ psi = yeo.johnson(y, lambda)
+ d1 = yeo.johnson(y, lambda, deriv=1)
AA = (psi - mymu) / sigma
- dl.dlambda <- -AA * d1 /sigma + sign(y) * log(abs(y)+1)
- dl.dmu <- AA / sigma
- dl.dsigma <- (AA^2 -1) / sigma
- dlambda.deta <- dtheta.deta(lambda, link=.link.lambda, earg= .elambda)
- dsigma.deta <- dtheta.deta(sigma, link=.link.sigma, earg= .esigma)
+ dl.dlambda = -AA * d1 /sigma + sign(y) * log1p(abs(y))
+ dl.dmu = AA / sigma
+ dl.dsigma = (AA^2 -1) / sigma
+ dlambda.deta = dtheta.deta(lambda, link=.link.lambda, earg= .elambda)
+ dsigma.deta = dtheta.deta(sigma, link=.link.sigma, earg= .esigma)
cbind(dl.dlambda * dlambda.deta,
dl.dmu,
@@ -669,7 +861,7 @@ lms.yjn <- function(percentiles=c(25,50,75),
}), list( .esigma=esigma, .elambda=elambda,
.link.sigma=link.sigma, .link.lambda=link.lambda ))),
weight=eval(substitute(expression({
- wz <- matrix(0, n, 6)
+ wz = matrix(0, n, 6)
wz[,iam(2,2,M)] = 1 / sigma^2
@@ -787,14 +979,14 @@ lms.yjn <- function(percentiles=c(25,50,75),
glag.weight.yjn.13(abscissae, lambda, mymu, sigma, temp9)
}
- 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
+ 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) {
wz[,iam(1,2,M)] = wz[,iam(1,3,M)] = 0
}
- wz[,iam(2,3,M)] <- wz[,iam(2,3,M)] * dsigma.deta
- wz[,iam(3,3,M)] <- wz[,iam(3,3,M)] * dsigma.deta^2
+ wz[,iam(2,3,M)] = wz[,iam(2,3,M)] * dsigma.deta
+ wz[,iam(3,3,M)] = wz[,iam(3,3,M)] * dsigma.deta^2
wz = wz * w
wz
@@ -813,7 +1005,7 @@ lmscreg.control <- function(cdf= TRUE, at.arg=NULL, x0=NULL, ...)
if(!is.logical(cdf)) {
warning("\"cdf\" is not logical; using TRUE instead")
- cdf = T
+ cdf = TRUE
}
list(cdf=cdf, at.arg=at.arg, x0=x0)
}
@@ -822,128 +1014,131 @@ lmscreg.control <- function(cdf= TRUE, at.arg=NULL, x0=NULL, ...)
-if(FALSE)
-lms.yjn1 = function(percentiles=c(25,50,75),
- zero=NULL,
- link.lambda="identity",
- dfmu.init=4,
- dfsigma.init=2,
- init.lambda=1.0,
- yoffset=NULL)
-{
- if(mode(link.lambda) != "character" && mode(link.lambda) != "name")
- link.lambda <- as.character(substitute(link.lambda))
+Wr1 <- function(r, w) ifelse(r <= 0, 1, w)
- new("vglmff",
- blurb=c("LMS Quantile Regression (Yeo-Johnson transformation to normality)\n",
- "Links: ",
- namesof("lambda", link=link.lambda, earg= elambda)),
- constraints=eval(substitute(expression({
- constraints <- cm.zero.vgam(constraints, x, .zero, M)
- }), list(.zero=zero))),
- initialize=eval(substitute(expression({
- predictors.names <- c(
- namesof("lambda", .link.lambda, earg= .elambda, short= TRUE))
- y.save <- y
- yoff = if(is.Numeric( .yoffset)) .yoffset else -median(y)
- extra$yoffset = yoff
- y <- y + yoff
+Wr2 <- function(r, w) (r <= 0) * 1 + (r > 0) * w
- if(!length(etastart)) {
- lambda.init = if(is.Numeric( .init.lambda)) .init.lambda else 1.0
+alsqreg.deviance = function(mu, y, w, residuals = FALSE, eta, extra=NULL) {
- y.tx = yeo.johnson(y, lambda.init)
- 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)
- extra$mymu = fv.init
+ M <- length(extra$w.als)
- sigma.init = if(TRUE) {
- if(is.Numeric( .dfsigma.init)) {
- fit710 = vsmooth.spline(x=x[,min(ncol(x),2)],
- y=(y.tx - fv.init)^2,
- w=w, df= .dfsigma.init)
- sqrt(c(abs(predict(fit710,
- x=x[,min(ncol(x),2)])$y)))
- } else {
- sqrt( sum( w * (y.tx - fv.init)^2 ) / sum(w) )
- }
- } else
- 1
- extra$sigma = sigma.init
+ if(M > 1) y = matrix(y,extra$n,extra$M)
- etastart <- cbind(theta2eta(lambda.init, .link.lambda, earg= .elambda))
- }
- }), list(.link.lambda=link.lambda,
- .dfmu.init=dfmu.init,
- .dfsigma.init=dfsigma.init,
- .init.lambda=init.lambda,
- .yoffset=yoffset,
- ))),
- inverse=eval(substitute(function(eta, extra=NULL) {
- eta = eta2theta(eta, .link.lambda, earg= .elambda)
- eta2 = extra$mymu
- eta3 = extra$sigma
- qtplot.lms.yjn(percentiles= .percentiles,
- eta=cbind(c(eta),eta2,eta3), yoffset= extra$yoff)
- }, list(.percentiles=percentiles,
- .link.lambda=link.lambda))),
- last=eval(substitute(expression({
- misc$percentiles <- .percentiles
- misc$link <- c(lambda = .link.lambda)
- misc$earg = list(lambda = list(), mu = .emu, sigma = .esigma)
- misc$true.mu <- FALSE # $fitted is not a true mu
- misc[["yoffset"]] = extra$yoff # zz Splus6.0 bug: sometimes the name is lost
+ devi = cbind((y - mu)^2)
+ 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))
+ } 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]))
+ }
+ if(is.logical(extra$individual) && extra$individual)
+ all.deviances else sum(all.deviances)
+}
- y <- y.save # Restore back the value; to be attached to object
- if(control$cdf) {
- post$cdf = cdf.lms.yjn(y + misc$yoffset,
- eta0=matrix(c(lambda,mymu,sigma),
- ncol=3, dimnames=list(dimnames(x)[[1]], NULL)))
+
+alsqreg <- function(w.als=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")
+ print("hi 13/3/08")
+ 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")
+ lexpectile = as.character(substitute(lexpectile))
+ if(!is.list(eexpectile)) eexpectile = list()
+ if(length(iexpectile) && !is.Numeric(iexpectile))
+ stop("bad input for argument 'iexpectile'")
+
+ new("vglmff",
+ blurb=c("Asymmetric least squares quantile regression\n\n",
+ "Links: ",
+ namesof("expectile", link=lexpectile, earg= eexpectile)),
+ constraints=eval(substitute(expression({
+ constraints = cm.vgam(matrix(1,M,1), x, .parallel, constraints)
+ }), list( .parallel=parallel ))),
+ deviance= function(mu, y, w, residuals = FALSE, eta, extra=NULL) {
+ alsqreg.deviance(mu=mu, y=y, w=w, residuals=residuals,
+ eta=eta, extra=extra)
+ },
+ initialize=eval(substitute(expression({
+ extra$w.als = .w.als
+ 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$n = n
+ extra$y.names = y.names = paste("w.als=", round(extra$w.als, 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)
+ rep(median(y), length=n) else
+ 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
+ lm.wfit(x=x, y=y, w=w, method="qr")
+ junk$fitted
+ }
+ if(length( .iexpectile))
+ mean.init = matrix( .iexpectile, n, M, byrow=TRUE)
+ etastart = matrix(theta2eta(mean.init, .lexpectile,
+ earg= .eexpectile), n, M)
}
- }), list(.percentiles=percentiles,
- .link.lambda=link.lambda))),
- loglikelihood=eval(substitute(
- function(mu,y,w, residuals= FALSE, eta, extra=NULL) {
- lambda <- eta2theta(eta, .link.lambda, earg= .elambda)
- mu <- extra$mymu
- sigma <- extra$sigma
- psi <- yeo.johnson(y, lambda)
- if(residuals) stop("loglikelihood residuals not implemented yet") else
- sum(w * (-log(sigma) - 0.5 * ((psi-mu)/sigma)^2))
- }, list(.link.lambda=link.lambda))),
- vfamily=c("lms.yjn", "lmscreg"),
+ }), list( .lexpectile=lexpectile, .eexpectile=eexpectile,
+ .iexpectile=iexpectile,
+ .method.init=method.init, .digw = digw, .w.als=w.als ))),
+ inverse=eval(substitute(function(eta, extra=NULL) {
+ ans = eta = as.matrix(eta)
+ for(ii in 1:ncol(eta))
+ ans[,ii] = eta2theta(eta[,ii], .lexpectile, earg= .eexpectile)
+ dimnames(ans) = list(dimnames(eta)[[1]], extra$y.names)
+ ans
+ }, list( .lexpectile=lexpectile, .eexpectile=eexpectile ))),
+ last=eval(substitute(expression({
+ misc$link = rep(.lexpectile, length=M)
+ names(misc$link) = extra$y.names
+ misc$earg = vector("list", M)
+ names(misc$earg) = names(misc$link)
+ misc$parallel = .parallel
+ misc$expected = TRUE
+ extra$percentile = numeric(M)
+ for(ii in 1:M)
+ extra$percentile[ii] = 100 * weighted.mean(myresid[,ii] <= 0, w)
+ names(extra$percentile) = names(misc$link)
+
+ extra$individual = TRUE
+ extra$deviance = alsqreg.deviance(mu=mu, y=y, w=w,
+ residuals=FALSE, eta=eta, extra=extra)
+ names(extra$deviance) = extra$y.names
+ }), list( .lexpectile=lexpectile, .eexpectile=eexpectile,
+ .parallel=parallel ))),
+ vfamily=c("alsqreg"),
deriv=eval(substitute(expression({
- lambda <- eta2theta(eta, .link.lambda, earg= .elambda)
- psi <- yeo.johnson(y, lambda)
-
- fit8 <- vsmooth.spline(x=x[,min(ncol(x),2)],y=psi,w=w, df= .dfmu.init)
- mymu = c(predict(fit8, x=x[,min(ncol(x),2)])$y)
- extra$mymu = mymu
- fit8 <- vsmooth.spline(x=x[,min(ncol(x),2)],y=(psi-mymu)^2,w=w,
- df= .dfsigma.init)
- sigma = sqrt(c(predict(fit8, x=x[,min(ncol(x),2)])$y))
- extra$sigma = sigma
-
- d1 <- yeo.johnson(y, lambda, deriv=1)
- AA = (psi - mymu) / sigma
-
- dl.dlambda = -AA * d1 / sigma
- warning("dl.dlambda is wrong")
- dlambda.deta <- dtheta.deta(lambda, link=.link.lambda, earg= .elambda)
- cbind(dl.dlambda * dlambda.deta) * w
- }), list(.dfmu.init=dfmu.init,
- .dfsigma.init=dfsigma.init,
- .elambda=stop("hi4"),
- .link.lambda=link.lambda))),
+ 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,
+ byrow=TRUE))
+ w * myresid * wor1 * dexpectile.deta
+ }), list( .lexpectile=lexpectile, .eexpectile=eexpectile ))),
weight=eval(substitute(expression({
- wz = (d1 / sigma)^2 # Approximate
- wz = ifelse(wz <= 0, 1.0e-9, wz)
- wz = wz * w
+ wz = w * wor1 * dexpectile.deta^2
wz
- }), list(.link.lambda=link.lambda))))
+ }), list( .lexpectile=lexpectile, .eexpectile=eexpectile ))))
}
@@ -952,208 +1147,650 @@ lms.yjn1 = function(percentiles=c(25,50,75),
-alsqreg <- function(w=1, method.init=1)
+
+
+
+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)
+
+ nz <- y > 0
+ devi = cbind(-(y - mu))
+ devi[nz] = devi[nz] + y[nz] * log(y[nz]/mu[nz])
+ if(residuals) {
+ stop("not sure here")
+ return(sign(y - mu) * sqrt(2 * abs(devi) * w) *
+ matrix(extra$w,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] = 2 * sum(w * devi[,ii] *
+ Wr1(myresid[,ii], w=extra$w.aml[ii]))
+ }
+ if(is.logical(extra$individual) && extra$individual)
+ all.deviances else sum(all.deviances)
+}
+
+
+amlpoisson <- function(w.aml=1, parallel=FALSE, method.init=1, digw=4,
+ link="loge", earg=list())
{
- w.arg = w
- if(!is.Numeric(w.arg, posit=TRUE, allow=1))
- stop("'w' must be a single positive number")
- lmean = "identity"
- emean = 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")
+ if(!is.Numeric(w.aml, posit=TRUE))
+ stop("'w.aml' must be a vector of positive values")
+ if(mode(link)!= "character" && mode(link)!= "name")
+ link = as.character(substitute(link))
+ if(!is.list(earg)) earg = list()
new("vglmff",
- blurb=c("Asymmetric least squares quantile regression\n\n"),
+ blurb=c("Poisson expectile regression by",
+ " asymmetric maximum likelihood estimation\n\n",
+ "Link: ", namesof("expectile", link, earg= earg)),
+ constraints=eval(substitute(expression({
+ constraints = cm.vgam(matrix(1,M,1), x, .parallel, constraints)
+ }), list( .parallel=parallel ))),
+ deviance= function(mu, y, w, residuals = FALSE, eta, extra=NULL) {
+ amlpoisson.deviance(mu=mu, y=y, w=w, residuals=residuals,
+ eta=eta, extra=extra)
+ },
initialize=eval(substitute(expression({
- predictors.names = c(namesof("w-regression plane",
- .lmean, earg=.emean, tag=FALSE))
- extra$w = .w.arg
+ extra$w.aml = .w.aml
if(ncol(y <- cbind(y)) != 1)
stop("response must be a vector or a one-column matrix")
+ extra$M = M = length(extra$w.aml) # Recycle if necessary
+ extra$n = n
+ extra$y.names = y.names = paste("w.aml=", round(extra$w.aml, dig=.digw),
+ sep="")
+ extra$individual = FALSE
+ predictors.names = c(namesof(paste("expectile(",y.names,")", sep=""),
+ .link, earg=.earg, tag=FALSE))
+
if(!length(etastart)) {
- mean.init = if( .method.init == 1)
- rep(median(y), length=n) else 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
- lm.wfit(x=x, y=y, w=w, method="qr")
- junk$fitted
- }
- etastart = cbind(theta2eta(mean.init, .lmean, earg= .emean))
+ mean.init = if( .method.init == 2)
+ rep(median(y), length=n) else
+ 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
+ lm.wfit(x=x, y=y, w=w, method="qr")
+ abs(junk$fitted)
+ }
+ etastart = matrix(theta2eta(mean.init, .link, earg= .earg), n, M)
}
- }), list( .lmean=lmean, .emean=emean, .method.init=method.init,
- .w.arg=w.arg ))),
+ }), list( .link=link, .earg=earg, .method.init=method.init,
+ .digw = digw, .w.aml=w.aml ))),
inverse=eval(substitute(function(eta, extra=NULL) {
- eta2theta(eta, .lmean, earg= .emean)
- }, list( .lmean=lmean, .emean=emean,
- .w.arg=w.arg ))),
+ mu.ans = eta = as.matrix(eta)
+ for(ii in 1:ncol(eta))
+ mu.ans[,ii] = eta2theta(eta[,ii], .link, earg= .earg)
+ dimnames(mu.ans) = list(dimnames(eta)[[1]], extra$y.names)
+ mu.ans
+ }, list( .link=link, .earg=earg ))),
last=eval(substitute(expression({
- misc$link = c("mu"= .lmean)
- misc$earg = list("mu"= .emean)
+ misc$link = rep(.link, length=M)
+ names(misc$link) = extra$y.names
+ misc$earg = vector("list", M)
+ names(misc$earg) = names(misc$link)
+ misc$parallel = .parallel
misc$expected = TRUE
- extra$percentile = 100 * weighted.mean(myresid <= 0, w)
- }), list( .lmean=lmean, .emean=emean,
- .w.arg=w.arg ))),
- loglikelihood=eval(substitute(
- function(mu,y,w,residuals= FALSE,eta, extra=NULL) {
- if(residuals) stop("loglikelihood residuals not implemented yet") else {
- Qw <- function(r, w, deriv.arg=0) {
- Wr <- function(r, w) ifelse(r <= 0, 1, w)
- switch(as.character(deriv.arg),
- "0"= Wr(r, w) * r^2,
- "1"= 2 * Wr(r, w) * r,
- stop("'deriv' not matched"))
- }
- myresid = y - mu
- -sum(w * Qw(myresid, .w.arg))
- }
- }, list( .lmean=lmean, .emean=emean,
- .w.arg=w.arg ))),
- vfamily=c("alsqreg"),
+ extra$percentile = numeric(M)
+ for(ii in 1:M)
+ extra$percentile[ii] = 100 * weighted.mean(myresid[,ii] <= 0, w)
+ names(extra$percentile) = names(misc$link)
+
+ extra$individual = TRUE
+ extra$deviance = amlpoisson.deviance(mu=mu, y=y, w=w,
+ residuals=FALSE, eta=eta, extra=extra)
+ names(extra$deviance) = extra$y.names
+ }), list( .link=link, .earg=earg, .parallel=parallel ))),
+ link=eval(substitute(function(mu, extra=NULL) {
+ theta2eta(mu, link= .link, earg= .earg)
+ }, list( .link=link, .earg=earg ))),
+ vfamily=c("amlpoisson"),
deriv=eval(substitute(expression({
- Wr <- function(r, w) ifelse(r <= 0, 1, w)
- mymu = eta2theta(eta, .lmean, earg= .emean)
- myresid = y - mymu
- temp1 = Wr(myresid, w= .w.arg)
- w * myresid * temp1
- }), list( .lmean=lmean, .emean=emean,
- .w.arg=w.arg ))),
+ mymu = eta2theta(eta, .link, earg= .earg)
+ dexpectile.deta = dtheta.deta(mymu, .link, earg=.earg)
+ myresid = matrix(y,extra$n,extra$M) - cbind(mu)
+ wor1 = Wr2(myresid, w= matrix(extra$w.aml, extra$n, extra$M,
+ byrow=TRUE))
+ w * myresid * wor1 * (dexpectile.deta / mymu)
+ }), list( .link=link, .earg=earg ))),
weight=eval(substitute(expression({
- wz = w * temp1
+ use.mu = mymu
+ use.mu[use.mu < .Machine$double.eps^(3/4)] = .Machine$double.eps^(3/4)
+ wz = w * wor1 * use.mu * (dexpectile.deta / mymu)^2
wz
- }), list( .lmean=lmean, .emean=emean,
- .w.arg=w.arg ))))
+ }), list( .link=link, .earg=earg ))))
}
+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)
+
+
+ devy <- y
+ nz <- y != 0
+ devy[nz] <- y[nz] * log(y[nz])
+ 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)) {
+ warning("fitted values close to 0 or 1")
+ smu <- mu[small]
+ sy <- y[small]
+ smu <- ifelse(smu < .Machine$double.eps, .Machine$double.eps, smu)
+ onemsmu <- ifelse((1 - smu) < .Machine$double.eps,
+ .Machine$double.eps, 1 - smu)
+ devmu[small] <- sy * log(smu) + (1 - sy) * log(onemsmu)
+ }
+ devi <- 2 * (devy - devmu)
+ if(residuals) {
+ stop("not sure here")
+ return(sign(y - mu) * sqrt(abs(devi) * w))
+ } else {
+ all.deviances = numeric(M)
+ myresid = matrix(y,extra$n,extra$M) - matrix(mu,extra$n,extra$M)
+ 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)
+ all.deviances else sum(all.deviances)
+}
+
-alspoisson <- function(link="loge", earg=list(),
- w=1, method.init=1)
+amlbinomial <- function(w.aml=1, parallel=FALSE, digw=4,
+ link="logit", earg=list())
{
- if(mode(link )!= "character" && mode(link )!= "name")
- link <- as.character(substitute(link))
+ if(!is.Numeric(w.aml, posit=TRUE))
+ stop("'w.aml' must be a vector of positive values")
+ if(mode(link)!= "character" && mode(link)!= "name")
+ link = as.character(substitute(link))
if(!is.list(earg)) earg = list()
- w.arg = w
- if(!is.Numeric(w.arg, posit=TRUE, allow=1))
- stop("'w' must be a single positive number")
- lmean = "identity"
- emean = list()
new("vglmff",
- blurb=c("Poisson distribution estimated by asymmetric least squares\n\n",
- "Link: ", namesof("mu", link, earg= earg), "\n",
- "Variance: mu"),
+ blurb=c("Logistic expectile regression by ",
+ "asymmetric maximum likelihood estimation\n\n",
+ "Link: ", namesof("expectile", link, earg= earg)),
+ constraints=eval(substitute(expression({
+ constraints = cm.vgam(matrix(1,M,1), x, .parallel, constraints)
+ }), list( .parallel=parallel ))),
deviance= function(mu, y, w, residuals = FALSE, eta, extra=NULL) {
- 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
- 2 * sum(w * devi)
+ amlbinomial.deviance(mu=mu, y=y, w=w, residuals=residuals,
+ eta=eta, extra=extra)
},
initialize=eval(substitute(expression({
- 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)) {
- paste("E[", dn2, "]", sep="")
- } else {
- paste("mu", 1:M, sep="")
+ {
+ NCOL = function (x)
+ if(is.array(x) && length(dim(x)) > 1 ||
+ is.data.frame(x)) ncol(x) else as.integer(1)
+
+ if(NCOL(y) == 1) {
+ if(is.factor(y)) y = y != levels(y)[1]
+ nn = rep(1, n)
+ 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))
+ stop("Number of successes must be integer-valued")
+ } 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)
+ w = w * nn
+ mustart = (0.5 + nn * y) / (1 + nn)
+ } else
+ stop("Response not of the right form")
}
- predictors.names = namesof(if(M>1) dn2 else "mu", .link,
- earg= .earg, short=TRUE)
- mu = pmax(y, 1/8)
- if(!length(etastart))
- etastart <- theta2eta(mu, link= .link, earg= .earg)
- }), list( .link=link,
- .earg=earg ))),
+
+ mustart = matrix(mustart, n, length( .w.aml ))
+
+ extra$w.aml = .w.aml
+ if(ncol(y <- cbind(y)) != 1)
+ stop("response must be a vector or a one-column matrix")
+ extra$M = M = length(extra$w.aml) # Recycle if necessary
+ extra$n = n
+ extra$y.names = y.names = paste("w.aml=", round(extra$w.aml, dig=.digw),
+ sep="")
+ extra$individual = FALSE
+ predictors.names = c(namesof(paste("expectile(",y.names,")", sep=""),
+ .link, earg=.earg, tag=FALSE))
+
+ }), list( .link=link, .earg=earg,
+ .digw = digw, .w.aml=w.aml ))),
inverse=eval(substitute(function(eta, extra=NULL) {
- mu = eta2theta(eta, link= .link, earg= .earg)
- mu
+ mu.ans = eta = as.matrix(eta)
+ for(ii in 1:ncol(eta))
+ mu.ans[,ii] = eta2theta(eta[,ii], .link, earg= .earg)
+ dimnames(mu.ans) = list(dimnames(eta)[[1]], extra$y.names)
+ mu.ans
}, list( .link=link, .earg=earg ))),
last=eval(substitute(expression({
+ misc$link = rep(.link, length=M)
+ names(misc$link) = extra$y.names
+ misc$earg = vector("list", M)
+ names(misc$earg) = names(misc$link)
+ misc$parallel = .parallel
misc$expected = TRUE
- misc$link = rep( .link, length=M)
- names(misc$link) = if(M>1) dn2 else "mu"
+ extra$percentile = numeric(M)
+ for(ii in 1:M)
+ extra$percentile[ii] = 100 * weighted.mean(myresid[,ii] <= 0, w)
+ names(extra$percentile) = names(misc$link)
+
+ extra$individual = TRUE
+ extra$deviance = amlbinomial.deviance(mu=mu, y=y, w=w,
+ residuals=FALSE, eta=eta, extra=extra)
+ names(extra$deviance) = extra$y.names
+ }), list( .link=link, .earg=earg, .parallel=parallel ))),
+ link=eval(substitute(function(mu, extra=NULL) {
+ theta2eta(mu, link= .link, earg= .earg)
+ }, list( .link=link, .earg=earg ))),
+ vfamily=c("amlbinomial"),
+ deriv=eval(substitute(expression({
+ mymu = eta2theta(eta, .link, earg= .earg)
+ use.mu = mymu
+ use.mu[use.mu < .Machine$double.eps^(3/4)] = .Machine$double.eps^(3/4)
+ dexpectile.deta = dtheta.deta(use.mu, .link, earg=.earg)
+ myresid = matrix(y,extra$n,extra$M) - cbind(mu)
+ wor1 = Wr2(myresid, w= matrix(extra$w.aml, extra$n, extra$M,
+ byrow=TRUE))
+ w * myresid * wor1 * (dexpectile.deta / (use.mu * (1-use.mu)))
+ }), list( .link=link, .earg=earg ))),
+ weight=eval(substitute(expression({
+ wz = w * wor1 * (dexpectile.deta^2 / (use.mu * (1-use.mu)))
+ wz
+ }), list( .link=link, .earg=earg ))))
+}
+
+
+
- extra$percentile = 100 * weighted.mean(myresid <= 0, w)
+
+
+
+
+
+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)
+
+ devy = cbind(-log(y) - 1)
+ devi = cbind(-log(mu) - y / mu)
+ if(residuals) {
+ stop("not sure here")
+ return(sign(y - mu) * sqrt(2 * abs(devi) * w) *
+ matrix(extra$w,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] = 2 * sum(w *
+ (devy[,ii] - devi[,ii]) *
+ Wr1(myresid[,ii], w=extra$w.aml[ii]))
+ }
+ if(is.logical(extra$individual) && extra$individual)
+ all.deviances else sum(all.deviances)
+}
+
+
+amlexponential <- function(w.aml=1, parallel=FALSE, method.init=1, digw=4,
+ link="loge", earg=list())
+{
+ if(!is.Numeric(w.aml, posit=TRUE))
+ stop("'w.aml' must be a vector of positive values")
+ if(mode(link)!= "character" && mode(link)!= "name")
+ link = as.character(substitute(link))
+ if(!is.list(earg)) earg = list()
+ if(!is.Numeric(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="")
+ predictors.names = c(namesof(
+ paste("expectile(", y.names,")", sep=""), link, earg=earg))
+ predictors.names = paste(predictors.names, collapse=", ")
+
+ new("vglmff",
+ blurb=c("Exponential expectile regression by",
+ " asymmetric maximum likelihood estimation\n\n",
+ "Link: ", predictors.names),
+ constraints=eval(substitute(expression({
+ constraints = cm.vgam(matrix(1,M,1), x, .parallel, constraints)
+ }), list( .parallel=parallel ))),
+ deviance= function(mu, y, w, residuals = FALSE, eta, extra=NULL) {
+ amlexponential.deviance(mu=mu, y=y, w=w, residuals=residuals,
+ eta=eta, extra=extra)
+ },
+ initialize=eval(substitute(expression({
+ extra$w.aml = .w.aml
+ if(ncol(y <- cbind(y)) != 1)
+ stop("response must be a vector or a one-column matrix")
+ if(any(y <= 0.0))
+ stop("all responses must be positive")
+ extra$M = M = length(extra$w.aml) # Recycle if necessary
+ extra$n = n
+ extra$y.names = y.names = paste("w.aml=", round(extra$w.aml, dig=.digw),
+ sep="")
+ extra$individual = FALSE
+ predictors.names = c(namesof(
+ paste("expectile(",y.names,")", sep=""), .link, earg=.earg, tag=FALSE))
+
+ if(!length(etastart)) {
+ mean.init = if( .method.init == 1)
+ rep(median(y), length=n) else
+ if( .method.init == 2)
+ rep(weighted.mean(y, w), length=n) else {
+ 1 / (y + 1)
+ }
+ etastart = matrix(theta2eta(mean.init, .link, earg= .earg), n, M)
+ }
+ }), list( .link=link, .earg=earg, .method.init=method.init,
+ .digw = digw, .w.aml=w.aml ))),
+ inverse=eval(substitute(function(eta, extra=NULL) {
+ mu.ans = eta = as.matrix(eta)
+ for(ii in 1:ncol(eta))
+ mu.ans[,ii] = eta2theta(eta[,ii], .link, earg= .earg)
+ dimnames(mu.ans) = list(dimnames(eta)[[1]], extra$y.names)
+ mu.ans
+ }, list( .link=link, .earg=earg ))),
+ last=eval(substitute(expression({
+ misc$link = rep(.link, length=M)
+ names(misc$link) = extra$y.names
misc$earg = vector("list", M)
names(misc$earg) = names(misc$link)
- for(ii in 1:M) misc$earg[[ii]] = .earg
- }), list( .link=link, .earg=earg ))),
+ misc$parallel = .parallel
+ misc$expected = TRUE
+ extra$percentile = numeric(M)
+ for(ii in 1:M)
+ extra$percentile[ii] = 100 * weighted.mean(myresid[,ii] <= 0, w)
+ names(extra$percentile) = names(misc$link)
+
+ extra$individual = TRUE
+ extra$deviance = amlexponential.deviance(mu=mu, y=y, w=w,
+ residuals=FALSE, eta=eta, extra=extra)
+ names(extra$deviance) = extra$y.names
+ }), list( .link=link, .earg=earg, .parallel=parallel ))),
link=eval(substitute(function(mu, extra=NULL) {
theta2eta(mu, link= .link, earg= .earg)
}, list( .link=link, .earg=earg ))),
+ vfamily=c("amlexponential"),
+ deriv=eval(substitute(expression({
+ mymu = eta2theta(eta, .link, earg= .earg)
+ bigy = matrix(y,extra$n,extra$M)
+ dl.dmu = (bigy - mymu) / mymu^2
+ dmu.deta = dtheta.deta(mymu, .link, earg=.earg)
+ myresid = bigy - cbind(mymu)
+ wor1 = Wr2(myresid, w= matrix(extra$w.aml, extra$n, extra$M,
+ byrow=TRUE))
+ w * wor1 * dl.dmu * dmu.deta
+ }), list( .link=link, .earg=earg ))),
+ weight=eval(substitute(expression({
+ ned2l.dmu2 = 1 / mymu^2
+ wz = w * wor1 * ned2l.dmu2 * dmu.deta^2
+ wz
+ }), list( .link=link, .earg=earg ))))
+}
- loglikelihood=eval(substitute(
- function(mu,y,w,residuals= FALSE,eta, extra=NULL) {
- if(residuals) stop("loglikelihood residuals not implemented yet") else {
- Qw <- function(r, w, deriv.arg=0) {
- Wr <- function(r, w) ifelse(r <= 0, 1, w)
- switch(as.character(deriv.arg),
- "0"= Wr(r, w) * r^2,
- "1"= 2 * Wr(r, w) * r,
- stop("'deriv' not matched"))
- }
- myresid = extra$z - mu
- -sum(w * Qw(myresid, .w.arg))
- }
- }, list( .lmean=lmean, .emean=emean,
- .w.arg=w.arg ))),
- vfamily="alspoisson",
- deriv=eval(substitute(expression({
- if( iter > 1) extra$z = z
- print("iter")
- print( iter )
- derivUsual =
- if( .link == "loge" && (any(mu < .Machine$double.eps))) {
- w * (y - mu)
- } else {
- lambda <- mu
- dl.dlambda <- (y-lambda) / lambda
- dlambda.deta <- dtheta.deta(theta=lambda, link= .link, earg= .earg)
- w * dl.dlambda * dlambda.deta
- }
+rho1check = function(u, tau=0.5)
+ u * (tau - (u <= 0))
- if(iter > 1) {
- Wr <- function(r, w) ifelse(r <= 0, 1, w)
- mymu = eta2theta(eta, .lmean, earg= .emean)
- myresid = z - mymu
- temp1 = Wr(myresid, w= wzUsual) # zz should the wt be wzUsual??
- temp1 = Wr(myresid, w= .w.arg) # zz should the wt be wzUsual??
- }
+dalaplace = function(x, location=0, scale=1, tau=0.5, kappa=sqrt(tau/(1-tau))) {
+ if(!is.Numeric(scale, posit=TRUE)) stop("\"scale\" must be positive")
+ if(!is.Numeric(kappa, posit=TRUE)) stop("\"kappa\" must be positive")
+ const = (sqrt(2) / scale) * kappa / (1 + kappa^2)
+ exponent = -(sqrt(2) / scale) * abs(x - location) *
+ ifelse(x >= location, kappa, 1/kappa)
+ const * exp(exponent)
+}
- if(iter %% 3 == 1) cat("=================\n")
- if(iter %% 3 == 1) derivUsual else w * myresid * temp1
- }), list( .link=link, .earg=earg, .w.arg=w.arg,
- .lmean=lmean, .emean=emean ))),
+ralaplace = function(n, location=0, scale=1, tau=0.5, kappa=sqrt(tau/(1-tau))) {
+ 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(kappa, posit=TRUE)) stop("\"kappa\" must be positive")
+ location = rep(location, len=n); scale= rep(scale, len=n)
+ kappa = rep(kappa, len=n);
+ U1 = runif(n)
+ U2 = runif(n)
+ location + scale * log(U1^kappa / U2^(1/kappa)) / sqrt(2)
+}
- weight=eval(substitute(expression({
- wzUsual =
- if( .link == "loge" && (any(mu < .Machine$double.eps))) {
- tmp600 = mu
- tmp600[tmp600 < .Machine$double.eps] = .Machine$double.eps
- w * tmp600
- } else {
- d2l.dlambda2 = 1 / lambda
- w * dlambda.deta^2 * d2l.dlambda2
+
+palaplace = function(q, location=0, scale=1, tau=0.5, kappa=sqrt(tau/(1-tau))) {
+ if(!is.Numeric(q))
+ stop("bad input for argument \"q\"")
+ if(!is.Numeric(location))
+ stop("bad input for argument \"location\"")
+ if(!is.Numeric(scale, posit=TRUE)) stop("\"scale\" must be positive")
+ if(!is.Numeric(kappa, posit=TRUE))
+ stop("bad input for argument \"kappa\"")
+ N = max(length(q), length(location), length(scale), length(kappa))
+ location = rep(location, len=N); scale= rep(scale, len=N)
+ kappa = rep(kappa, len=N); q= rep(q, len=N)
+ exponent = -(sqrt(2) / scale) * abs(q - location) *
+ ifelse(q >= location, kappa, 1/kappa)
+ temp = exp(exponent) / (1 + kappa^2)
+ ans = 1 - temp
+ index1 = (q < location)
+ ans[index1] = (kappa[index1])^2 * temp[index1]
+ ans
+}
+
+
+qalaplace = function(p, location=0, scale=1, tau=0.5, kappa=sqrt(tau/(1-tau))) {
+ if(!is.Numeric(p, posit=TRUE) || max(p) >= 1)
+ stop("bad input for argument \"p\"")
+ if(!is.Numeric(location))
+ stop("bad input for argument \"location\"")
+ if(!is.Numeric(scale, posit=TRUE)) stop("\"scale\" must be positive")
+ if(!is.Numeric(kappa, posit=TRUE))
+ stop("bad input for argument \"kappa\"")
+ N = max(length(p), length(location), length(scale), length(kappa))
+ location = rep(location, len=N); scale= rep(scale, len=N)
+ kappa = rep(kappa, len=N); p = rep(p, len=N)
+ ans = p
+ temp = kappa^2 / (1 + kappa^2)
+ index1 = (p <= temp)
+ exponent = p[index1] / temp[index1]
+ ans[index1] = location[index1] + (scale[index1] * kappa[index1]) *
+ log(exponent) / sqrt(2)
+ ans[!index1] = location[!index1] - (scale[!index1] / kappa[!index1]) *
+ (log1p((kappa[!index1])^2) + log1p(-p[!index1])) / sqrt(2)
+ ans
+}
+
+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)
+ stop("\"tau\" must have values in (0,1)")
+ const = tau * (1-tau) / scale
+ const * exp(-rho1check((x-location)/scale, tau=tau))
+}
+
+
+
+if(FALSE)
+rqregal = function(n, tau=0.5, location=0, scale=1) {
+ if(!is.Numeric(n, 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)
+ stop("\"tau\" must have values in (0,1)")
+ location = rep(location, len=n); scale= rep(scale, len=n)
+ r = runif(n)
+ location - sign(r-tau) * scale * log(2*ifelse(r < tau, r, 1-r))
+}
+
+
+
+if(FALSE)
+pqregal = function(q, tau=0.5, location=0, scale=1) {
+ if(!all(scale == 1))
+ stop("currently can only handle scale == 1")
+ if(!is.Numeric(q))
+ stop("bad input for argument \"q\"")
+ if(!is.Numeric(location))
+ stop("bad input for argument \"location\"")
+ if(!is.Numeric(scale, posit=TRUE)) stop("\"scale\" must be positive")
+ if(!is.Numeric(tau, posit=TRUE) || max(tau) >= 1)
+ stop("\"tau\" must have values in (0,1)")
+ N = max(length(q), length(tau), length(location), length(scale))
+ location = rep(location, len=N); scale= rep(scale, len=N)
+ tau = rep(tau, len=N); q= rep(q, len=N)
+ ans = tau * exp(-(location - q) * (1 - tau))
+ index1 = (q > location)
+ ans[index1] = (1 - (1-tau) * exp(-tau * (q - location)))[index1]
+ ans
+}
+
+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")
+ llocation = as.character(substitute(llocation))
+ 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)
+ stop("bad input for argument \"tau\"")
+ if(!is.list(elocation)) elocation = list()
+ if(mode(lscale) != "character" && mode(lscale) != "name")
+ lscale = as.character(substitute(lscale))
+ if(!is.list(escale)) escale = list()
+
+ new("vglmff",
+ blurb=c("Quantile REGression via an Asymmetric Laplace distribution\n\n",
+ "Links: ",
+ namesof("scale", lscale, earg=escale), ", ",
+ namesof("location", llocation, earg=elocation)),
+ constraints=eval(substitute(expression({
+ constraints = cm.vgam(matrix(1,M,1), x, .parallel, constraints)
+ }), list( .parallel=parallel ))),
+ initialize=eval(substitute(expression({
+ extra$tau = .tau
+ if(ncol(y <- cbind(y)) != 1)
+ stop("response must be a vector or a one-column matrix")
+ extra$M = M = 1 + length(extra$tau)
+ extra$n = n
+ extra$y.names = y.names = paste("tau=", round(extra$tau, dig=.digt),
+ sep="")
+ print("y.names")
+ print( y.names )
+ extra$individual = FALSE
+ predictors.names = c(
+ namesof("scale", .lscale, earg=.escale, tag=FALSE),
+ namesof(paste("quantile(",y.names,")", sep=""),
+ link = .llocation, earg=.elocation, tag=FALSE))
+
+ if(!length(etastart)) {
+ if( .method.init == 1) {
+ location.init = median(y)
+ } else {
+ location.init = y
+ }
+ location.init = if(length(.ilocation)) {
+ matrix( .ilocation, n, M-1, byrow=TRUE)
+ } else {
+ rep(location.init, len=n)
+ }
+ scale.init = rep(1.0, len=n)
+ etastart = cbind(
+ theta2eta(scale.init, .lscale, earg = .escale),
+ matrix(
+ theta2eta(location.init, .llocation, earg= .elocation), n, M-1))
}
- if(iter %% 3 == 1) wzUsual else w * temp1
- }), list( .link=link, .earg=earg,
- .lmean=lmean, .emean=emean,
- .w.arg=w.arg ))))
+ }), list( .method.init=method.init, .tau=tau, .digt=digt,
+ .elocation=elocation, .escale=escale,
+ .llocation=llocation, .lscale=lscale,
+ .ilocation=ilocation ))),
+ inverse=eval(substitute(function(eta, extra=NULL) {
+ eta = as.matrix(eta)
+ print("eta[1:5,]")
+ print( eta[1:5,] )
+ xi.ans = matrix(0, nrow(eta), ncol(eta)-1)
+ for(ii in 1:(ncol(eta)-1))
+ xi.ans[,ii] = eta2theta(eta[,ii+1], .llocation, earg= .elocation)
+ dimnames(xi.ans) = list(dimnames(eta)[[1]], extra$y.names)
+ xi.ans
+ }, list( .elocation=elocation, .llocation=llocation, .tau=tau,
+ .escale=escale, .lscale=lscale ))),
+ last=eval(substitute(expression({
+ misc$link = rep( .llocation, length=M)
+ names(misc$link) = extra$y.names
+ misc$earg = vector("list", M)
+ names(misc$earg) = names(misc$link)
+ extra$percentile = numeric(M)
+ for(ii in 1:M)
+ extra$percentile[ii] = 100 *
+ weighted.mean(ymat[,ii] - mu[,ii] <= 0, w)
+ names(extra$percentile) = names(misc$link)
+
+ misc$expected = TRUE
+ misc$RegCondOK = FALSE # Save this for later
+ misc$tau = .tau
+ }), list( .elocation=elocation, .llocation=llocation, .tau=tau,
+ .escale=escale, .lscale=lscale ))),
+ loglikelihood=eval(substitute(
+ function(mu,y,w,residuals= FALSE,eta, extra=NULL) {
+ locmat = eta2theta(eta[,-1,drop=FALSE], .llocation, earg= .elocation)
+ scalemat = matrix(eta2theta(eta[,1,drop=FALSE], .lscale,
+ earg= .escale), nrow=extra$n, ncol=extra$M - 1)
+ taumat = matrix(extra$tau, nrow=extra$n, ncol=extra$M - 1, byrow=TRUE)
+ ymat = matrix(y, nrow=extra$n, ncol=extra$M - 1)
+ 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,
+ .escale=escale, .lscale=lscale, .tau=tau ))),
+ vfamily=c("qregal"),
+ deriv=eval(substitute(expression({
+ ymat = matrix(y, nrow=extra$n, ncol=extra$M - 1)
+ taumat = matrix(extra$tau, nrow=extra$n, ncol=extra$M - 1, byrow=TRUE)
+ scalemat = matrix(eta2theta(eta[,1,drop=FALSE], .lscale,
+ earg= .escale), nrow=extra$n, ncol=extra$M - 1)
+ locmat = eta2theta(eta[,-1,drop=FALSE], .llocation, earg= .elocation)
+ dl.dlocation = taumat /scalemat
+ index1 = (ymat < locmat)
+ dl.dlocation[index1] = ((taumat - 1)/scalemat)[index1]
+ dlocation.deta = dtheta.deta(locmat, .llocation, earg= .elocation)
+ dscale.deta = dtheta.deta(scalemat, .lscale, earg= .escale)
+ w * cbind(dl.dlocation * dlocation.deta)
+ }), list( .tau=tau, .elocation=elocation, .llocation=llocation,
+ .escale=escale, .lscale=lscale ))),
+ weight=eval(substitute(expression({
+ wz = matrix(0, nrow=n, M) # Diagonal
+ ed2l.dlocation2 = taumat * (1 - taumat) / scalemat^2
+ ed2l.dscale2 = 2 * (3*taumat^2 - 3*taumat+1) / (scalemat^2 *
+ taumat * (1-taumat))
+ wz[,iam(1,1,M)] = ed2l.dscale2 * dscale.deta^2
+ wz[,-1] = ed2l.dlocation2 * dlocation.deta^2
+ w * wz
+ }), list( .tau=tau, .elocation=elocation, .llocation=llocation,
+ .escale=escale, .lscale=lscale ))))
}
+
+
diff --git a/R/family.rcqo.q b/R/family.rcqo.q
index dc289ce..16214dc 100644
--- a/R/family.rcqo.q
+++ b/R/family.rcqo.q
@@ -1,5 +1,5 @@
# These functions are
-# Copyright (C) 1998-2007 T.W. Yee, University of Auckland. All rights reserved.
+# Copyright (C) 1998-2008 T.W. Yee, University of Auckland. All rights reserved.
diff --git a/R/family.rrr.q b/R/family.rrr.q
index 10e3f70..8732474 100644
--- a/R/family.rrr.q
+++ b/R/family.rrr.q
@@ -1,5 +1,5 @@
# These functions are
-# Copyright (C) 1998-2007 T.W. Yee, University of Auckland. All rights reserved.
+# Copyright (C) 1998-2008 T.W. Yee, University of Auckland. All rights reserved.
diff --git a/R/family.survival.q b/R/family.survival.q
index d64ca7c..b26459a 100644
--- a/R/family.survival.q
+++ b/R/family.survival.q
@@ -1,5 +1,5 @@
# These functions are
-# Copyright (C) 1998-2007 T.W. Yee, University of Auckland. All rights reserved.
+# Copyright (C) 1998-2008 T.W. Yee, University of Auckland. All rights reserved.
diff --git a/R/family.ts.q b/R/family.ts.q
index 863b72e..12b114e 100644
--- a/R/family.ts.q
+++ b/R/family.ts.q
@@ -1,5 +1,5 @@
# These functions are
-# Copyright (C) 1998-2007 T.W. Yee, University of Auckland. All rights reserved.
+# Copyright (C) 1998-2008 T.W. Yee, University of Auckland. All rights reserved.
diff --git a/R/family.univariate.q b/R/family.univariate.q
index 20114c0..215a410 100644
--- a/R/family.univariate.q
+++ b/R/family.univariate.q
@@ -1,6 +1,5 @@
# These functions are
-# Copyright (C) 1998-2007 T.W. Yee, University of Auckland. All rights reserved.
-
+# Copyright (C) 1998-2008 T.W. Yee, University of Auckland. All rights reserved.
@@ -133,11 +132,19 @@ mccullagh89 = function(ltheta="rhobit", lnu="logoff",
+hzeta.control <- function(save.weight=TRUE, ...)
+{
+ list(save.weight=save.weight)
+}
+
+
-hzeta = function(link="loglog", earg=list(), init.alpha=NULL)
+hzeta = function(link="loglog", earg=list(), ialpha=NULL, nsimEIM=100)
{
- if(length(init.alpha) && !is.Numeric(init.alpha, positive=TRUE))
- stop("'init.alpha' must be > 0")
+ if(length(ialpha) && !is.Numeric(ialpha, positive=TRUE))
+ stop("'ialpha' must be > 0")
+ if(!is.Numeric(nsimEIM, allow=1, integ=TRUE) || nsimEIM <= 10)
+ stop("'nsimEIM' should be an integer greater than 10")
if(mode(link) != "character" && mode(link) != "name")
link = as.character(substitute(link))
@@ -146,7 +153,7 @@ hzeta = function(link="loglog", earg=list(), init.alpha=NULL)
new("vglmff",
blurb=c(
"Haight's Zeta distribution f(y) = (2y-1)^(-alpha) - (2y+1)^(-alpha),\n",
- " alpha>0, y=1,2,..\n\n",
+ " alpha>0, y=1,2,....\n\n",
"Link: ",
namesof("alpha", link, earg=earg), "\n\n",
"Mean: (1-2^(-alpha)) * zeta(alpha) if alpha>1",
@@ -157,17 +164,17 @@ hzeta = function(link="loglog", earg=list(), init.alpha=NULL)
if(ncol(cbind(y)) != 1)
stop("response must be a vector or a one-column matrix")
if(any(y < 1))
- stop("all y values must be in 1,2,3,...")
+ stop("all y values must be in 1,2,3,....")
predictors.names = namesof("alpha", .link, earg= .earg, tag=FALSE)
if(!length(etastart)) {
- ainit = if(length( .init.alpha)) .init.alpha else {
- if((meany <- mean(y)) < 1.5) 3.0 else
+ 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
}
- ainit = rep(ainit, length=n)
- etastart = theta2eta(ainit, .link, earg= .earg )
+ a.init = rep(a.init, length=n)
+ etastart = theta2eta(a.init, .link, earg= .earg )
}
- }), list( .link=link, .earg=earg, .init.alpha=init.alpha ))),
+ }), list( .link=link, .earg=earg, .ialpha=ialpha ))),
inverse=eval(substitute(function(eta, extra=NULL) {
alpha = eta2theta(eta, .link, earg= .earg )
mu = (1-2^(-alpha)) * zeta(alpha)
@@ -175,49 +182,50 @@ hzeta = function(link="loglog", earg=list(), init.alpha=NULL)
mu
}, list( .link=link, .earg=earg ))),
last=eval(substitute(expression({
- misc$d3 = d3 # because save.weights=F
misc$link = c(alpha= .link)
misc$earg = list(alpha= .earg)
- misc$pooled.weight = pooled.weight
- }), list( .link=link, .earg=earg ))),
+ misc$nsimEIM = .nsimEIM
+ }), list( .link=link, .earg=earg, .nsimEIM=nsimEIM ))),
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
- sum(w * log((2*y-1)^(-alpha) - (2*y+1)^(-alpha )))
+ sum(w * log((2*y-1)^(-alpha) - (2*y+1)^(-alpha)))
}, list( .link=link, .earg=earg ))),
vfamily=c("hzeta"),
deriv=eval(substitute(expression({
- if(iter==1) {
- d3 = deriv3(~ w * log((2*y-1)^(-alpha) - (2*y+1)^(-alpha)),
- "alpha", hessian= TRUE)
- }
-
alpha = eta2theta(eta, .link, earg= .earg )
+ dalpha.deta = dtheta.deta(alpha, .link, earg= .earg )
+ d3 = deriv3(~ log((2*y-1)^(-alpha) - (2*y+1)^(-alpha)),
+ "alpha", hessian=FALSE)
eval.d3 = eval(d3)
dl.dalpha = attr(eval.d3, "gradient")
- dalpha.deta = dtheta.deta(alpha, .link, earg= .earg )
- dl.dalpha * dalpha.deta
+ w * dl.dalpha * dalpha.deta
}), list( .link=link, .earg=earg ))),
- weight=eval(substitute(expression({
- d2l.dalpha2 = as.vector(attr(eval.d3, "hessian"))
- wz = -dalpha.deta^2 * d2l.dalpha2 -
- dl.dalpha * d2theta.deta2(alpha, .link, earg= .earg )
-
- if(FALSE && intercept.only) {
- sumw = sum(w)
- for(i in 1:ncol(wz))
- wz[,i] = sum(wz[,i]) / sumw
- pooled.weight = TRUE
- wz = w * wz # Put back the weights
- } else
- pooled.weight = FALSE
- c(wz)
- }), list( .link=link, .earg=earg ))))
+ weight = eval(substitute(expression({
+ sd3 = deriv3(~ log((2*ysim-1)^(-alpha) - (2*ysim+1)^(-alpha)),
+ "alpha", hessian=FALSE)
+ run.var = 0
+ for(ii in 1:( .nsimEIM )) {
+ ysim = rhzeta(n, alpha=alpha)
+ eval.sd3 = eval(sd3)
+ dl.dalpha = attr(eval.d3, "gradient")
+ rm(ysim)
+ temp3 = dl.dalpha
+ run.var = ((ii-1) * run.var + temp3^2) / ii
+ }
+ wz = if(intercept.only)
+ matrix(apply(cbind(run.var), 2, mean),
+ n, dimm(M), byrow=TRUE) else cbind(run.var)
+
+ wz = wz * dalpha.deta^2
+ w * wz
+ }), list( .nsimEIM=nsimEIM ))))
}
+
dhzeta = function(x, alpha)
{
if(!is.Numeric(alpha, posit=TRUE))
@@ -688,6 +696,7 @@ dirichlet = function(link="loge", earg=list(), zero=NULL)
misc$earg = vector("list", M)
names(misc$earg) = names(misc$link)
for(ii in 1:M) misc$earg[[ii]] = .earg
+ misc$expected = TRUE
}), list( .link=link, .earg=earg ))),
loglikelihood=eval(substitute(
function(mu,y,w,residuals= FALSE,eta, extra=NULL) {
@@ -875,7 +884,7 @@ zetaff = function(link="loge", earg=list(), init.p=NULL)
if(residuals) stop("loglikelihood residuals not implemented yet") else
sum(w * (-(pp+1) * log(y) - log(zeta(pp+1 ))))
}, list( .link=link, .earg=earg ))),
- vfamily=c("zeta"),
+ vfamily=c("zetaff"),
deriv=eval(substitute(expression({
pp = eta2theta(eta, .link, earg=.earg)
fred1 = zeta(pp+1)
@@ -1042,6 +1051,159 @@ zipf = function(N=NULL, link="loge", earg=list(), init.s=NULL)
+cauchy.control <- function(save.weight=TRUE, ...)
+{
+ list(save.weight=save.weight)
+}
+
+cauchy = function(llocation="identity", lscale="loge",
+ elocation=list(), escale=list(),
+ ilocation=NULL, iscale=NULL,
+ iprobs = seq(0.2, 0.8, by=0.2),
+ method.init=1, nsimEIM=NULL, zero=2)
+{
+ if(mode(llocation) != "character" && mode(llocation) != "name")
+ llocation = as.character(substitute(llocation))
+ if(mode(lscale) != "character" && mode(lscale) != "name")
+ lscale = as.character(substitute(lscale))
+ if(!is.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))
+ stop("bad input for argument \"zero\"")
+ 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))
+ stop("bad input for argument \"iscale\"")
+ 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"),
+ constraints=eval(substitute(expression({
+ constraints = cm.zero.vgam(constraints, x, .zero, M)
+ }), list( .zero=zero ))),
+ initialize=eval(substitute(expression({
+ predictors.names = c(
+ namesof("location", .llocation, earg=.elocation, tag=FALSE),
+ namesof("scale", .lscale, earg=.escale, tag=FALSE))
+ 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 {
+ 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
+ sum(w * (-log1p(((y-loc)/scal)^2) - log(scal)))
+ }
+ loc.grid = c(quantile(y, probs=seq(0.1, 0.9, by=0.05)))
+ try.this = getMaxMin(loc.grid, objfun=cauchy2.Loglikfun,
+ y=y, x=x, w=w)
+ try.this = rep(c(try.this), len=n)
+ try.this
+ }
+ }
+ loc.init = rep(c(loc.init), len=n)
+
+
+ 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
+ sca.init
+ }
+
+ sca.init = rep(c(sca.init), len=n)
+ if(.llocation == "loge") loc.init = abs(loc.init)+0.01
+ etastart = cbind(theta2eta(loc.init, .llocation, earg=.elocation),
+ theta2eta(sca.init, .lscale, earg=.escale))
+ }
+ }), list( .ilocation=ilocation, .elocation=elocation, .llocation=llocation,
+ .iscale=iscale, .escale=escale, .lscale=lscale,
+ .iprobs=iprobs, .method.init=method.init ))),
+ inverse=eval(substitute(function(eta, extra=NULL) {
+ eta2theta(eta[,1], .llocation, earg= .elocation)
+ }, list( .llocation=llocation,
+ .elocation=elocation ))),
+ last=eval(substitute(expression({
+ misc$expected = TRUE
+ misc$link = c("location"= .llocation, "scale"=.lscale)
+ misc$earg = list(location= .elocation, scale= .escale)
+ }), list( .escale=escale, .elocation=elocation,
+ .llocation=llocation, .lscale=lscale ))),
+ loglikelihood=eval(substitute(
+ function(mu,y,w,residuals= FALSE,eta, extra=NULL) {
+ location = eta2theta(eta[,1], .llocation, earg=.elocation)
+ myscale = eta2theta(eta[,2], .lscale, earg=.escale)
+ Z = (y-location)/ myscale
+ if(residuals) stop("loglikelihood residuals not implemented yet") else
+ sum(w * (-log1p(Z^2) - log(pi) - log(myscale)))
+ }, list( .escale=escale, .lscale=lscale,
+ .elocation=elocation, .llocation=llocation ))),
+ vfamily=c("cauchy"),
+ deriv=eval(substitute(expression({
+ location = eta2theta(eta[,1], .llocation, earg=.elocation)
+ myscale = eta2theta(eta[,2], .lscale, earg=.escale)
+ dlocation.deta = dtheta.deta(location, .llocation, earg=.elocation)
+ dscale.deta = dtheta.deta(myscale, .lscale, earg=.escale)
+ Z = (y-location) / myscale
+ dl.dlocation = 2 * Z / ((1 + Z^2) * myscale)
+ dl.dscale = (Z^2 - 1) / ((1 + Z^2) * myscale)
+ w * cbind(dl.dlocation * dlocation.deta,
+ dl.dscale * dscale.deta)
+ }), list( .escale=escale, .lscale=lscale,
+ .elocation=elocation, .llocation=llocation ))),
+ weight=eval(substitute(expression({
+ run.varcov = 0
+ ind1 = iam(NA, NA, M=M, both=TRUE, diag=TRUE)
+ dthetas.detas = cbind(dlocation.deta, dscale.deta)
+ if(length( .nsimEIM )) {
+ for(ii in 1:( .nsimEIM )) {
+ ysim = rcauchy(n, loc=location, scale=myscale)
+ Z = (ysim-location) / myscale
+ dl.dlocation = 2 * Z / ((1 + Z^2) * myscale)
+ dl.dscale = (Z^2 - 1) / ((1 + Z^2) * myscale)
+ rm(ysim)
+ temp3 = matrix(c(dl.dlocation, dl.dscale), n, 2)
+ run.varcov = ((ii-1) * run.varcov +
+ temp3[,ind1$row.index]*temp3[,ind1$col.index]) / ii
+ }
+ wz = if(intercept.only)
+ matrix(apply(run.varcov, 2, mean),
+ n, ncol(run.varcov), byrow=TRUE) else run.varcov
+
+ wz = wz * dthetas.detas[,ind1$row] * dthetas.detas[,ind1$col]
+ wz = w * matrix(wz, n, dimm(M))
+ } else {
+ wz = cbind(matrix(0.5 / myscale^2,n,2), matrix(0,n,1)) *
+ dthetas.detas[,ind1$row] * dthetas.detas[,ind1$col]
+ wz = w * wz[,1:M] # diagonal wz
+ }
+
+ wz
+ }), list( .escale=escale, .lscale=lscale, .nsimEIM=nsimEIM,
+ .elocation=elocation, .llocation=llocation ))))
+}
+
+
@@ -1060,7 +1222,8 @@ cauchy1 = function(scale.arg=1, llocation="identity",
if(!is.list(elocation)) elocation = list()
new("vglmff",
- blurb=c("One parameter Cauchy distribution (location unknown, scale known)\n\n",
+ blurb=c("One-parameter Cauchy distribution ",
+ "(location unknown, scale known)\n\n",
"Link: ",
namesof("location", llocation, earg=elocation), "\n\n",
"Mean: NA\n",
@@ -1093,10 +1256,12 @@ cauchy1 = function(scale.arg=1, llocation="identity",
}), list( .scale.arg=scale.arg, .ilocation=ilocation,
.elocation=elocation, .llocation=llocation,
.method.init=method.init ))),
- inverse=function(eta, extra=NULL) {
- rep(as.numeric(NA), length(eta))
- },
+ inverse=eval(substitute(function(eta, extra=NULL) {
+ eta2theta(eta, .llocation, earg= .elocation)
+ }, list( .llocation=llocation,
+ .elocation=elocation ))),
last=eval(substitute(expression({
+ misc$expected = TRUE
misc$link = c("location"= .llocation)
misc$earg = list(location= .elocation )
misc$scale.arg = .scale.arg
@@ -1145,7 +1310,8 @@ logistic1 = function(llocation="identity",
if(!is.list(elocation)) elocation = list()
new("vglmff",
- blurb=c("One-parameter logistic distribution (location unknown, scale known)\n\n",
+ blurb=c("One-parameter logistic distribution ",
+ "(location unknown, scale known)\n\n",
"Link: ",
namesof("location", llocation, earg=elocation), "\n\n",
"Mean: location", "\n",
@@ -1166,6 +1332,7 @@ logistic1 = function(llocation="identity",
}, list( .llocation=llocation,
.elocation=elocation ))),
last=eval(substitute(expression({
+ misc$expected = TRUE
misc$link = c(location= .llocation)
misc$earg = list(location= .elocation )
misc$scale.arg = .scale.arg
@@ -1239,6 +1406,7 @@ erlang = function(shape.arg, link="loge", earg=list(), method.init=1)
.shape.arg * sc
}, list( .link=link, .earg=earg, .shape.arg=shape.arg ))),
last=eval(substitute(expression({
+ misc$expected = TRUE
misc$link = c(scale= .link)
misc$earg = list(scale= .earg )
misc$shape.arg = .shape.arg
@@ -1258,7 +1426,7 @@ erlang = function(shape.arg, link="loge", earg=list(), method.init=1)
w * dl.dsc * dsc.deta
}), list( .link=link, .earg=earg, .shape.arg=shape.arg ))),
weight=eval(substitute(expression({
- ed2l.dsc2 = .shape.arg / sc^2 # Use the expected info matrix
+ ed2l.dsc2 = .shape.arg / sc^2
wz = w * dsc.deta^2 * ed2l.dsc2
wz
}), list( .earg=earg, .shape.arg=shape.arg ))))
@@ -1266,70 +1434,202 @@ erlang = function(shape.arg, link="loge", earg=list(), method.init=1)
-borel.tanner = function(shape.arg, link="logit", earg=list())
-{
- if(!is.Numeric(shape.arg, allow=1, integ=TRUE))
- stop("bad input for argument \"shape.arg\"")
+dbort = function(x, Qsize=1, a=0.5) {
+ 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)
+ 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);
+
+ xok = (x >= Qsize) & (x == round(x)) & (a > 0) & (a < 1)
+ ans = x * 0
+ loglik = 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]
+ ans[xok] = exp(loglik)
+ ans
+}
+
+
+rbort = function(n, Qsize=1, a=0.5) {
+ 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))
+ stop("bad input for argument \"Qsize\"")
+ 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)
+ totqsize = qsize
+ fini = (qsize < 1)
+ while(any(!fini)) {
+ additions = rpois(sum(!fini), a[!fini])
+ qsize[!fini] = qsize[!fini] + additions
+ totqsize[!fini] = totqsize[!fini] + additions
+ qsize = qsize - 1
+ fini = fini | (qsize < 1)
+ }
+ totqsize
+}
+
+
+borel.tanner = function(Qsize=1, link="logit", earg=list(), method.init=1)
+{
+ if(!is.Numeric(Qsize, allow=1, integ=TRUE, posit=TRUE))
+ stop("bad input for argument \"Qsize\"")
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) ||
+ method.init > 4)
+ stop("'method.init' must be 1 or 2, 3 or 4")
new("vglmff",
blurb=c("Borel-Tanner distribution\n\n",
"Link: ",
namesof("a", link, earg=earg), "\n\n",
- "Mean: n/(1-a)",
+ "Mean: Qsize/(1-a)",
"\n",
- "Variance: n*a / (1-a)^3"),
+ "Variance: Qsize*a / (1-a)^3"),
initialize=eval(substitute(expression({
- y = as.numeric(y)
- if(any(y < .shape.arg))
- stop("all y values must be >= n")
- if(max(abs(y - round(y )))>0.00001)
- stop("response must be integer-valued")
if(ncol(cbind(y)) != 1)
stop("response must be a vector or a one-column matrix")
+ if(any(y < .Qsize))
+ stop(paste("all y values must be >=", .Qsize))
+ if(any(y != round(y)))
+ warning("response should be integer-valued")
predictors.names = namesof("a", .link, earg=.earg, tag=FALSE)
-
if(!length(etastart)) {
- a.init = .shape.arg / y
+ a.init = switch(as.character( .method.init ),
+ "1"= 1 - .Qsize / (y+1/8),
+ "2"= rep(1 - .Qsize / weighted.mean(y,w), len=n),
+ "3"= rep(1 - .Qsize / median(y), len=n),
+ "4"= rep(0.5, len=n))
etastart = theta2eta(a.init, .link, earg=.earg)
}
- }), list( .link=link, .earg=earg, .shape.arg=shape.arg ))),
+ }), list( .link=link, .earg=earg, .Qsize=Qsize,
+ .method.init=method.init ))),
inverse=eval(substitute(function(eta, extra=NULL) {
a = eta2theta(eta, .link, earg=.earg)
- .shape.arg / (1 - a)
- }, list( .link=link, .earg=earg, .shape.arg=shape.arg ))),
+ .Qsize / (1 - a)
+ }, list( .link=link, .earg=earg, .Qsize=Qsize ))),
last=eval(substitute(expression({
+ misc$expected = TRUE
misc$link = c(a= .link)
misc$earg = list(a= .earg )
- misc$shape.arg = .shape.arg
- }), list( .link=link, .earg=earg, .shape.arg=shape.arg ))),
+ misc$Qsize = .Qsize
+ }), list( .link=link, .earg=earg, .Qsize=Qsize ))),
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
- sum(w * ((y- .shape.arg) * log(a) - a * y))
- }, list( .link=link, .earg=earg, .shape.arg=shape.arg ))),
+ sum(w * (lgamma( 1 + .Qsize) - lgamma( y + 1 - .Qsize) +
+ (y - 1 - .Qsize) * log(y) +
+ (y- .Qsize) * log(a) - a * y))
+ }, list( .link=link, .earg=earg, .Qsize=Qsize ))),
vfamily=c("borel.tanner"),
deriv=eval(substitute(expression({
a = eta2theta(eta, .link, earg=.earg)
- dl.da = (y- .shape.arg)/a - y
+ dl.da = (y- .Qsize)/a - y
da.deta = dtheta.deta(a, .link, earg=.earg)
w * dl.da * da.deta
- }), list( .link=link, .earg=earg, .shape.arg=shape.arg ))),
+ }), list( .link=link, .earg=earg, .Qsize=Qsize ))),
weight=eval(substitute(expression({
- ed2l.da2 = .shape.arg/(a*(1-a)) # Use the expected info matrix
+ ed2l.da2 = .Qsize / (a*(1-a))
wz = w * da.deta^2 * ed2l.da2
wz
- }), list( .shape.arg=shape.arg ))))
+ }), list( .Qsize=Qsize ))))
}
+
+dfelix = function(x, a=0.25) {
+ 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);
+
+ xok = (x %% 2 == 1) & (x == round(x)) & (x >= 1) & (a > 0) & (a < 0.5)
+ ans = x * 0
+ loglik = ((x[xok]-3)/2) * log(x[xok]) + ((x[xok]-1)/2) * log(a[xok]) -
+ lgamma( x[xok]/2 + 0.5) - a[xok] * x[xok]
+ ans[xok] = exp(loglik)
+ ans
+}
+
+
+
+felix = function(link="elogit",
+ earg=if(link=="elogit") list(min=0, max=0.5) else list(),
+ method.init=1)
+{
+ 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) ||
+ method.init > 4)
+ stop("'method.init' must be 1 or 2, 3 or 4")
+
+ new("vglmff",
+ 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)
+ stop("response must be a vector or a one-column matrix")
+ 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)) {
+ wymean = weighted.mean(y,w)
+ a.init = switch(as.character( .method.init ),
+ "1"= (y-1+1/8) / (2*(y+1/8)+1/8),
+ "2"= rep((wymean-1+1/8) / (2*(wymean+1/8)+1/8), len=n),
+ "3"= rep((median(y)-1+1/8) / (2*(median(y)+1/8)+1/8), len=n),
+ "4"= rep(0.25, len=n))
+ etastart = theta2eta(a.init, .link, earg=.earg)
+ }
+ }), list( .link=link, .earg=earg,
+ .method.init=method.init ))),
+ inverse=eval(substitute(function(eta, extra=NULL) {
+ a = eta2theta(eta, .link, earg=.earg)
+ 1 / (1 - 2*a)
+ }, list( .link=link, .earg=earg ))),
+ last=eval(substitute(expression({
+ misc$expected = TRUE
+ 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) {
+ a = eta2theta(eta, .link, earg=.earg)
+ if(residuals) stop("loglikelihood residuals not implemented yet") else
+ sum(w * (((y-3)/2) * log(y) + ((y-1)/2) * log(a) -
+ lgamma( y/2 + 0.5) - a * y))
+ }, list( .link=link, .earg=earg ))),
+ vfamily=c("felix"),
+ deriv=eval(substitute(expression({
+ a = eta2theta(eta, .link, earg=.earg)
+ dl.da = (y- 1)/(2*a) - y
+ da.deta = dtheta.deta(a, .link, earg=.earg)
+ w * dl.da * da.deta
+ }), list( .link=link, .earg=earg ))),
+ weight=eval(substitute(expression({
+ ed2l.da2 = 1 / (a*(1-2*a))
+ wz = w * da.deta^2 * ed2l.da2
+ wz
+ }), list( .link=link ))))
+}
+
dsnorm = function(x, location=0, scale=1, shape=0) {
if(!is.Numeric(scale, posit=TRUE))
stop("bad input for argument \"scale\"")
@@ -1353,11 +1653,15 @@ rsnorm = function(n, location=0, scale=1, shape=0) {
}
-skewnormal1 = function(lshape="identity", earg = list(), ishape=NULL)
+skewnormal1 = function(lshape="identity", earg = list(), ishape=NULL,
+ nsimEIM=NULL)
{
if(mode(lshape) != "character" && mode(lshape) != "name")
lshape = as.character(substitute(lshape))
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",
@@ -1388,7 +1692,9 @@ skewnormal1 = function(lshape="identity", earg = list(), ishape=NULL)
last=eval(substitute(expression({
misc$link = c(shape= .lshape)
misc$earg = list(shape= .earg )
- }), list( .earg=earg, .lshape=lshape ))),
+ misc$nsimEIM = .nsimEIM
+ misc$expected = (length( .nsimEIM ) > 0)
+ }), list( .earg=earg, .lshape=lshape, .nsimEIM=nsimEIM ))),
link=eval(substitute(function(mu, extra=NULL) {
alpha = mu / sqrt(2/pi - mu^2)
theta2eta(alpha, .lshape, earg=.earg)
@@ -1410,32 +1716,188 @@ skewnormal1 = function(lshape="identity", earg = list(), ishape=NULL)
w * dl.dshape * dshape.deta
}), list( .earg=earg, .lshape=lshape ))),
weight=eval(substitute(expression({
- d2shape.deta2 = d2theta.deta2(alpha, .lshape, earg=.earg)
- d2l.dshape = -y*y * tmp86 * (tmp76 * zedd + tmp86) / tmp76^2
- wz = -(dshape.deta^2) * d2l.dshape - d2shape.deta2 * dl.dshape
- wz = w * wz
- wz[wz < .Machine$double.eps] = .Machine$double.eps
+ if( length( .nsimEIM )) {
+ run.mean = 0
+ for(ii in 1:(.nsimEIM)) {
+ ysim = rsnorm(n, location = 0, scale = 1, shape = alpha)
+ zedd = ysim*alpha
+ tmp76 = pnorm(zedd)
+ tmp86 = dnorm(zedd)
+ d2l.dshape2 = -ysim*ysim*tmp86*(tmp76*zedd+tmp86)/tmp76^2
+ rm(ysim)
+ run.mean = ((ii-1) * run.mean + d2l.dshape2) / ii
+ }
+ if(intercept.only)
+ run.mean = mean(run.mean)
+ wz = -w * (dshape.deta^2) * run.mean
+ } else {
+ d2shape.deta2 = d2theta.deta2(alpha, .lshape, earg=.earg)
+ d2l.dshape2 = -y*y * tmp86 * (tmp76 * zedd + tmp86) / tmp76^2
+ wz = -(dshape.deta^2) * d2l.dshape2 - d2shape.deta2 * dl.dshape
+ wz = w * wz
+ }
wz
- }), list( .earg=earg, .lshape=lshape ))))
+ }), list( .earg=earg, .lshape=lshape, .nsimEIM=nsimEIM ))))
}
-betaff = function(link="loge", earg=list(),
- i1=NULL, i2=NULL, trim=0.05,
- A=0, B=1, zero=NULL)
+
+
+
+betaff = function(A=0, B=1,
+ lmu=if(A==0 & B==1) "logit" else "elogit", lphi="loge",
+ emu=if(lmu=="elogit") list(min=A,max=B) else list(),
+ ephi=list(),
+ imu=NULL, iphi=NULL, method.init=1, zero=NULL)
{
- 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)
+ stop("A must be < B, and both must be of length one")
+ stdbeta = (A==0 && B==1)
+
+ if(mode(lmu) != "character" && mode(lmu) != "name")
+ lmu = as.character(substitute(lmu))
+ if(mode(lphi) != "character" && mode(lphi) != "name")
+ lphi = as.character(substitute(lphi))
if(length(zero) && !is.Numeric(zero, integer=TRUE, posit=TRUE))
stop("bad input for argument \"zero\"")
+ 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))
+ stop("bad input for argument \"iphi\"")
+ 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()
+
+ 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)",
+ "/ 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) * (",
+ B, "-", A, ")^(phi-1)),\n",
+ A," < y < ",B, ", ", A," < mu < ",B,
+ ", mu = ", A, " + ", (B-A), " * mu1",
+ ", phi > 0\n\n", sep=""),
+ "Links: ",
+ namesof("mu", lmu, earg=emu), ", ",
+ namesof("phi", lphi, earg=ephi)),
+ constraints=eval(substitute(expression({
+ constraints = cm.zero.vgam(constraints, x, .zero, M)
+ }), list( .zero=zero ))),
+ initialize=eval(substitute(expression({
+ if(min(y) <= .A || max(y) >= .B)
+ stop("data not within (A, B)")
+ 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(.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
+ 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 )
+ etastart[,2] = theta2eta(phi.init, .lphi, earg=.ephi )
+ }
+ }), list( .lmu=lmu, .lphi=lphi, .imu=imu, .iphi=iphi,
+ .A=A, .B=B, .emu=emu, .ephi=ephi, .method.init=method.init ))),
+ inverse=eval(substitute(function(eta, extra=NULL) {
+ mu = eta2theta(eta[,1], .lmu, .emu )
+ mu
+ }, list( .lmu=lmu, .emu=emu, .A=A, .B=B))),
+ last=eval(substitute(expression({
+ misc$link = c(mu = .lmu, phi = .lphi)
+ misc$limits = c(.A, .B)
+ misc$earg = list(mu= .emu, phi= .ephi)
+ misc$stdbeta = .stdbeta
+ }), list( .lmu=lmu, .lphi=lphi, .A=A, .B=B, .emu=emu, .ephi=ephi,
+ .stdbeta = stdbeta ))),
+ 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)
+ phi = eta2theta(eta[,2], .lphi, .ephi )
+ if(residuals) stop("loglikelihood residuals not implemented yet") else {
+ if( .stdbeta ) sum(w * (-lbeta(mu*phi,(1-mu)*phi) +
+ (phi*mu-1)*log(y) + ((1-mu)*phi-1)*log1p(-y))) else
+ sum(w * (-lbeta(m1u*phi,(1-m1u)*phi) + (phi*m1u-1)*log(y-.A) +
+ ((1-m1u)*phi-1)*log(.B-y) - (phi-1)*log(.B-.A)))
+ }
+ }, list( .lmu=lmu, .lphi=lphi, .A=A, .B=B, .emu=emu, .ephi=ephi,
+ .stdbeta = stdbeta ))),
+ vfamily="betaff",
+ 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)
+ 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 ) {
+ 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)
+ } else {
+ dl.dmu1 = phi*(digamma(temp2) - digamma(temp1) +
+ log(y-.A) - log(.B-y))
+ dl.dphi = digamma(phi) - m1u*digamma(temp1) -
+ (1-m1u)*digamma(temp2) +
+ m1u*log(y-.A) + (1-m1u)*log(.B-y) - log(.B -.A)
+ }
+ w * cbind(dl.dmu1 * dmu1.dmu * dmu.deta, dl.dphi * dphi.deta)
+ }), list( .lmu=lmu, .lphi=lphi, .A=A, .B=B, .emu=emu, .ephi=ephi,
+ .stdbeta = stdbeta ))),
+ weight=eval(substitute(expression({
+ d2l.dmu12 = phi^2 * (trigamma(temp1) + trigamma(temp2))
+ d2l.dphi2 = -trigamma(phi) + trigamma(temp1) * m1u^2 +
+ trigamma(temp2) * (1-m1u)^2
+ d2l.dmu1phi = temp1*trigamma(temp1) - temp2*trigamma(temp2)
+ wz = matrix(as.numeric(NA), n, dimm(M))
+ wz[,iam(1,1,M)] = d2l.dmu12 * dmu1.dmu^2 * dmu.deta^2
+ wz[,iam(2,2,M)] = d2l.dphi2 * dphi.deta^2
+ wz[,iam(1,2,M)] = d2l.dmu1phi * dmu1.dmu * dmu.deta * dphi.deta
+ w * wz
+ }), list( .A=A, .B=B ))))
+}
+
+
+
+
+
+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")
+ lshape1 = as.character(substitute(lshape1))
+ if(mode(lshape2) != "character" && mode(lshape2) != "name")
+ lshape2 = as.character(substitute(lshape2))
+ if(length(zero) && !is.Numeric(zero, integer=TRUE, posit=TRUE))
+ stop("bad input for argument \"zero\"")
+ if(length( i1 ) && !is.Numeric( i1, posit=TRUE))
+ stop("bad input for argument \"i1\"")
+ 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)
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(eshape1)) eshape1 = list()
+ if(!is.list(eshape2)) eshape2 = list()
new("vglmff",
- blurb=c("Two-parameter Beta distribution\n",
+ 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")
@@ -1445,23 +1907,24 @@ betaff = function(link="loge", earg=list(),
B, "-", A, ")^(shape1+shape2-1)], ",
A,"<=y<=",B," shape1>0, shape2>0\n\n", sep=""),
"Links: ",
- namesof("shape1", link, earg=earg), ", ",
- namesof("shape2", link, earg=earg)),
+ 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( .zero=zero ))),
+ }), list( .parallel=parallel, .zero=zero ))),
initialize=eval(substitute(expression({
if(min(y) <= .A || max(y) >= .B)
stop("data not within (A, B)")
if(ncol(cbind(y)) != 1)
stop("response must be a vector or a one-column matrix")
- predictors.names = c(namesof("shape1", .link, earg= .earg, short=TRUE),
- namesof("shape2", .link, earg= .earg, short=TRUE))
- if(is.numeric( .i1 ) && is.numeric( .i2 )) {
- vec = c(.i1, .i2)
- vec = c(theta2eta(vec[1], .link, earg= .earg ),
- theta2eta(vec[2], .link, earg= .earg ))
- etastart = matrix(vec, n, 2, byrow= TRUE)
+ 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)
@@ -1469,38 +1932,48 @@ betaff = function(link="loge", earg=list(),
DD = (.B - .A)^2
pinit = uu^2 * (1-uu)*DD/var(y) - uu # But var(y) is not robust
qinit = pinit * (1-uu) / uu
- etastart = matrix(theta2eta(c(pinit,qinit), .link, earg= .earg ),
- n, 2, byrow=TRUE)
+ etastart = matrix(0, n, 2)
+ etastart[,1] = theta2eta( pinit, .lshape1, earg= .eshape1 )
+ etastart[,2] = theta2eta( qinit, .lshape2, earg= .eshape2 )
}
- }), list( .link=link, .i1=i1, .i2=i2, .trim=trim, .A=A, .B=B,
- .earg=earg ))),
+ }), 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 = eta2theta(eta, .link, earg= .earg )
+ shapes = cbind(eta2theta(eta[,1], .lshape1, earg= .eshape1 ),
+ eta2theta(eta[,2], .lshape2, earg= .eshape2 ))
.A + (.B-.A) * shapes[,1] / (shapes[,1] + shapes[,2])
- }, list( .link=link, .A=A, .B=B, .earg=earg ))),
+ }, list( .lshape1=lshape1, .lshape2=lshape2, .A=A, .B=B,
+ .eshape1=eshape1, .eshape2=eshape2 ))),
last=eval(substitute(expression({
- misc$link = c(shape1 = .link, shape2 = .link)
+ misc$link = c(shape1 = .lshape1, shape2 = .lshape2)
misc$limits = c(.A, .B)
- misc$earg = list(shape1= .earg, shape2= .earg)
- }), list( .link=link, .A=A, .B=B, .earg=earg ))),
+ misc$earg = list(shape1= .eshape1, shape2= .eshape2)
+ }), list( .lshape1=lshape1, .lshape2=lshape2, .A=A, .B=B,
+ .eshape1=eshape1, .eshape2=eshape2 ))),
loglikelihood=eval(substitute(
function(mu, y, w, residuals= FALSE, eta, extra=NULL){
- shapes = eta2theta(eta, .link, earg= .earg )
+ shapes = cbind(eta2theta(eta[,1], .lshape1, earg= .eshape1 ),
+ eta2theta(eta[,2], .lshape2, earg= .eshape2 ))
temp = if(is.R()) lbeta(shapes[,1], shapes[,2]) else
lgamma(shapes[,1]) + lgamma(shapes[,2]) -
lgamma(shapes[,1]+shapes[,2])
if(residuals) stop("loglikelihood residuals not implemented yet") else
sum(w * ((shapes[,1]-1) * log(y- .A) + (shapes[,2]-1) * log( .B -y) -
temp - (shapes[,1]+shapes[,2]-1) * log( .B - .A )))
- }, list( .link=link, .A=A, .B=B, .earg=earg ))),
- vfamily="betaff",
+ }, list( .lshape1=lshape1, .lshape2=lshape2, .A=A, .B=B,
+ .eshape1=eshape1, .eshape2=eshape2 ))),
+ vfamily="beta.ab",
deriv=eval(substitute(expression({
- shapes = eta2theta(eta, .link, earg= .earg )
- dshapes.deta = dtheta.deta(shapes, .link, earg= .earg )
+ shapes = cbind(eta2theta(eta[,1], .lshape1, earg= .eshape1 ),
+ eta2theta(eta[,2], .lshape2, earg= .eshape2 ))
+ dshapes.deta = cbind(dtheta.deta(shapes[,1], .lshape1, earg= .eshape1),
+ dtheta.deta(shapes[,2], .lshape2, earg= .eshape2))
dl.dshapes = cbind(log(y-.A), log(.B-y)) - digamma(shapes) +
digamma(shapes[,1] + shapes[,2]) - log(.B - .A)
w * dl.dshapes * dshapes.deta
- }), list( .link=link, .A=A, .B=B, .earg=earg ))),
+ }), list( .lshape1=lshape1, .lshape2=lshape2, .A=A, .B=B,
+ .eshape1=eshape1, .eshape2=eshape2 ))),
weight=expression({
temp2 = trigamma(shapes[,1]+shapes[,2])
d2l.dshape12 = temp2 - trigamma(shapes[,1])
@@ -1672,21 +2145,33 @@ exponential = function(link="loge", earg=list(), location=0, expected=TRUE)
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)
+ stop("bad input for argument \"expected\"")
new("vglmff",
blurb=c("Exponential distribution\n\n",
"Link: ", namesof("rate", link, tag= TRUE), "\n",
- "Mean: ", "mu =", location, "+ 1 / ",
- namesof("rate", link, tag= TRUE, earg=earg), "\n",
+ "Mean: ", "mu = ",
+ if(location == 0) "1/rate" else
+ paste(location, "+ 1/rate"), "\n",
"Variance: ",
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)
+ 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)
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))
- stop(paste("all responses must be greater than",extra$loc))
+ stop(paste("all responses must be greater than", extra$loc))
predictors.names = namesof("rate", .link, tag=FALSE)
mu = y + (y == extra$loc) / 8
if(!length(etastart))
@@ -1697,21 +2182,13 @@ exponential = function(link="loge", earg=list(), location=0, expected=TRUE)
list( .link=link, .earg=earg ))),
last=eval(substitute(expression({
misc$location = extra$loc
- misc$link = c(rate = .link)
- misc$earg = list(rate = .earg)
- }), list( .link=link, .earg=earg ))),
- link=eval(substitute(function(mu, extra=NULL)
- theta2eta(1/(mu-extra$loc), .link, earg=.earg),
- list( .link=link, .earg=earg ))),
- 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)
- sign(y - mu) * sqrt(abs(devi) * w) else
- sum(w * devi)
- }, list( .location=location, .earg=earg ))),
+ misc$link = c(rate = .link)
+ misc$earg = list(rate = .earg)
+ misc$expected = .expected
+ }), list( .link=link, .earg=earg, .expected=expected ))),
+ link=eval(substitute(function(mu, extra=NULL)
+ theta2eta(1/(mu-extra$loc), .link, earg=.earg),
+ list( .link=link, .earg=earg ))),
vfamily=c("exponential"),
deriv=eval(substitute(expression({
rate = 1 / (mu - extra$loc)
@@ -2342,7 +2819,7 @@ normal1 = function(lmean="identity", lsd="loge",
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),
@@ -2393,7 +2870,7 @@ normal1 = function(lmean="identity", lsd="loge",
cbind(w * dl.dmu * dmu.deta, w * dl.dsd * dsd.deta)
}), list( .lmean=lmean, .lsd=lsd, .emean=emean, .esd=esd ))),
weight=expression({
- wz = matrix(as.numeric(NA), n, 2) # diagonal matrix; y is one-column too
+ wz = matrix(as.numeric(NA), n, 2) # diagonal matrix; y is one-column too
ed2l.dmu2 = -1 / sd^2
ed2l.dsd2 = -2 / sd^2 # zz; replace 2 by 0.5 ??
wz[,iam(1,1,M)] = -w * ed2l.dmu2 * dmu.deta^2
@@ -2693,7 +3170,7 @@ negbinomial = function(lmu = "loge", lk = "loge",
NOS = ncoly = ncol(y) # Number of species
predictors.names = c(namesof(if(NOS==1) "mu" else
paste("mu", 1:NOS, sep=""), .lmu, earg=.emu, tag=FALSE),
- namesof(if(NOS==1) "k" else paste("k", 1:NOS, sep=""), .lk, earg=.ek,
+ 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)) {
@@ -2704,10 +3181,9 @@ negbinomial = function(lmu = "loge", lk = "loge",
} else {
median(y[,iii]) + 1/16
}
- mu.init[,iii] = (1- .sinit) * (y[,iii]+1/16) + .sinit * use.this
+ mu.init[,iii] = (1- .sinit)*(y[,iii]+1/16) + .sinit * use.this
}
-
if( is.Numeric( .k.init )) {
kay.init = matrix( .k.init, nr=n, nc=NOS, byrow=TRUE)
} else {
@@ -2832,7 +3308,8 @@ negbinomial = function(lmu = "loge", lk = "loge",
if(residuals)
sign(y - mu) * sqrt(abs(devi) * w) else
sum(w * devi)
- }, list( .lk=lk, .emu=emu, .ek=ek,)))
+ }, list( .lk=lk, .emu=emu, .ek=ek )))
+
ans
}
@@ -2900,7 +3377,7 @@ negbin.ab = function(link.alpha ="loge", link.k ="loge",
alpha = eta2theta(eta[,1], .link.alpha, earg= .ealpha)
k = eta2theta(eta[,2], .link.k, earg= .ek)
if(residuals) stop("loglikelihood residuals not implemented yet") else
- sum(w * (y * log(alpha) - (y+k)*log(alpha+1) + lgamma(y+k) -
+ sum(w * (y * log(alpha) - (y+k)*log1p(alpha) + lgamma(y+k) -
lgamma(k) - lgamma(y+1 )))
}, list( .link.alpha=link.alpha, .link.k=link.k,
.ealpha=ealpha, .ek=ek ))),
@@ -3219,12 +3696,17 @@ simple.poisson = function()
-studentt = function(link.df="loglog", earg=list())
+studentt = function(link.df="loglog", earg=list(),
+ idf=NULL, nsimEIM=100)
{
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)
+ stop("'nsimEIM' should be an integer greater than 10")
+ if(length(idf) && !is.Numeric(idf) && any(idf <= 1))
+ stop("'idf' should be > 1")
new("vglmff",
blurb=c("Student t-distribution\n\n",
@@ -3237,13 +3719,14 @@ studentt = function(link.df="loglog", earg=list())
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 = (2*var(y)/(var(y)-1))
- if(is.na(init.df) || init.df<1)
+ init.df = if(length( .idf )) .idf else
+ (2*var(y)/(var(y)-1)) # Should incorporate weights
+ if(!is.Numeric(init.df) || init.df <= 1)
init.df = 4
etastart = rep(theta2eta(init.df, .link.df, earg= .earg),
len=length(y))
}
- }), list( .link.df=link.df, .earg=earg ))),
+ }), list( .link.df=link.df, .earg=earg, .idf=idf ))),
inverse=eval(substitute(function(eta, extra=NULL) {
df = eta2theta(eta, .link.df, earg= .earg)
ifelse(df > 1, 0, NA)
@@ -3251,18 +3734,15 @@ studentt = function(link.df="loglog", earg=list())
last=eval(substitute(expression({
misc$link = c(df = .plink )
misc$earg = list(df = .earg )
- }), list( .plink=link.df, .earg=earg ))),
- link=eval(substitute(function(mu, extra=NULL) {
- alpha = mu / sqrt(2/pi - mu^2)
- theta2eta(alpha, .plink, earg= .earg)
- }, list( .plink=link.df, .earg=earg ))),
- loglikelihood=eval(substitute(function(mu, y, w, residuals = FALSE, eta,
- extra=NULL) {
+ misc$simEIM = TRUE
+ misc$nsimEIM = .nsimEIM
+ }), list( .plink=link.df, .earg=earg, .nsimEIM=nsimEIM ))),
+ loglikelihood=eval(substitute(
+ function(mu,y,w,residuals=FALSE,eta,extra=NULL) {
df = eta2theta(eta, .link.df, earg= .earg)
- temp1 = y^2 / df
if(residuals) stop("loglikelihood residuals not implemented yet") else {
if(is.R()) sum(w * dt(x=y, df=df, log=TRUE)) else
- sum(w * (-log(pi*df)/2 - (df+1)*log1p(temp1)/2 +
+ sum(w * (-log(pi*df)/2 - (df+1)*log1p(y^2 / df)/2 +
lgamma((df+1)/2) - lgamma(df/2)))
}
}, list( .link.df=link.df, .earg=earg ))),
@@ -3279,15 +3759,22 @@ studentt = function(link.df="loglog", earg=list())
weight=eval(substitute(expression({
temp2 = (df+1)/2
d2df.deta2 = d2theta.deta2(theta=df, .link.df, earg= .earg)
- negative = -trigamma(df/2)/4 -
- 0.5*y^2*( (1+temp)/(df+y^2) + temp^2 )/(df+y^2)
- positive = 0.5*temp^2 +trigamma(temp2)/4 + 0.5*y^2*temp/(df+y^2)
- d2l.ddf2 = positive + negative
- wz = -ddf.deta^2 * d2l.ddf2 - dl.ddf * d2df.deta2
- wz * w
- }), list( .link.df=link.df, .earg=earg ))))
-}
+ run.mean = 0
+ for(ii in 1:(.nsimEIM)) {
+ ysim = rt(n, df=df)
+ d2l.ddf2 = 0.5*temp^2 + trigamma(temp2)/4 +
+ 0.5*ysim^2*temp/(df+ysim^2) - trigamma(df/2)/4 -
+ 0.5*ysim^2*((1+temp)/(df+ysim^2) + temp^2)/(df+ysim^2)
+ rm(ysim)
+ run.mean = ((ii-1) * run.mean + d2l.ddf2) / ii
+ }
+ if(intercept.only)
+ run.mean = mean(run.mean)
+ wz = -w * ddf.deta^2 * run.mean
+ wz
+ }), list( .link.df=link.df, .earg=earg, .nsimEIM=nsimEIM ))))
+}
chisq = function(link = "loge", earg=list())
@@ -3320,8 +3807,7 @@ chisq = function(link = "loge", earg=list())
function(mu,y,w,residuals= FALSE,eta,extra=NULL) {
df = eta2theta(eta, .link, earg= .earg)
if(residuals) stop("loglikelihood residuals not implemented yet") else
- sum(w * (df*log(0.5)/2 + (df/2 - 1)*log(y) - y/2 -
- lgamma(df/2 )))
+ sum(w * dchisq(x=y, df=df, ncp = 0, log = TRUE))
}, list( .link = link, .earg=earg ))),
vfamily="chisq",
deriv=eval(substitute(expression({
@@ -3401,7 +3887,7 @@ simplex = function(lmu="logit", lsigma="loge",
(0.5/sigma^2)*(y-mu)^2 / (y*(1-y)*mu^2*(1-mu)^2 )))
}, list( .lsigma=lsigma,
.emu=emu, .esigma=esigma ))),
- vfamily=c("simplex1"),
+ vfamily=c("simplex"),
deriv=eval(substitute(expression({
if(iter==1) {
d3 = deriv3(~ w * (-0.5*log(2*pi*sigma^2*(y*(1-y))^3) -
@@ -3816,9 +4302,10 @@ leipnik = function(lmu="logit", llambda="loge",
-invbinomial = function(lrho="logit", llambda="loge",
- erho=list(), elambda=list(),
- irho=0.75,
+invbinomial = function(lrho="elogit", llambda="loge",
+ erho=if(lrho=="elogit") list(min = 0.5, max = 1) else list(),
+ elambda=list(),
+ irho=NULL,
ilambda=NULL,
zero=NULL)
{
@@ -3837,7 +4324,8 @@ invbinomial = function(lrho="logit", llambda="loge",
"Links: ",
namesof("rho", lrho, earg=erho), ", ",
namesof("lambda", llambda, earg=elambda), "\n",
- "Mean: lambda*(1-rho)/(2*rho-1)\n"),
+ "Mean: lambda*(1-rho)/(2*rho-1)\n",
+ "Variance: lambda*rho*(1-rho)/(2*rho-1)^3\n"),
constraints=eval(substitute(expression({
constraints = cm.zero.vgam(constraints, x, .zero, M)
}), list( .zero=zero ))),
@@ -3848,10 +4336,17 @@ invbinomial = function(lrho="logit", llambda="loge",
c(namesof("rho", .lrho, earg=.erho, tag=FALSE),
namesof("lambda", .llambda, earg=.elambda, tag=FALSE))
if(!length(etastart)) {
- rho = rep(if(length( .irho)) .irho else 0.75, length=n)
- lambda = rep(if(length( .ilambda)) .ilambda else 1, length=n)
- etastart = cbind(theta2eta(rho, .lrho, earg= .erho),
- theta2eta(lambda, .llambda, earg= .elambda))
+ 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)
+ init.rho = rep(if(length( .irho)) .irho else {
+ ifelse(temp1 > 0.5 && temp1 < 1, temp1, temp2)
+ }, length=n)
+ init.lambda = rep(if(length( .ilambda)) .ilambda else {
+ (2*init.rho-1) * weighted.mean(y, w) / (1-init.rho)
+ }, length=n)
+ etastart = cbind(theta2eta(init.rho, .lrho, earg= .erho),
+ theta2eta(init.lambda, .llambda, earg= .elambda))
}
}), list( .llambda=llambda, .lrho=lrho,
.elambda=elambda, .erho=erho,
@@ -3859,7 +4354,7 @@ invbinomial = function(lrho="logit", llambda="loge",
inverse=eval(substitute(function(eta, extra=NULL) {
rho = eta2theta(eta[,1], .lrho, earg= .erho)
lambda = eta2theta(eta[,2], .llambda, earg= .elambda)
- lambda*(1-rho)/(2*rho-1)
+ ifelse(rho > 0.5, lambda*(1-rho)/(2*rho-1), NA)
}, list( .llambda=llambda, .lrho=lrho,
.elambda=elambda, .erho=erho ))),
last=eval(substitute(expression({
@@ -3874,43 +4369,40 @@ invbinomial = function(lrho="logit", llambda="loge",
lambda = eta2theta(eta[,2], .llambda, earg= .elambda)
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*(1-rho)) + lambda*log(rho )))
+ lgamma(y+lambda+1) + y*log(rho) + y*log1p(-rho) +
+ lambda*log(rho)))
}, list( .llambda=llambda, .lrho=lrho,
.elambda=elambda, .erho=erho ))),
vfamily=c("invbinomial"),
deriv=eval(substitute(expression({
rho = eta2theta(eta[,1], .lrho, earg= .erho)
lambda = eta2theta(eta[,2], .llambda, earg= .elambda)
- dl.drho = y * (1-2*rho)/(rho*(1-rho)) + lambda /rho
+ dl.drho = (y + lambda)/rho - y/(1-rho)
dl.dlambda = 1/lambda - digamma(2*y+lambda) - digamma(y+lambda+1) +
- log(rho)
+ log(rho)
drho.deta = dtheta.deta(rho, .lrho, earg= .erho)
dlambda.deta = dtheta.deta(lambda, .llambda, earg= .elambda)
w * cbind( dl.drho * drho.deta, dl.dlambda * dlambda.deta )
}), list( .llambda=llambda, .lrho=lrho,
.elambda=elambda, .erho=erho ))),
weight=eval(substitute(expression({
- d2l.drho2 = y * (-1+2*rho-2*rho^2) / (rho*(1-rho))^2 - lambda/rho^2
- d2l.dlambda2 = -1/(lambda^2) - trigamma(2*y+lambda) -
- trigamma(y+lambda+1)
- d2l.dlambdarho = 1/rho
+ ed2l.drho2 = (mu+lambda) / rho^2 + mu / (1-rho)^2
+ d2l.dlambda2 = 1/(lambda^2) + trigamma(2*y+lambda)+trigamma(y+lambda+1)
+ ed2l.dlambdarho = -1/rho
wz = matrix(as.numeric(NA), n, dimm(M)) #3=dimm(M)
- wz[,iam(2,2,M)] = -d2l.dlambda2 * dlambda.deta^2
- wz[,iam(1,1,M)] = -d2l.drho2 * drho.deta^2
- wz[,iam(1,2,M)] = -d2l.dlambdarho * dlambda.deta * drho.deta
+ wz[,iam(1,1,M)] = ed2l.drho2 * drho.deta^2
+ wz[,iam(1,2,M)] = ed2l.dlambdarho * dlambda.deta * drho.deta
+ wz[,iam(2,2,M)] = d2l.dlambda2 * dlambda.deta^2
d2rhodeta2 = d2theta.deta2(rho, .lrho, earg= .erho)
d2lambda.deta2 = d2theta.deta2(lambda, .llambda, earg= .elambda)
- wz[,iam(1,1,M)] = wz[,iam(1,1,M)] - dl.dlambda * d2lambda.deta2
- wz[,iam(2,2,M)] = wz[,iam(2,2,M)] - dl.drho * d2rhodeta2
wz = w * wz
if(intercept.only) {
- sumw = sum(w)
- for(i in 1:ncol(wz))
- wz[,i] = sum(wz[,i]) / sumw
pooled.weight = TRUE
- wz = w * wz # Put back the weights
+
+ wz[,iam(2,2,M)] = sum(wz[,iam(2,2,M)]) / sum(w)
+
} else
pooled.weight = FALSE
@@ -3921,9 +4413,12 @@ invbinomial = function(lrho="logit", llambda="loge",
-genpoisson = function(llambda="logit", ltheta="loge",
- elambda=list(), etheta=list(),
- ilambda=0.5, itheta=NULL, zero=NULL)
+genpoisson = function(llambda="elogit", ltheta="loge",
+ elambda=if(llambda=="elogit") list(min=-1,max=1) else list(),
+ etheta=list(),
+ ilambda=NULL, itheta=NULL,
+ use.approx=TRUE,
+ method.init=1, zero=1)
{
if(mode(llambda) != "character" && mode(llambda) != "name")
@@ -3934,6 +4429,11 @@ genpoisson = function(llambda="logit", ltheta="loge",
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) ||
+ method.init > 2)
+ stop("'method.init' must be 1 or 2")
+ 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",
@@ -3950,17 +4450,32 @@ genpoisson = function(llambda="logit", ltheta="loge",
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))
+ namesof("theta", .ltheta, earg=.etheta, tag=FALSE))
+ init.lambda = if( .method.init == 1)
+ 1 - sqrt(weighted.mean(y,w) / var(y)) else 0.5
+ 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)
+ init.theta = 0.1
+ cutpt = if(init.lambda < 0) {
+ mmm = max(trunc(-init.theta / init.lambda), 4)
+ max(-1, -init.theta /mmm)
+ } else -1
+ if(init.lambda <= cutpt)
+ init.lambda = cutpt + 0.1
+ if(init.lambda >= 1)
+ init.lambda = 0.9
if(!length(etastart)) {
lambda = rep(if(length( .ilambda)) .ilambda else
- 0.5, length=n)
- theta = rep(if(length( .itheta)) .itheta else
- median(y) * (1-lambda), length=n)
+ init.lambda, length=n)
+ theta = rep(if(length( .itheta)) .itheta else init.theta, length=n)
etastart = cbind(theta2eta(lambda, .llambda, earg= .elambda),
- theta2eta(theta, .ltheta, earg= .etheta))
+ theta2eta(theta, .ltheta, earg= .etheta))
}
}), list( .ltheta=ltheta, .llambda=llambda,
.etheta=etheta, .elambda=elambda,
+ .method.init=method.init,
.itheta=itheta, .ilambda=ilambda )) ),
inverse=eval(substitute(function(eta, extra=NULL) {
lambda = eta2theta(eta[,1], .llambda, earg= .elambda)
@@ -3971,19 +4486,21 @@ genpoisson = function(llambda="logit", ltheta="loge",
last=eval(substitute(expression({
misc$link = c(lambda=.llambda, theta=.ltheta)
misc$earg = list(lambda=.elambda, theta=.etheta)
- misc$pooled.weight = pooled.weight
+ if(! .use.approx )
+ misc$pooled.weight = pooled.weight
}), list( .ltheta=ltheta, .llambda=llambda,
+ .use.approx = use.approx,
.etheta=etheta, .elambda=elambda ))),
loglikelihood=eval(substitute(
function(mu, y, w, residuals= FALSE,eta, extra=NULL) {
lambda = eta2theta(eta[,1], .llambda, earg= .elambda)
theta = eta2theta(eta[,2], .ltheta, earg= .etheta)
- index = y == 0
+ index = (y == 0)
if(residuals) stop("loglikelihood residuals not implemented yet") else
sum(w[index]*(-theta[index])) +
- sum(w[!index]*(-y[!index]*lambda[!index]-theta[!index]+
+ sum(w[!index] * (-y[!index]*lambda[!index]-theta[!index] +
(y[!index]-1)*log(theta[!index]+y[!index]*lambda[!index]) +
- log(theta[!index] )))
+ log(theta[!index]) - lgamma(y[!index]+1)) )
}, list( .ltheta=ltheta, .llambda=llambda,
.etheta=etheta, .elambda=elambda ))),
vfamily=c("genpoisson"),
@@ -3998,32 +4515,42 @@ genpoisson = function(llambda="logit", ltheta="loge",
}), list( .ltheta=ltheta, .llambda=llambda,
.etheta=etheta, .elambda=elambda ))),
weight=eval(substitute(expression({
- d2l.dlambda2 = -y^2 * (y-1) / (theta+y*lambda)^2
- d2l.dtheta2 = -(y-1)/(theta+y*lambda)^2 - 1 / theta^2
- d2l.dthetalambda = -y * (y-1) / (theta+y*lambda)^2
wz = matrix(as.numeric(NA), n, dimm(M)) #3=dimm(M)
- wz[,iam(1,1,M)] = -d2l.dlambda2 * dlambda.deta^2
- wz[,iam(2,2,M)] = -d2l.dtheta2 * dTHETA.deta^2
- wz[,iam(1,2,M)] = -d2l.dthetalambda * dTHETA.deta * dlambda.deta
-
- d2THETA.deta2 = d2theta.deta2(theta, .ltheta, earg= .etheta)
- d2lambdadeta2 = d2theta.deta2(lambda, .llambda, earg= .elambda)
- wz[,iam(1,1,M)] = wz[,iam(1,1,M)] - dl.dlambda * d2lambdadeta2
- wz[,iam(2,2,M)] = wz[,iam(2,2,M)] - dl.dtheta * d2THETA.deta2
- wz = w * wz
-
- if(intercept.only) {
- sumw = sum(w)
- for(i in 1:ncol(wz))
- wz[,i] = sum(wz[,i]) / sumw
- pooled.weight = TRUE
- wz = w * wz # Put back the weights
- } else
- pooled.weight = FALSE
-
-
+ 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
+ d2l.dthetalambda = 2 * theta / BBB
+ wz[,iam(1,1,M)] = d2l.dlambda2 * dlambda.deta^2
+ wz[,iam(2,2,M)] = d2l.dtheta2 * dTHETA.deta^2
+ wz[,iam(1,2,M)] = d2l.dthetalambda * dTHETA.deta * dlambda.deta
+ wz = w * wz
+ } else {
+ d2l.dlambda2 = -y^2 * (y-1) / (theta+y*lambda)^2
+ d2l.dtheta2 = -(y-1)/(theta+y*lambda)^2 - 1 / theta^2
+ d2l.dthetalambda = -y * (y-1) / (theta+y*lambda)^2
+ wz[,iam(1,1,M)] = -d2l.dlambda2 * dlambda.deta^2
+ wz[,iam(2,2,M)] = -d2l.dtheta2 * dTHETA.deta^2
+ wz[,iam(1,2,M)] = -d2l.dthetalambda * dTHETA.deta * dlambda.deta
+
+ d2THETA.deta2 = d2theta.deta2(theta, .ltheta, earg= .etheta)
+ d2lambdadeta2 = d2theta.deta2(lambda, .llambda, earg= .elambda)
+ wz[,iam(1,1,M)] = wz[,iam(1,1,M)] - dl.dlambda * d2lambdadeta2
+ wz[,iam(2,2,M)] = wz[,iam(2,2,M)] - dl.dtheta * d2THETA.deta2
+ wz = w * wz
+
+ if(intercept.only) {
+ sumw = sum(w)
+ for(i in 1:ncol(wz))
+ wz[,i] = sum(wz[,i]) / sumw
+ pooled.weight = TRUE
+ wz = w * wz # Put back the weights
+ } else
+ pooled.weight = FALSE
+ }
wz
}), list( .ltheta=ltheta, .llambda=llambda,
+ .use.approx = use.approx,
.etheta=etheta, .elambda=elambda ))))
}
@@ -4059,6 +4586,7 @@ lgammaff = function(link="loge", earg=list(), init.k=NULL)
last=eval(substitute(expression({
misc$link = c(k= .link )
misc$earg = list(k= .earg )
+ misc$expected = TRUE
}), list( .link=link, .earg=earg ))),
loglikelihood=eval(substitute(
function(mu,y,w,residuals= FALSE,eta, extra=NULL) {
@@ -4121,6 +4649,8 @@ lgamma3ff = function(llocation="identity", lscale="loge", lshape="loge",
lshape = as.character(substitute(lshape))
if(length(zero) && !is.Numeric(zero, integer=TRUE, posit=TRUE))
stop("bad input for argument \"zero\"")
+ 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()
@@ -4229,6 +4759,8 @@ prentice74 = function(llocation="identity", lscale="loge", lshape="identity",
lshape = as.character(substitute(lshape))
if(length(zero) && !is.Numeric(zero, integer=TRUE, posit=TRUE))
stop("bad input for argument \"zero\"")
+ 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()
@@ -4385,6 +4917,8 @@ ggamma = function(lscale="loge", ld="loge", lk="loge",
lk = as.character(substitute(lk))
if(length(zero) && !is.Numeric(zero, integer=TRUE, posit=TRUE))
stop("bad input for argument \"zero\"")
+ 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()
@@ -4594,6 +5128,7 @@ logff = function(link="logit", earg=list(), init.c=NULL)
last=eval(substitute(expression({
misc$link = c(c= .link)
misc$earg = list(c= .earg)
+ misc$expected = TRUE
}), list( .link=link, .earg=earg ))),
loglikelihood=eval(substitute(
function(mu,y,w,residuals= FALSE,eta, extra=NULL) {
@@ -7625,6 +8160,8 @@ expexp = function(lshape="loge", lscale="loge",
stop("bad input for argument \"tolerance\"")
if(!is.Numeric(ishape, posit=TRUE))
stop("bad input for argument \"ishape\"")
+ 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()
@@ -7681,7 +8218,7 @@ expexp = function(lshape="loge", lscale="loge",
deriv=eval(substitute(expression({
shape = eta2theta(eta[,1], .lshape, earg= .eshape)
scale = eta2theta(eta[,2], .lscale, earg= .escale)
- dl.dscale = 1/scale + (shape-1)*y*exp(-scale*y) / (1-exp(-scale*y)) - y
+ dl.dscale = 1/scale + (shape-1)*y*exp(-scale*y) / (-expm1(-scale*y)) - y
dl.dshape = 1/shape + log1p(-exp(-scale*y))
dscale.deta = dtheta.deta(scale, .lscale, earg= .escale)
dshape.deta = dtheta.deta(shape, .lshape, earg= .eshape)
@@ -7738,6 +8275,8 @@ expexp1 = function(lscale="loge",
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))
+ stop("bad input for argument \"iscale\"")
new("vglmff",
blurb=c("Exponentiated Exponential Distribution",
@@ -7768,7 +8307,7 @@ expexp1 = function(lscale="loge",
.escale=escale ))),
inverse=eval(substitute(function(eta, extra=NULL) {
scale = eta2theta(eta, .lscale, earg= .escale)
- temp7 = 1 - exp(-scale*extra$yvector)
+ temp7 = -expm1(-scale*extra$yvector)
shape = -extra$sumw / sum(extra$w*log(temp7)) # \gamma(\theta)
(digamma(shape+1)-digamma(1)) / scale
}, list( .lscale=lscale,
@@ -7776,7 +8315,7 @@ expexp1 = function(lscale="loge",
last=eval(substitute(expression({
misc$link = c("scale"= .lscale)
misc$earg = list(scale= .escale)
- temp7 = 1 - exp(-scale*y)
+ temp7 = -expm1(-scale*y)
shape = -extra$sumw / sum(w*log(temp7)) # \gamma(\theta)
misc$shape = shape # Store the ML estimate here
misc$pooled.weight = pooled.weight
@@ -7784,7 +8323,7 @@ expexp1 = function(lscale="loge",
loglikelihood= eval(substitute(
function(mu, y, w, residuals = FALSE, eta, extra=NULL) {
scale = eta2theta(eta, .lscale, earg= .escale)
- temp7 = 1 - exp(-scale*y)
+ temp7 = -expm1(-scale*y)
shape = -extra$sumw / sum(w*log(temp7)) # \gamma(\theta)
if(residuals) stop("loglikelihood residuals not implemented yet") else
sum(w * (log(shape) + log(scale) +
@@ -7942,6 +8481,8 @@ logistic2 = function(llocation="identity",
method.init > 2) stop("argument \"method.init\" must be 1 or 2")
if(length(zero) && !is.Numeric(zero, integer=TRUE, posit=TRUE))
stop("bad input for argument \"zero\"")
+ 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()
@@ -8030,12 +8571,364 @@ logistic2 = function(llocation="identity",
-alaplace = function(llocation="identity", lscale="loge",
- lkappa="loge",
- elocation=list(), escale=list(),
- ekappa=list(),
+alaplace2 = function(tau = NULL,
+ llocation="identity", lscale="loge",
+ elocation=list(), escale=list(),
+ ilocation=NULL, iscale=NULL,
+ kappa = sqrt(tau/(1-tau)),
+ shrinkage.init=0.95, parallelLocation=FALSE, digt=4,
+ sameScale=TRUE,
+ dfmu.init = 3,
+ method.init=1, zero="(1 + M/2):M") {
+
+ if(!is.Numeric(kappa, posit=TRUE))
+ stop("bad input for argument \"kappa\"")
+ if(length(tau) && max(abs(kappa - sqrt(tau/(1-tau)))) > 1.0e-6)
+ stop("arguments 'kappa' and 'tau' do not match")
+ if(mode(llocation) != "character" && mode(llocation) != "name")
+ llocation = as.character(substitute(llocation))
+ if(mode(lscale) != "character" && mode(lscale) != "name")
+ lscale = as.character(substitute(lscale))
+ 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))
+ stop("bad input for argument \"iscale\"")
+ if(!is.list(elocation)) elocation = list()
+ if(!is.list(escale)) escale = list()
+ if(!is.Numeric(shrinkage.init, allow=1) || shrinkage.init < 0 ||
+ shrinkage.init > 1) stop("bad input for argument \"shrinkage.init\"")
+ if(length(zero) &&
+ !(is.Numeric(zero, integer=TRUE, posit=TRUE) || is.character(zero )))
+ stop("bad input for argument \"zero\"")
+ if(!is.logical(sameScale) || length(sameScale) != 1)
+ stop("bad input for argument \"sameScale\"")
+ if(!is.logical(parallelLocation) || length(parallelLocation) != 1)
+ stop("bad input for argument \"parallelLocation\"")
+ fittedMean = FALSE
+ if(!is.logical(fittedMean) || length(fittedMean) != 1)
+ stop("bad input for argument \"fittedMean\"")
+
+ new("vglmff",
+ blurb=c("Two-parameter asymmetric Laplace distribution\n\n",
+ "Links: ",
+ namesof("location", llocation, earg=elocation), ", ",
+ namesof("scale", lscale, earg=escale),
+ "\n", "\n",
+ "Mean: location + scale * (1/kappa - kappa) / sqrt(2)", "\n",
+ "Quantiles: location", "\n",
+ "Variance: scale^2 * (1 + kappa^4) / (2 * kappa^2)"),
+ constraints=eval(substitute(expression({
+ .ZERO = .zero
+ if(is.character(.ZERO)) .ZERO = eval(parse(text = .ZERO))
+ .PARALLEL = .parallelLocation
+ parHmat = if(is.logical(.PARALLEL) && .PARALLEL)
+ matrix(1, M/2, 1) else diag(M/2)
+ 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)") {
+ parHmat = diag(M/2)
+ mycmatrix = cbind(rbind(parHmat, 0*parHmat),
+ rbind(0*scaleHmat, scaleHmat))
+ constraints[["(Intercept)"]] = mycmatrix
+ }
+ if(is.logical(.sameScale) && .sameScale &&
+ names(constraints)[1] == "(Intercept)") {
+ temp3 = constraints[["(Intercept)"]]
+ temp3 = cbind(temp3[,1:(M/2)], rbind(0*scaleHmat, scaleHmat))
+ constraints[["(Intercept)"]] = temp3
+ }
+ }), list( .sameScale=sameScale, .parallelLocation=parallelLocation,
+ .zero=zero ))),
+ initialize=eval(substitute(expression({
+ extra$kappa = .kappa
+ extra$tau = extra$kappa^2 / (1 + extra$kappa^2)
+ if(ncol(y <- cbind(y)) != 1)
+ stop("response must be a vector or a one-column matrix")
+ extra$M = M = 2 * length(extra$kappa)
+ extra$n = n
+ extra$y.names = y.names = paste("tau=", round(extra$tau, dig=.digt),
+ sep="")
+ extra$individual = FALSE
+ predictors.names =
+ c(namesof(paste("quantile(", y.names, ")", sep=""),
+ .llocation, earg=.elocation, tag=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) {
+ location.init = weighted.mean(y, w)
+ scale.init = sqrt(var(y) / 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) {
+ 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)
+ scale.init = sqrt(sum(w*abs(y-median(y))) / (sum(w) *2))
+ } else {
+ use.this = weighted.mean(y, w)
+ 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
+ rep(location.init, len=n)
+ location.init = matrix(location.init, n, M/2)
+ scale.init = if(length(.iscale)) rep(.iscale, len=n) else
+ rep(scale.init, len=n)
+ scale.init = matrix(scale.init, n, M/2)
+ etastart =
+ cbind(theta2eta(location.init, .llocation, earg= .elocation),
+ theta2eta(scale.init, .lscale, earg= .escale))
+ }
+ }), list( .method.init=method.init,
+ .dfmu.init=dfmu.init,
+ .sinit=shrinkage.init, .digt=digt,
+ .elocation=elocation, .escale=escale,
+ .llocation=llocation, .lscale=lscale, .kappa=kappa,
+ .ilocation=ilocation, .iscale=iscale ))),
+ inverse=eval(substitute(function(eta, extra=NULL) {
+ 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)
+ Scale = eta2theta(eta[,(1+extra$M/2):extra$M], .lscale, earg= .escale)
+ location + Scale * (1/kappamat - kappamat)
+ } else {
+ location = eta2theta(eta[,1:(extra$M/2),drop=FALSE],
+ .llocation, earg= .elocation)
+ dimnames(location) = list(dimnames(eta)[[1]], extra$y.names)
+ location
+ }
+ }, list( .elocation=elocation, .llocation=llocation,
+ .fittedMean=fittedMean, .escale=escale, .lscale=lscale,
+ .kappa=kappa ))),
+ last=eval(substitute(expression({
+ misc$link = c(location= .llocation, scale= .lscale)
+ misc$earg = list(location= .elocation, scale= .escale)
+ misc$expected = TRUE
+ extra$kappa = misc$kappa = .kappa
+ extra$tau = misc$tau = misc$kappa^2 / (1 + misc$kappa^2)
+ misc$true.mu = .fittedMean # @fitted is not a true mu?
+ extra$percentile = numeric(length(misc$kappa))
+ location = as.matrix(location)
+ for(ii in 1:length(misc$kappa))
+ extra$percentile[ii] = 100 * weighted.mean(y <= location[,ii], w)
+ }), list( .elocation=elocation, .llocation=llocation,
+ .escale=escale, .lscale=lscale,
+ .fittedMean=fittedMean,
+ .kappa=kappa ))),
+ loglikelihood=eval(substitute(
+ function(mu,y,w,residuals= FALSE,eta, extra=NULL) {
+ ymat = matrix(y, extra$n, extra$M/2)
+ kappamat = matrix(extra$kappa, extra$n, extra$M/2, byrow=TRUE)
+ location = eta2theta(eta[,1:(extra$M/2),drop=FALSE],
+ .llocation, earg= .elocation)
+ Scale = eta2theta(eta[,(1+extra$M/2):extra$M], .lscale, earg= .escale)
+ zedd = ifelse(ymat >= location, kappamat, 1/kappamat) * sqrt(2) *
+ abs(ymat-location) / Scale
+ if(residuals) stop("loglikelihood residuals not implemented yet") else
+ sum(w*(-zedd - log(Scale) - log(2)/2 + log(kappa) - log1p(kappamat^2)))
+ }, list( .elocation=elocation, .llocation=llocation,
+ .escale=escale, .lscale=lscale,
+ .kappa=kappa ))),
+ vfamily=c("alaplace2"),
+ deriv=eval(substitute(expression({
+ ymat = matrix(y, n, M/2)
+ Scale = eta2theta(eta[,(1+extra$M/2):extra$M], .lscale, earg= .escale)
+ location = eta2theta(eta[,1:(extra$M/2),drop=FALSE],
+ .llocation, earg= .elocation)
+ kappamat = matrix(extra$kappa, n, M/2, byrow=TRUE)
+ zedd = abs(ymat-location) / Scale
+ dl.dlocation = sqrt(2) * ifelse(ymat >= location, kappamat, 1/kappamat) *
+ sign(ymat-location) / Scale
+ dl.dscale = sqrt(2) * ifelse(ymat >= location, kappamat, 1/kappamat) *
+ zedd / Scale - 1 / Scale
+ dlocation.deta = dtheta.deta(location, .llocation, earg= .elocation)
+ dscale.deta = dtheta.deta(Scale, .lscale, earg= .escale)
+ w * cbind(dl.dlocation * dlocation.deta,
+ dl.dscale * dscale.deta)
+ }), list( .escale=escale, .lscale=lscale,
+ .elocation=elocation, .llocation=llocation,
+ .kappa=kappa ))),
+ weight=eval(substitute(expression({
+ d2l.dlocation2 = 2 / Scale^2
+ d2l.dscale2 = 1 / Scale^2
+ wz = cbind(d2l.dlocation2 * dlocation.deta^2,
+ d2l.dscale2 * dscale.deta^2)
+ w * wz
+ }), list( .escale=escale, .lscale=lscale,
+ .elocation=elocation, .llocation=llocation ))))
+}
+
+
+
+
+alaplace1 = function(tau = NULL,
+ llocation="identity",
+ elocation=list(),
+ ilocation=NULL,
+ kappa = sqrt(tau/(1-tau)),
+ Scale.arg=1,
+ shrinkage.init=0.95, parallelLocation=FALSE, digt=4,
+ dfmu.init = 3,
+ method.init=1, zero=NULL) {
+
+ if(!is.Numeric(kappa, posit=TRUE))
+ stop("bad input for argument \"kappa\"")
+ if(length(tau) && max(abs(kappa - sqrt(tau/(1-tau)))) > 1.0e-6)
+ stop("arguments 'kappa' and 'tau' do not match")
+ if(mode(llocation) != "character" && mode(llocation) != "name")
+ llocation = as.character(substitute(llocation))
+ if(!is.Numeric(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 ||
+ shrinkage.init > 1) stop("bad input for argument \"shrinkage.init\"")
+ if(length(zero) &&
+ !(is.Numeric(zero, integer=TRUE, posit=TRUE) || is.character(zero )))
+ stop("bad input for argument \"zero\"")
+ if(!is.Numeric(Scale.arg, posit=TRUE))
+ stop("bad input for argument \"Scale.arg\"")
+ if(!is.logical(parallelLocation) || length(parallelLocation) != 1)
+ stop("bad input for argument \"parallelLocation\"")
+ fittedMean = FALSE
+ if(!is.logical(fittedMean) || length(fittedMean) != 1)
+ stop("bad input for argument \"fittedMean\"")
+
+ new("vglmff",
+ blurb=c("One-parameter asymmetric Laplace distribution\n\n",
+ "Links: ",
+ namesof("location", llocation, earg=elocation),
+ "\n", "\n",
+ "Mean: location + scale * (1/kappa - kappa) / sqrt(2)", "\n",
+ "Quantiles: location", "\n",
+ "Variance: scale^2 * (1 + kappa^4) / (2 * kappa^2)"),
+ constraints=eval(substitute(expression({
+ constraints = cm.vgam(matrix(1,M,1), x, .parallelLocation,
+ constraints, intercept=FALSE)
+ constraints = cm.zero.vgam(constraints, x, .zero, M)
+ }), list( .parallelLocation=parallelLocation,
+ .Scale.arg=Scale.arg, .zero=zero ))),
+ initialize=eval(substitute(expression({
+ extra$M = M = max(length( .Scale.arg ), length( .kappa )) # Recycle
+ 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)
+ 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),
+ sep="")
+ extra$individual = FALSE
+ predictors.names = namesof(paste("quantile(", y.names, ")", sep=""),
+ .llocation, earg=.elocation, tag=FALSE)
+
+ if(!length(etastart)) {
+ if( .method.init == 1) {
+ location.init = weighted.mean(y, w)
+ } else if( .method.init == 2) {
+ location.init = median(y)
+ } 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)
+ } else {
+ use.this = weighted.mean(y, w)
+ location.init = (1- .sinit)*y + .sinit * use.this
+ }
+ location.init = if(length(.ilocation)) rep(.ilocation, len=n) else
+ rep(location.init, len=n)
+ location.init = matrix(location.init, n, M)
+ etastart =
+ cbind(theta2eta(location.init, .llocation, earg= .elocation))
+ }
+ }), list( .method.init=method.init,
+ .dfmu.init=dfmu.init,
+ .sinit=shrinkage.init, .digt=digt,
+ .elocation=elocation, .Scale.arg=Scale.arg,
+ .llocation=llocation, .kappa=kappa,
+ .ilocation=ilocation ))),
+ inverse=eval(substitute(function(eta, extra=NULL) {
+ 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)
+ 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({
+ misc$link = c(location= .llocation)
+ misc$earg = list(location= .elocation)
+ misc$expected = TRUE
+ extra$kappa = misc$kappa = .kappa
+ extra$tau = misc$tau = misc$kappa^2 / (1 + misc$kappa^2)
+ extra$Scale.arg = .Scale.arg
+ misc$true.mu = .fittedMean # @fitted is not a true mu?
+ extra$percentile = numeric(length(misc$kappa))
+ location = as.matrix(location)
+ for(ii in 1:length(misc$kappa))
+ extra$percentile[ii] = 100 * weighted.mean(y <= location[,ii], w)
+ }), list( .elocation=elocation, .llocation=llocation,
+ .Scale.arg=Scale.arg, .fittedMean=fittedMean,
+ .kappa=kappa ))),
+ loglikelihood=eval(substitute(
+ function(mu,y,w,residuals= FALSE,eta, extra=NULL) {
+ ymat = matrix(y, extra$n, extra$M)
+ 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)
+ zedd = ifelse(ymat >= location, kappamat, 1/kappamat) * sqrt(2) *
+ abs(ymat-location) / Scale
+ if(residuals) stop("loglikelihood residuals not implemented yet") else
+ sum(w*(-zedd - log(Scale) - log(2)/2 + log(kappa) - log1p(kappamat^2)))
+ }, list( .elocation=elocation, .llocation=llocation,
+ .Scale.arg=Scale.arg, .kappa=kappa ))),
+ vfamily=c("alaplace1"),
+ deriv=eval(substitute(expression({
+ ymat = matrix(y, n, M)
+ Scale = matrix(extra$Scale, extra$n, extra$M, byrow=TRUE)
+ location = eta2theta(eta, .llocation, earg= .elocation)
+ kappamat = matrix(extra$kappa, n, M, byrow=TRUE)
+ zedd = abs(ymat-location) / Scale
+ dl.dlocation = ifelse(ymat >= location, kappamat, 1/kappamat) *
+ sqrt(2) * sign(ymat-location) / Scale
+ dl.dscale = ifelse(ymat >= location, kappamat, 1/kappamat) *
+ sqrt(2) * zedd / Scale - 1 / Scale
+ dlocation.deta = dtheta.deta(location, .llocation, earg= .elocation)
+ w * cbind(dl.dlocation * dlocation.deta)
+ }), list( .Scale.arg=Scale.arg, .elocation=elocation,
+ .llocation=llocation, .kappa=kappa ))),
+ weight=eval(substitute(expression({
+ d2l.dlocation2 = 2 / Scale^2
+ wz = cbind(d2l.dlocation2 * dlocation.deta^2)
+ w * wz
+ }), list( .Scale.arg=Scale.arg,
+ .elocation=elocation, .llocation=llocation ))))
+}
+
+
+
+
+
+
+alaplace3 = function(llocation="identity", lscale="loge", lkappa="loge",
+ elocation=list(), escale=list(), ekappa=list(),
ilocation=NULL, iscale=NULL, ikappa=1.0,
- method.init=1, zero=NULL) {
+ method.init=1, zero=2:3) {
if(mode(llocation) != "character" && mode(llocation) != "name")
llocation = as.character(substitute(llocation))
if(mode(lscale) != "character" && mode(lscale) != "name")
@@ -8046,6 +8939,8 @@ alaplace = function(llocation="identity", lscale="loge",
method.init > 2) stop("argument \"method.init\" must be 1 or 2")
if(length(zero) && !is.Numeric(zero, integer=TRUE, posit=TRUE))
stop("bad input for argument \"zero\"")
+ 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()
@@ -8059,7 +8954,7 @@ alaplace = function(llocation="identity", lscale="loge",
"\n", "\n",
"Mean: location + scale * (1/kappa - kappa) / sqrt(2)",
"\n",
- "Variance: mean^2 + scale^2"),
+ "Variance: Scale^2 * (1 + kappa^4) / (2 * kappa^2)"),
constraints=eval(substitute(expression({
constraints = cm.zero.vgam(constraints, x, .zero, M)
}), list( .zero=zero ))),
@@ -8099,7 +8994,7 @@ alaplace = function(llocation="identity", lscale="loge",
kappa = eta2theta(eta[,3], .lkappa, earg= .ekappa)
location + Scale * (1/kappa - kappa) / sqrt(2)
}, list( .elocation=elocation, .llocation=llocation,
- .escale=ekappa, .lscale=lkappa,
+ .escale=escale, .lscale=lscale,
.ekappa=ekappa, .lkappa=lkappa ))),
last=eval(substitute(expression({
misc$link = c(location= .llocation, scale= .lscale, kappa= .lkappa)
@@ -8120,7 +9015,7 @@ alaplace = function(llocation="identity", lscale="loge",
}, list( .elocation=elocation, .llocation=llocation,
.escale=escale, .lscale=lscale,
.ekappa=ekappa, .lkappa=lkappa ))),
- vfamily=c("alaplace"),
+ vfamily=c("alaplace3"),
deriv=eval(substitute(expression({
location = eta2theta(eta[,1], .llocation, earg= .elocation)
Scale = eta2theta(eta[,2], .lscale, earg= .escale)
@@ -8160,20 +9055,25 @@ alaplace = function(llocation="identity", lscale="loge",
}
+
+
+
laplace = function(llocation="identity", lscale="loge",
elocation=list(), escale=list(),
ilocation=NULL, iscale=NULL,
- method.init=1, zero=NULL) {
+ method.init=1, zero=2) {
if(mode(llocation) != "character" && mode(llocation) != "name")
llocation = as.character(substitute(llocation))
if(mode(lscale) != "character" && mode(lscale) != "name")
lscale = as.character(substitute(lscale))
if(!is.Numeric(method.init, allow=1, integ=TRUE, posit=TRUE) ||
- method.init > 2) stop("argument \"method.init\" must be 1 or 2")
+ method.init > 3) stop("argument \"method.init\" must be 1 or 2 or 3")
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))
+ stop("bad input for argument \"iscale\"")
new("vglmff",
blurb=c("Two-parameter Laplace distribution\n\n",
@@ -8196,8 +9096,11 @@ laplace = function(llocation="identity", lscale="loge",
if( .method.init == 1) {
location.init = median(y)
scale.init = sqrt(var(y) / 2)
+ } else if( .method.init == 2) {
+ location.init = weighted.mean(y, w)
+ scale.init = sqrt(var(y) / 2)
} else {
- location.init = y
+ 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
@@ -8244,9 +9147,8 @@ laplace = function(llocation="identity", lscale="loge",
}), list( .escale=escale, .lscale=lscale,
.elocation=elocation, .llocation=llocation ))),
weight=eval(substitute(expression({
- d2l.dlocation2 = 1 / Scale^2
- d2l.dscale2 = 1 / Scale^2
- wz = matrix(0, nrow=n, ncol=2) # diagonal
+ d2l.dlocation2 = d2l.dscale2 = 1 / Scale^2
+ wz = matrix(0, nrow=n, ncol=M) # diagonal
wz[,iam(1,1,M)] = d2l.dlocation2 * dlocation.deta^2
wz[,iam(2,2,M)] = d2l.dscale2 * dscale.deta^2
w * wz
@@ -8400,101 +9302,6 @@ fff = function(link="loge", earg=list(),
-vonmises = function(llocation="elogit",
- lscale="loge",
- elocation=if(llocation=="elogit") list(min=0, max=2*pi) else list(),
- escale=list(),
- ilocation=NULL, iscale=NULL,
- method.init=1, zero=NULL) {
- if(mode(llocation) != "character" && mode(llocation) != "name")
- llocation = as.character(substitute(llocation))
- if(mode(lscale) != "character" && mode(lscale) != "name")
- lscale = as.character(substitute(lscale))
- if(!is.Numeric(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))
- stop("bad input for argument \"zero\"")
- if(!is.list(escale)) escale = list()
-
- new("vglmff",
- blurb=c("Von Mises distribution\n\n",
- "Links: ",
- namesof("location", llocation, earg= elocation), ", ",
- namesof("scale", lscale, earg=escale),
- "\n", "\n",
- "Mean: location"),
- constraints=eval(substitute(expression({
- constraints = cm.zero.vgam(constraints, x, .zero, M)
- }), list( .zero=zero ))),
- initialize=eval(substitute(expression({
- if(ncol(cbind(y)) != 1)
- stop("response must be a vector or a one-column matrix")
- predictors.names =
- c(namesof("location", .llocation, earg= .elocation, tag=FALSE),
- namesof("scale", .lscale, earg=.escale, tag=FALSE))
- 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)
- } else {
- 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
- rep(location.init, len=n)
- scale.init= if(length(.iscale)) rep(.iscale,len=n) else rep(1,len=n)
- etastart = cbind(
- theta2eta(location.init, .llocation, earg= .elocation),
- theta2eta(scale.init, .lscale, earg= .escale))
- }
- y = y %% (2*pi) # Coerce after initial values have been computed
- }), list( .method.init=method.init, .ilocation=ilocation,
- .escale=escale, .iscale=iscale,
- .lscale=lscale, .llocation=llocation, .elocation=elocation ))),
- inverse=eval(substitute(function(eta, extra=NULL) {
- eta2theta(eta[,1], .llocation, earg= .elocation) %% (2*pi)
- }, list( .escale=escale, .lscale=lscale,
- .llocation=llocation, .elocation=elocation ))),
- last=eval(substitute(expression({
- misc$link = c(location= .llocation, scale= .lscale)
- misc$earg = list(location= .elocation, scale= .escale )
- }), list( .escale=escale, .lscale=lscale,
- .llocation=llocation, .elocation=elocation ))),
- loglikelihood=eval(substitute(
- function(mu,y,w,residuals= FALSE,eta, extra=NULL) {
- location = eta2theta(eta[,1], .llocation, earg= .elocation)
- Scale = eta2theta(eta[,2], .lscale, earg= .escale)
- if(residuals) stop("loglikelihood residuals not implemented yet") else
- sum(w * (Scale * cos(y - location) -
- log(mbesselI0(x=Scale ))))
- }, list( .escale=escale, .lscale=lscale,
- .llocation=llocation, .elocation=elocation ))),
- vfamily=c("vonmises"),
- deriv=eval(substitute(expression({
- location = eta2theta(eta[,1], .llocation, earg= .elocation)
- Scale = eta2theta(eta[,2], .lscale, earg= .escale)
- tmp6 = mbesselI0(x=Scale, deriv=2)
- dl.dlocation = Scale * sin(y - location)
- dlocation.deta = dtheta.deta(location, .llocation, earg= .elocation)
- dl.dscale = cos(y - location) - tmp6[,2] / tmp6[,1]
- dscale.deta = dtheta.deta(Scale, .lscale, earg= .escale)
- w * cbind(dl.dlocation * dlocation.deta,
- dl.dscale * dscale.deta)
- }), list( .escale=escale, .lscale=lscale,
- .llocation=llocation, .elocation=elocation ))),
- weight=eval(substitute(expression({
- d2l.location2 = Scale * tmp6[,2] / tmp6[,1]
- d2l.dscale2 = tmp6[,3] / tmp6[,1] - (tmp6[,2] / tmp6[,1])^2
- wz = matrix(as.numeric(NA), nrow=n, ncol=2) # diagonal
- wz[,iam(1,1,M)] = d2l.location2 * dlocation.deta^2
- wz[,iam(2,2,M)] = d2l.dscale2 * dscale.deta^2
- w * wz
- }), list( .escale=escale, .lscale=lscale,
- .llocation=llocation, .elocation=elocation ))))
-}
-
-
hyperg = function(N=NULL, D=NULL,
lprob="logit", earg=list(),
@@ -8534,6 +9341,7 @@ hyperg = function(N=NULL, D=NULL,
y = ifelse(nn > 0, y[,1]/nn, 0)
w = w * nn
mustart = (0.5 + nn * y) / (1 + nn)
+ mustart[mustart >= 1] = 0.95
} else
stop("Response not of the right form")
@@ -8611,7 +9419,8 @@ hyperg = function(N=NULL, D=NULL,
trigamma(1+Nvec*(1-prob)-w+yvec))
}
d2prob.deta2 = d2theta.deta2(prob, .lprob, earg= .earg)
- wz = -(dprob.deta^2) * d2l.dprob2 - d2prob.deta2 * dl.dprob
+
+ wz = -(dprob.deta^2) * d2l.dprob2
wz = w * wz
wz[wz < .Machine$double.eps] = .Machine$double.eps
wz
@@ -8641,7 +9450,7 @@ pbenini = function(q, shape, y0) {
q = rep(q, len=N); shape = rep(shape, len=N); y0 = rep(y0, len=N);
ans = y0 * 0
ok = q > y0
- ans[ok] = 1 - exp(-shape[ok] * (log(q[ok]/y0[ok]))^2)
+ ans[ok] = -expm1(-shape[ok] * (log(q[ok]/y0[ok]))^2)
ans
}
@@ -8733,27 +9542,41 @@ benini = function(y0=stop("argument \"y0\" must be specified"),
-dpolono = function(x, meanlog=0, sdlog=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\"")
+dpolono = function(x, meanlog=0, sdlog=1, bigx=Inf, ...) {
+ if(!is.Numeric(x)) stop("bad input for argument 'x'")
+ if(!is.Numeric(meanlog)) stop("bad input for argument 'meanlog'")
+ if(!is.Numeric(sdlog, posit=TRUE)) stop("bad input for argument 'sdlog'")
+ if(length(bigx) != 1)
+ stop("bad input for argument 'bigx'")
+ if(bigx < 10)
+ warning("argument 'bigx' is probably too small")
N = max(length(x), length(meanlog), length(sdlog))
- x = rep(x, len=N); meanlog = rep(meanlog, len=N); sdlog = rep(sdlog, len=N);
+ x = rep(x, len=N); meanlog = rep(meanlog, len=N); sdlog = rep(sdlog, len=N)
ans = x * 0
integrand = function(t, x, meanlog, sdlog)
exp(t*x - exp(t) - 0.5*((t-meanlog)/sdlog)^2)
for(i in 1:N) {
if(x[i] == round(x[i]) && x[i] >= 0) {
- temp = integrate(f=integrand, lower=-Inf, upper=Inf,
- x=x[i], meanlog=meanlog[i], sdlog=sdlog[i], ...)
- if(temp$message == "OK") ans[i] = temp$value else {
- warning(paste("could not integrate (numerically) observation", i))
- ans[i] = NA
+ if(x[i] >= bigx) {
+ zedd = (log(x[i])-meanlog[i]) / sdlog[i]
+ temp = 1 + (zedd^2 + log(x[i]) - meanlog[i] -
+ 1) / (2*x[i]*(sdlog[i])^2)
+ ans[i] = temp * exp(-0.5*zedd^2)/(sqrt(2*pi) * sdlog[i] * x[i])
+ } else {
+ temp = integrate(f=integrand, lower=-Inf, upper=Inf,
+ x=x[i], meanlog=meanlog[i], sdlog=sdlog[i], ...)
+ if(temp$message == "OK") {
+ ans[i] = temp$value / (sqrt(2*pi) * sdlog[i] *
+ exp(lgamma(x[i]+1)))
+ } else {
+ warning(paste("could not integrate",
+ " (numerically) observation", i))
+ ans[i] = NA
+ }
}
}
}
- ans = ans / (sqrt(2*pi) * sdlog * gamma(x+1))
- ifelse(x == round(x) & x >= 0, ans, 0)
+ ans
}
diff --git a/R/family.vglm.q b/R/family.vglm.q
index 67a9bd7..541e790 100644
--- a/R/family.vglm.q
+++ b/R/family.vglm.q
@@ -1,5 +1,5 @@
# These functions are
-# Copyright (C) 1998-2007 T.W. Yee, University of Auckland. All rights reserved.
+# Copyright (C) 1998-2008 T.W. Yee, University of Auckland. All rights reserved.
diff --git a/R/family.zeroinf.q b/R/family.zeroinf.q
index 78adea3..2728ac4 100644
--- a/R/family.zeroinf.q
+++ b/R/family.zeroinf.q
@@ -1,5 +1,5 @@
# These functions are
-# Copyright (C) 1998-2007 T.W. Yee, University of Auckland. All rights reserved.
+# Copyright (C) 1998-2008 T.W. Yee, University of Auckland. All rights reserved.
@@ -12,7 +12,7 @@ dzipois = function(x, lambda, phi=0) {
x = rep(x, len=L); lambda = rep(lambda, len=L); phi = rep(phi, len=L);
ans = dpois(x, lambda)
if(!is.Numeric(phi) || any(phi < 0) || any(phi > 1))
- stop("phi must be between 0 and 1 inclusive")
+ stop("'phi' must be between 0 and 1 inclusive")
ifelse(x==0, phi + (1-phi) * ans, (1-phi) * ans)
}
@@ -20,7 +20,7 @@ pzipois = function(q, lambda, phi=0) {
ans = ppois(q, lambda)
phi = rep(phi, length=length(ans))
if(!is.Numeric(phi) || any(phi < 0) || any(phi > 1))
- stop("phi must be between 0 and 1 inclusive")
+ stop("'phi' must be between 0 and 1 inclusive")
phi + (1-phi) * ans
}
@@ -30,7 +30,7 @@ qzipois = function(p, lambda, phi=0) {
lambda = rep(lambda, len=nn)
phi = rep(phi, len=nn)
if(!is.Numeric(phi) || any(phi < 0) || any(phi > 1))
- stop("phi must be between 0 and 1 inclusive")
+ stop("'phi' must be between 0 and 1 inclusive")
ans = p
ans[p<=phi] = 0
ans[p>phi] = qpois((p[p>phi]-phi[p>phi])/(1-phi[p>phi]), lam=lambda[p>phi])
@@ -39,7 +39,7 @@ qzipois = function(p, lambda, phi=0) {
rzipois = function(n, lambda, phi=0) {
if(!is.Numeric(n, positive=TRUE, integer=TRUE, allow=1))
- stop("n must be a single positive integer")
+ stop("'n' must be a single positive integer")
ans = rpois(n, lambda)
phi = rep(phi, len=length(ans))
if(!is.Numeric(phi) || any(phi < 0) || any(phi > 1))
@@ -531,8 +531,8 @@ zipoisson = function(lphi="logit", llambda="loge",
phi.init = if(length( .iphi)) .iphi else {
sum(w[y==0]) / sum(w)
}
- phi.init[phi.init <= 0] = 0.05 # Last resort
- phi.init[phi.init >= 1] = 0.95 # Last resort
+ phi.init[phi.init <= 0.02] = 0.02 # Last resort
+ phi.init[phi.init >= 0.98] = 0.98 # Last resort
if( .method.init == 2) {
mymean = weighted.mean(y[y>0], w[y>0]) + 1/16
lambda.init = (1- .sinit) * (y+1/8) + .sinit * mymean
@@ -803,3 +803,352 @@ rzibinom = function(n, size, prob, phi=0) {
+
+
+
+
+dzinb = function(x, phi, size, prob, munb, log=FALSE) {
+ if (!missing(munb)) {
+ if (!missing(prob))
+ stop("'prob' and 'munb' both specified")
+ prob <- size/(size + munb)
+ }
+ log.arg = log
+ rm(log)
+ if(!is.logical(log.arg) || length(log.arg) != 1)
+ stop("bad input for 'log.arg'")
+ ans = dnbinom(x=x, size=size, prob=prob, log = log.arg)
+ 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)
+}
+
+pzinb = function(q, phi, size, prob, munb) {
+ if (!missing(munb)) {
+ if (!missing(prob))
+ stop("'prob' and 'munb' both specified")
+ prob <- size/(size + munb)
+ }
+ ans = pnbinom(q=q, size=size, prob=prob)
+ if(!is.Numeric(phi) || any(phi < 0) || any(phi > 1))
+ stop("'phi' must be between 0 and 1 inclusive")
+ phi + (1-phi) * ans
+}
+
+qzinb = function(p, phi, size, prob, munb) {
+ if (!missing(munb)) {
+ if (!missing(prob))
+ 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))
+ 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])
+ ans
+}
+
+rzinb = function(n, phi, size, prob, munb) {
+ if (!missing(munb)) {
+ if (!missing(prob))
+ 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))
+ stop("'phi' must be between 0 and 1 inclusive")
+ phi = rep(phi, len=length(ans))
+ ifelse(runif(n) < phi, rep(0, n), ans)
+}
+
+
+
+
+zinegbinomial.control <- function(save.weight=TRUE, ...)
+{
+ list(save.weight=save.weight)
+}
+
+
+
+zinegbinomial = function(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)
+{
+ 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))
+ stop("'ik' must contain positive values only")
+ 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) || nsimEIM <= 50)
+ stop("'nsimEIM' should be an integer greater than 50")
+ 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")
+ lmunb = as.character(substitute(lmunb))
+ if(mode(lk) != "character" && mode(lk) != "name")
+ lk = as.character(substitute(lk))
+ 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()
+
+ new("vglmff",
+ blurb=c("Zero-inflated negative binomial\n\n",
+ "Links: ",
+ namesof("phi", lphi, earg= ephi, tag=FALSE), ", ",
+ namesof("munb", lmunb, earg= emunb, tag=FALSE), ", ",
+ namesof("k", lk, earg= ek, tag=FALSE), "\n",
+ "Mean: (1-phi) * munb"),
+ constraints=eval(substitute(expression({
+ temp752 = .zero
+ 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)))
+ 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="")
+ 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) {
+ y + 1/16
+ } else {
+ mu.init = y
+ for(iii in 1:ncol(y)) {
+ index = (y[,iii] > 0)
+ 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))
+ matrix( .iphi, n, ncoly, byrow=TRUE) else {
+ phi.init = y
+ for(iii in 1:ncol(y))
+ phi.init[,iii] = sum(w[y[,iii]==0]) / sum(w)
+ phi.init[phi.init <= 0.02] = 0.02 # Last resort
+ phi.init[phi.init >= 0.98] = 0.98 # Last resort
+ phi.init
+ }
+
+ kay.init =
+ if( is.Numeric( .ik )) {
+ matrix( .ik, nr=n, nc=ncoly, byrow=TRUE)
+ } else {
+ zinb.Loglikfun = function(kval, y, x, w, extraargs) {
+ index = (y == 0)
+ phivec = extraargs$phi
+ muvec = extraargs$mu
+ tmp8 = phivec[index] + (1.0-phivec[index]) *
+ dnbinom(y[index], mu= muvec[index], size=kval)
+ ell0 = log(tmp8)
+ ell1 = log1p(-phivec[!index]) + dnbinom(y[!index],
+ mu= muvec[!index], size=kval, log=TRUE)
+ sum(w[index] * ell0) + sum(w[!index] * ell1)
+ }
+ k.grid = 2^((-3):6)
+ kay.init = matrix(0, nr=n, nc=NOS)
+ for(spp. in 1:NOS) {
+ kay.init[,spp.] = getMaxMin(k.grid,
+ objfun=zinb.Loglikfun,
+ y=y[,spp.], x=x, w=w,
+ extraargs= list(phi=phi.init[,spp.],
+ mu=mu.init[,spp.]))
+ }
+ kay.init
+ }
+
+ etastart = cbind(theta2eta(phi.init, .lphi, earg= .ephi),
+ theta2eta(mu.init, .lmunb, earg= .emunb),
+ 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,
+ .ephi=ephi, .emunb=emunb, .ek=ek,
+ .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))
+ dimnames(fv.matrix) = list(dimnames(phi)[[1]], extra$dimnamesy2)
+ fv.matrix
+ }, list( .lphi=lphi, .lk=lk, .lmunb=lmunb,
+ .ephi=ephi, .emunb=emunb, .ek=ek ))),
+ last=eval(substitute(expression({
+ misc$link = c(rep( .lphi, length=NOS), rep( .lmunb, length=NOS),
+ rep( .lk, length=NOS))
+ temp.names = c(mynames1, mynames2, mynames3)
+ temp.names = temp.names[interleave.VGAM(3*NOS, M=3)]
+ names(misc$link) = temp.names
+ misc$earg = vector("list", 3*NOS)
+ names(misc$earg) = temp.names
+ for(ii in 1:NOS) {
+ misc$earg[[3*ii-2]] = .ephi
+ misc$earg[[3*ii-1]] = .emunb
+ misc$earg[[3*ii ]] = .ek
+ }
+ misc$method.init = .method.init
+ misc$nsimEIM = .nsimEIM
+ misc$expected = TRUE
+ 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)
+ misc$prob0 = phi + (1-phi) * (kval / (kval + munb))^kval # P(Y=0)
+ }
+ }), list( .lphi=lphi, .lmunb=lmunb, .lk=lk,
+ .ephi=ephi, .emunb=emunb, .ek=ek, .nsimEIM=nsimEIM,
+ .method.init=method.init ))),
+ loglikelihood=eval(substitute(
+ function(mu,y,w,residuals=FALSE, 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 )
+ kmat = eta2theta(eta[,3*(1:NOS), drop=FALSE], .lk, earg= .ek )
+
+
+ ans = 0.0
+ for(spp. in 1:NOS) {
+ ytemp = y[,spp.]
+ phitemp = phi[,spp.]
+ ktemp = kmat[,spp.]
+ mutemp = munb[,spp.]
+ index = (ytemp == 0)
+ tmp8 = phitemp[index] + (1.0-phitemp[index]) *
+ dnbinom(ytemp[index], mu= mutemp[index], size=ktemp[index])
+ ell0 = log(tmp8)
+ ell1 = log1p(-phitemp[!index]) + dnbinom(ytemp[!index],
+ mu= mutemp[!index], size=ktemp[!index], log=TRUE)
+ ans = ans + sum(w[index] * ell0) + sum(w[!index] * ell1)
+ }
+ ans
+ }, list( .lphi=lphi, .lmunb=lmunb, .lk=lk,
+ .ephi=ephi, .emunb=emunb, .ek=ek ))),
+ vfamily=c("zinegbinomial"),
+ deriv=eval(substitute(expression({
+ 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 )
+ kmat = eta2theta(eta[,3*(1:NOS), drop=FALSE], .lk, earg= .ek )
+ dphi.deta = dtheta.deta(phi, .lphi, earg= .ephi )
+ dmunb.deta = dtheta.deta(munb, .lmunb, earg= .emunb )
+ dk.deta = dtheta.deta(kmat, .lk, earg= .ek )
+ dthetas.detas = (cbind(dphi.deta, dmunb.deta,
+ dk.deta))[,interleave.VGAM(3*NOS, M=3)]
+
+ d3 = deriv3(~ log(phi. + (1 - phi.) * (kmat. /(kmat. + munb. ))^kmat.),
+ c("phi.", "munb.", "kmat."), hessian=FALSE)
+ 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))
+ stop("must have some 0s AND some positive counts in the data")
+
+ yvec. = y[index,spp.]
+ kmat. = kmat[index,spp.]
+ munb. = munb[index,spp.]
+ phi. = phi[index,spp.]
+ eval.d3 = eval(d3) # Evaluated for one species
+ dl.dthetas[index,(3*spp.-2):(3*spp.)] = attr(eval.d3, "gradient")
+
+ yvec. = y[!index,spp.]
+ kmat. = kmat[!index,spp.]
+ munb. = munb[!index,spp.]
+ phi. = phi[!index,spp.]
+ dl.dphi = -1/(1-phi.)
+ dl.dmunb = yvec. / munb. - (yvec. +kmat.)/(kmat.+munb.)
+ dl.dk = digamma(yvec. +kmat.) - digamma(kmat.) -
+ (yvec. +kmat.)/(munb.+kmat.) + 1 +
+ log(kmat./(kmat.+munb.))
+ dl.dthetas[!index,(3*spp.-2):(3*spp.)] =
+ cbind(dl.dphi, dl.dmunb, dl.dk)
+ }
+ w * dl.dthetas * dthetas.detas
+ }), list( .lphi=lphi, .lmunb=lmunb, .lk=lk,
+ .ephi=ephi, .emunb=emunb, .ek=ek ))),
+ weight=eval(substitute(expression({
+
+ wz = matrix(0, n, 3*(M-1))
+ ind8 = iam(NA, NA, M=M, both=TRUE, diag=TRUE)
+ ind1 = iam(NA, NA, M=3, both=TRUE, diag=TRUE)
+ for(spp. in 1:NOS) {
+ run.varcov = 0
+ sdl.dthetas = matrix(0, n, 3)
+ for(ii in 1:( .nsimEIM )) {
+ ysim = rzinb(n=n,phi=phi[,spp.],size=kmat[,spp.],mu=munb[,spp.])
+ index = (ysim == 0)
+
+ yvec. = ysim[index]
+ kmat. = kmat[index,spp.]
+ munb. = munb[index,spp.]
+ phi. = phi[index,spp.]
+ eval.d3 = eval(d3) # Evaluated for one species
+ sdl.dthetas[index,] = attr(eval.d3, "gradient")
+
+ yvec. = ysim[!index]
+ kmat. = kmat[!index,spp.]
+ munb. = munb[!index,spp.]
+ phi. = phi[!index,spp.]
+ dl.dphi = -1/(1-phi.)
+ dl.dmunb = yvec. / munb. - (yvec. +kmat.)/(kmat.+munb.)
+ dl.dk = digamma(yvec. +kmat.) - digamma(kmat.) -
+ (yvec. +kmat.)/(munb.+kmat.) + 1 +
+ log(kmat./(kmat.+munb.))
+ sdl.dthetas[!index,] = cbind(dl.dphi, dl.dmunb, dl.dk)
+ rm(ysim)
+ temp3 = sdl.dthetas
+ run.varcov = ((ii-1) * run.varcov +
+ temp3[,ind1$row.index]*temp3[,ind1$col.index]) / ii
+ }
+ wz1 = if(intercept.only)
+ matrix(apply(run.varcov, 2, mean),
+ nr=n, nc=ncol(run.varcov), byrow=TRUE) else run.varcov
+
+ wz1 = wz1 * dthetas.detas[,3*(spp. -1) + ind1$row] *
+ dthetas.detas[,3*(spp. -1) + ind1$col]
+
+ for(jay in 1:3)
+ for(kay in jay:3) {
+ cptr = iam((spp.-1)*3+jay, (spp.-1)*3+kay, M=M)
+ wz[,cptr] = wz1[,iam(jay, kay, M=3)]
+ }
+ }
+ w * wz
+ }), list( .lphi=lphi, .ephi=ephi, .nsimEIM=nsimEIM ))))
+}
+
+
+
+
diff --git a/R/fitted.vlm.q b/R/fitted.vlm.q
index 8df6421..e52aa55 100644
--- a/R/fitted.vlm.q
+++ b/R/fitted.vlm.q
@@ -1,5 +1,5 @@
# These functions are
-# Copyright (C) 1998-2007 T.W. Yee, University of Auckland. All rights reserved.
+# Copyright (C) 1998-2008 T.W. Yee, University of Auckland. All rights reserved.
diff --git a/R/generic.q b/R/generic.q
index 5bd7314..9150006 100644
--- a/R/generic.q
+++ b/R/generic.q
@@ -1,5 +1,5 @@
# These functions are
-# Copyright (C) 1998-2007 T.W. Yee, University of Auckland. All rights reserved.
+# Copyright (C) 1998-2008 T.W. Yee, University of Auckland. All rights reserved.
add1.vgam <- function(...)
diff --git a/R/links.q b/R/links.q
index 7917a99..ad545bf 100644
--- a/R/links.q
+++ b/R/links.q
@@ -1,5 +1,5 @@
# These functions are
-# Copyright (C) 1998-2007 T.W. Yee, University of Auckland. All rights reserved.
+# Copyright (C) 1998-2008 T.W. Yee, University of Auckland. All rights reserved.
@@ -16,6 +16,13 @@
+TypicalVGAMfamilyFunction <- function(lsigma="loge", esigma=list(),
+ isigma=NULL, parallel=TRUE,
+ method.init=1,
+ nsimEIM=100, zero=NULL) {
+ NULL
+}
+
TypicalVGAMlinkFunction <- function(theta,
earg=list(), inverse=FALSE, deriv=0, short=TRUE, tag=FALSE) {
NULL
@@ -178,13 +185,13 @@ cloglog <- function(theta, earg=list(), inverse=FALSE, deriv=0,
1 / Recall(theta=theta, earg=earg, inverse=FALSE, deriv=deriv)
} else {
junk <- exp(theta)
- 1 - exp(-junk)
+ -expm1(-junk)
}
} else {
switch(deriv+1, {
- log(-log(1-theta))},
- -(1-theta) * log(1-theta),
- { junk <- log(1 - theta)
+ log(-log1p(-theta))},
+ -(1-theta) * log1p(-theta),
+ { junk <- log1p(-theta)
-(1-theta) * (1 + junk) * junk
},
stop("'deriv' unmatched"))
@@ -464,11 +471,11 @@ rhobit <- function(theta, earg=list(), inverse=FALSE, deriv=0,
1/Recall(theta=theta, earg=earg, inverse=FALSE, deriv=deriv)
} else {
junk <- exp(theta)
- (junk-1.0) / (junk+1.0)
+ expm1(theta) / (junk+1.0)
}
} else {
switch(deriv+1,{
- log((1+theta)/(1-theta))},
+ log1p(theta) - log1p(-theta)},
(1 - theta^2) / 2,
(1 - theta^2)^2 / (4*theta))
}
@@ -500,11 +507,11 @@ fisherz <- function(theta, earg=list(), inverse=FALSE, deriv=0,
1/Recall(theta=theta, earg=earg, inverse=FALSE, deriv=deriv)
} else {
junk <- exp(2*theta)
- (junk-1.0)/(junk+1.0)
+ expm1(2*theta) / (junk+1.0)
}
} else {
switch(deriv+1,
- 0.5 * log((1.0+theta)/(1.0-theta)),
+ 0.5 * log1p(theta) - log1p(-theta),
1.0 - theta^2,
(1.0 - theta^2)^2 / (2*theta))
}
@@ -637,7 +644,7 @@ elogit <- function(theta, earg=list(min=0, max=1), inverse=FALSE, deriv=0,
1/Recall(theta=theta, earg=earg, inverse=FALSE, deriv=deriv)
} else {
junk <- if(is.R()) care.exp(theta) else care.exp(theta)
- (A + B*junk) / (1 + junk)
+ (A + B*junk) / (1.0 + junk)
}
} else {
switch(deriv+1, {
@@ -669,12 +676,12 @@ logit <- function(theta, earg=list(), inverse=FALSE, deriv=0,
1/Recall(theta=theta, earg=earg, inverse=FALSE, deriv=deriv)
} else {
eta <- care.exp(theta)
- eta / (1 + eta)
+ eta / (1.0 + eta)
}
} else {
switch(deriv+1, {
- log(theta/(1-theta))},
- theta * (1 - theta),
+ log(theta) - log1p(-theta)},
+ exp(log(theta) + log1p(-theta)),
theta * (1 - theta) * (1 - 2 * theta))
}
}
@@ -700,13 +707,13 @@ logc <- function(theta, earg=list(), inverse=FALSE, deriv=0,
if(deriv>0) {
1 / Recall(theta=theta, earg=earg, inverse=FALSE, deriv=deriv)
} else {
- 1 - exp(theta)
+ -expm1(theta)
}
} else {
switch(deriv+1,{
- log(1-theta)},
- -(1 - theta),
- -(1 - theta)^2)
+ log1p(-theta)},
+ -(1.0 - theta),
+ -(1.0 - theta)^2)
}
}
diff --git a/R/logLik.vlm.q b/R/logLik.vlm.q
index d834f60..238260b 100644
--- a/R/logLik.vlm.q
+++ b/R/logLik.vlm.q
@@ -1,5 +1,5 @@
# These functions are
-# Copyright (C) 1998-2007 T.W. Yee, University of Auckland. All rights reserved.
+# Copyright (C) 1998-2008 T.W. Yee, University of Auckland. All rights reserved.
diff --git a/R/model.matrix.vglm.q b/R/model.matrix.vglm.q
index 0cb0eb0..41db2b5 100644
--- a/R/model.matrix.vglm.q
+++ b/R/model.matrix.vglm.q
@@ -1,5 +1,5 @@
# These functions are
-# Copyright (C) 1998-2007 T.W. Yee, University of Auckland. All rights reserved.
+# Copyright (C) 1998-2008 T.W. Yee, University of Auckland. All rights reserved.
@@ -247,6 +247,7 @@ setMethod("model.matrix", "vlm", function(object, ...)
+
if(is.R()) {
model.framevlm = function(object, ...) {
diff --git a/R/mux.q b/R/mux.q
index 2dbee29..862e0f8 100644
--- a/R/mux.q
+++ b/R/mux.q
@@ -1,5 +1,5 @@
# These functions are
-# Copyright (C) 1998-2007 T.W. Yee, University of Auckland. All rights reserved.
+# Copyright (C) 1998-2008 T.W. Yee, University of Auckland. All rights reserved.
@@ -208,13 +208,12 @@ mux111 <- function(cc, xmat, M, upper=TRUE)
mux15 <- function(cc, xmat)
{
-
n <- nrow(xmat)
M <- ncol(xmat)
if(nrow(cc) != M || ncol(cc) != M)
stop("input inconformable")
if(max(abs(t(cc)-cc))>0.000001)
- stop("cc not symmetric")
+ stop("argument 'cc' is not symmetric")
ans <- rep(as.numeric(NA),n*M*M)
fred <- dotC(name="mux15", as.double(cc), as.double(t(xmat)),
@@ -347,3 +346,15 @@ vchol.greenstadt <- function(cc, M, silent=FALSE)
}
+
+
+myf = function(x) {
+ dotFortran("VGAM_F90_fill9",
+ x=as.double(x), lenx=as.integer(length(x)),
+ answer=as.double(x),
+ NAOK=TRUE)$answer
+}
+
+
+
+
diff --git a/R/plot.vglm.q b/R/plot.vglm.q
index 8710a63..a6fdd16 100644
--- a/R/plot.vglm.q
+++ b/R/plot.vglm.q
@@ -1,5 +1,5 @@
# These functions are
-# Copyright (C) 1998-2007 T.W. Yee, University of Auckland. All rights reserved.
+# Copyright (C) 1998-2008 T.W. Yee, University of Auckland. All rights reserved.
diff --git a/R/predict.vgam.q b/R/predict.vgam.q
index 1bcb3f7..079a2f5 100644
--- a/R/predict.vgam.q
+++ b/R/predict.vgam.q
@@ -1,5 +1,5 @@
# These functions are
-# Copyright (C) 1998-2007 T.W. Yee, University of Auckland. All rights reserved.
+# Copyright (C) 1998-2008 T.W. Yee, University of Auckland. All rights reserved.
diff --git a/R/predict.vglm.q b/R/predict.vglm.q
index 3c8a06a..7c444cb 100644
--- a/R/predict.vglm.q
+++ b/R/predict.vglm.q
@@ -1,5 +1,5 @@
# These functions are
-# Copyright (C) 1998-2007 T.W. Yee, University of Auckland. All rights reserved.
+# Copyright (C) 1998-2008 T.W. Yee, University of Auckland. All rights reserved.
diff --git a/R/predict.vlm.q b/R/predict.vlm.q
index b5e68cf..5658343 100644
--- a/R/predict.vlm.q
+++ b/R/predict.vlm.q
@@ -1,5 +1,5 @@
# These functions are
-# Copyright (C) 1998-2007 T.W. Yee, University of Auckland. All rights reserved.
+# Copyright (C) 1998-2008 T.W. Yee, University of Auckland. All rights reserved.
diff --git a/R/print.summary.others.q b/R/print.summary.others.q
index 01338ab..36b4ab7 100644
--- a/R/print.summary.others.q
+++ b/R/print.summary.others.q
@@ -1,5 +1,5 @@
# These functions are
-# Copyright (C) 1998-2007 T.W. Yee, University of Auckland. All rights reserved.
+# Copyright (C) 1998-2008 T.W. Yee, University of Auckland. All rights reserved.
diff --git a/R/print.vglm.q b/R/print.vglm.q
index b795cf8..bad11f4 100644
--- a/R/print.vglm.q
+++ b/R/print.vglm.q
@@ -1,5 +1,5 @@
# These functions are
-# Copyright (C) 1998-2007 T.W. Yee, University of Auckland. All rights reserved.
+# Copyright (C) 1998-2008 T.W. Yee, University of Auckland. All rights reserved.
print.vglm <- function(x, ...)
diff --git a/R/print.vlm.q b/R/print.vlm.q
index 193d113..f236d51 100644
--- a/R/print.vlm.q
+++ b/R/print.vlm.q
@@ -1,5 +1,5 @@
# These functions are
-# Copyright (C) 1998-2007 T.W. Yee, University of Auckland. All rights reserved.
+# Copyright (C) 1998-2008 T.W. Yee, University of Auckland. All rights reserved.
diff --git a/R/qrrvglm.control.q b/R/qrrvglm.control.q
index c830ad7..027dd10 100644
--- a/R/qrrvglm.control.q
+++ b/R/qrrvglm.control.q
@@ -1,5 +1,5 @@
# These functions are
-# Copyright (C) 1998-2007 T.W. Yee, University of Auckland. All rights reserved.
+# Copyright (C) 1998-2008 T.W. Yee, University of Auckland. All rights reserved.
qrrvglm.control = function(Rank=1,
diff --git a/R/qtplot.q b/R/qtplot.q
index 29a7d55..157d0bf 100644
--- a/R/qtplot.q
+++ b/R/qtplot.q
@@ -1,5 +1,5 @@
# These functions are
-# Copyright (C) 1998-2007 T.W. Yee, University of Auckland. All rights reserved.
+# Copyright (C) 1998-2008 T.W. Yee, University of Auckland. All rights reserved.
@@ -45,6 +45,7 @@ qtplot.lms.bcg <- function(percentiles=c(25,50,75),
answer
}
+qtplot.lms.yjn2 <-
qtplot.lms.yjn <- function(percentiles=c(25,50,75),
eta=NULL, yoffset=0)
{
@@ -381,7 +382,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
@@ -395,20 +396,21 @@ deplot.lms.bcg <- function(object,
}
-
+deplot.lms.yjn2 <-
deplot.lms.yjn <- function(object,
newdata,
y.arg,
eta0)
{
- if(!any(object at family@vfamily == "lms.yjn"))
+ if(!length(intersect(object at family@vfamily, c("lms.yjn","lms.yjn2"))))
warning("I think you've called the wrong function")
lambda <- eta0[,1]
Zvec <- (yeo.johnson(y.arg+object at misc$yoffset, lambda=eta0[,1]) -
eta0[,2]) / eta0[,3]
- dZ.dy <- dyj.dy(y.arg+object at misc$yoffset, lambda=eta0[,1]) / eta0[,3]
+ dZ.dy <- dyj.dy.yeojohnson(y.arg+object at misc$yoffset,
+ lambda=eta0[,1]) / eta0[,3]
yvec <- dnorm(Zvec) * abs(dZ.dy)
list(newdata=newdata, y=y.arg, density=yvec)
diff --git a/R/residuals.vlm.q b/R/residuals.vlm.q
index 31f5d87..021c6e7 100644
--- a/R/residuals.vlm.q
+++ b/R/residuals.vlm.q
@@ -1,5 +1,5 @@
# These functions are
-# Copyright (C) 1998-2007 T.W. Yee, University of Auckland. All rights reserved.
+# Copyright (C) 1998-2008 T.W. Yee, University of Auckland. All rights reserved.
diff --git a/R/rrvglm.R b/R/rrvglm.R
index 0a3164f..d56da97 100644
--- a/R/rrvglm.R
+++ b/R/rrvglm.R
@@ -1,5 +1,5 @@
# These functions are
-# Copyright (C) 1998-2007 T.W. Yee, University of Auckland. All rights reserved.
+# Copyright (C) 1998-2008 T.W. Yee, University of Auckland. All rights reserved.
diff --git a/R/rrvglm.control.q b/R/rrvglm.control.q
index 513f436..09a75b9 100644
--- a/R/rrvglm.control.q
+++ b/R/rrvglm.control.q
@@ -1,5 +1,5 @@
# These functions are
-# Copyright (C) 1998-2007 T.W. Yee, University of Auckland. All rights reserved.
+# Copyright (C) 1998-2008 T.W. Yee, University of Auckland. All rights reserved.
diff --git a/R/rrvglm.fit.q b/R/rrvglm.fit.q
index 07b206d..6f138de 100644
--- a/R/rrvglm.fit.q
+++ b/R/rrvglm.fit.q
@@ -1,5 +1,5 @@
# These functions are
-# Copyright (C) 1998-2007 T.W. Yee, University of Auckland. All rights reserved.
+# Copyright (C) 1998-2008 T.W. Yee, University of Auckland. All rights reserved.
@@ -17,6 +17,7 @@ rrvglm.fit <- function(x, y, w=rep(1, length(x[, 1])),
extra=NULL,
Terms=Terms, function.name="rrvglm", ...)
{
+ specialCM = NULL
post = list()
check.rank = TRUE # !control$Quadratic
nonparametric <- FALSE
@@ -302,7 +303,7 @@ rrvglm.fit <- function(x, y, w=rep(1, length(x[, 1])),
rrcontrol$Ainit = control$Ainit = Amat # Good for valt()
rrcontrol$Cinit = control$Cinit = Cmat # Good for valt()
- Blist <- process.constraints(constraints, x, M)
+ Blist <- process.constraints(constraints, x, M, specialCM=specialCM)
nice31 = control$Quadratic && (!control$EqualTol || control$ITolerances) &&
all(trivial.constraints(Blist))
diff --git a/R/s.q b/R/s.q
index f8c9e69..89e424b 100644
--- a/R/s.q
+++ b/R/s.q
@@ -1,5 +1,5 @@
# These functions are
-# Copyright (C) 1998-2007 T.W. Yee, University of Auckland. All rights reserved.
+# Copyright (C) 1998-2008 T.W. Yee, University of Auckland. All rights reserved.
diff --git a/R/s.vam.q b/R/s.vam.q
index f9e1e06..5a7649f 100644
--- a/R/s.vam.q
+++ b/R/s.vam.q
@@ -1,5 +1,5 @@
# These functions are
-# Copyright (C) 1998-2007 T.W. Yee, University of Auckland. All rights reserved.
+# Copyright (C) 1998-2008 T.W. Yee, University of Auckland. All rights reserved.
diff --git a/R/smart.R b/R/smart.R
index 6992bbf..d7f9f40 100644
--- a/R/smart.R
+++ b/R/smart.R
@@ -1,5 +1,5 @@
# These functions are
-# Copyright (C) 1998-2007 T.W. Yee, University of Auckland. All rights reserved.
+# Copyright (C) 1998-2008 T.W. Yee, University of Auckland. All rights reserved.
diff --git a/R/step.vglm.q b/R/step.vglm.q
index 8c388e8..6285f0e 100644
--- a/R/step.vglm.q
+++ b/R/step.vglm.q
@@ -1,5 +1,5 @@
# These functions are
-# Copyright (C) 1998-2007 T.W. Yee, University of Auckland. All rights reserved.
+# Copyright (C) 1998-2008 T.W. Yee, University of Auckland. All rights reserved.
step.vglm <- function(fit, ...)
diff --git a/R/summary.others.q b/R/summary.others.q
index 20f66cf..2c16b1c 100644
--- a/R/summary.others.q
+++ b/R/summary.others.q
@@ -1,5 +1,5 @@
# These functions are
-# Copyright (C) 1998-2007 T.W. Yee, University of Auckland. All rights reserved.
+# Copyright (C) 1998-2008 T.W. Yee, University of Auckland. All rights reserved.
diff --git a/R/summary.vgam.q b/R/summary.vgam.q
index 4b33c5d..3d9cce9 100644
--- a/R/summary.vgam.q
+++ b/R/summary.vgam.q
@@ -1,5 +1,5 @@
# These functions are
-# Copyright (C) 1998-2007 T.W. Yee, University of Auckland. All rights reserved.
+# Copyright (C) 1998-2008 T.W. Yee, University of Auckland. All rights reserved.
diff --git a/R/summary.vglm.q b/R/summary.vglm.q
index bac5fa3..984d0f4 100644
--- a/R/summary.vglm.q
+++ b/R/summary.vglm.q
@@ -1,5 +1,5 @@
# These functions are
-# Copyright (C) 1998-2007 T.W. Yee, University of Auckland. All rights reserved.
+# Copyright (C) 1998-2008 T.W. Yee, University of Auckland. All rights reserved.
@@ -62,7 +62,8 @@ setMethod("logLik", "summary.vglm", function(object, ...)
logLik.vlm(object, ...))
-printsummary.vglm <- function(x, digits = NULL, quote = TRUE, prefix = "")
+printsummary.vglm <- function(x, digits = NULL, quote = TRUE, prefix = "",
+ presid = TRUE)
{
M <- x at misc$M
@@ -74,20 +75,20 @@ printsummary.vglm <- function(x, digits = NULL, quote = TRUE, prefix = "")
cat("\nCall:\n")
dput(x at call)
- presid <- x at pearson.resid
+ Presid <- x at pearson.resid
rdf <- x at df[2]
- if(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)
{
- rq <- apply(as.matrix(presid), 2, quantile) # 5 x M
+ rq <- apply(as.matrix(Presid), 2, quantile) # 5 x M
dimnames(rq) <- list(c("Min", "1Q", "Median", "3Q", "Max"),
x at misc$predictors.names)
print(t(rq), digits = digits)
} else
if(rdf > 0) {
- print(presid, digits = digits)
+ print(Presid, digits = digits)
}
}
diff --git a/R/summary.vlm.q b/R/summary.vlm.q
index a103153..8489da5 100644
--- a/R/summary.vlm.q
+++ b/R/summary.vlm.q
@@ -1,5 +1,5 @@
# These functions are
-# Copyright (C) 1998-2007 T.W. Yee, University of Auckland. All rights reserved.
+# Copyright (C) 1998-2008 T.W. Yee, University of Auckland. All rights reserved.
diff --git a/R/uqo.R b/R/uqo.R
index 465396e..bff1eeb 100644
--- a/R/uqo.R
+++ b/R/uqo.R
@@ -1,5 +1,5 @@
# These functions are
-# Copyright (C) 1998-2007 T.W. Yee, University of Auckland. All rights reserved.
+# Copyright (C) 1998-2008 T.W. Yee, University of Auckland. All rights reserved.
diff --git a/R/vgam.R b/R/vgam.R
index 7a1bb39..3ca3583 100644
--- a/R/vgam.R
+++ b/R/vgam.R
@@ -1,5 +1,5 @@
# These functions are
-# Copyright (C) 1998-2007 T.W. Yee, University of Auckland. All rights reserved.
+# Copyright (C) 1998-2008 T.W. Yee, University of Auckland. All rights reserved.
@@ -25,29 +25,39 @@ vgam <- function(formula,
ocall <- match.call()
- mf <- match.call(expand=FALSE)
-
if(smart)
setup.smart("write")
+ if(missing(data))
+ data <- environment(formula)
+ mtsave <- terms(formula, "s", data = data)
+ mf <- match.call(expand.dots = FALSE)
+ m <- match(c("formula", "data", "subset", "weights", "na.action",
+ "etastart", "mustart", "offset"), names(mf), 0)
+ mf <- mf[c(1, m)]
+ mf$drop.unused.levels <- TRUE
+ mf[[1]] <- as.name("model.frame")
+ mf <- eval(mf, parent.frame())
+ switch(method, model.frame = return(mf), vgam.fit = 1,
+ stop("invalid 'method': ", method))
+ mt <- attr(mf, "terms")
- mt <- terms(formula, "s", data = data)
+ xlev = .getXlevels(mt, mf)
+ y <- model.response(mf, "any") # model.extract(mf, "response")
+ x <- if (!is.empty.model(mt)) model.matrix(mt, mf, contrasts) else
+ matrix(, NROW(Y), 0)
+ attr(x, "assign") <- attrassigndefault(x, mt) # So as to make it like Splus
- if(missing(data))
- data <- environment(formula)
+ offset <- model.offset(mf)
+ if(is.null(offset))
+ offset <- 0 # yyy ???
- mf$family <- mf$method <- mf$model <- mf$x.arg <- mf$y.arg <-
- mf$control <- mf$etastart <- mf$mustart <- mf$coefstart <-
- mf$qr.arg <- mf$contrasts <- mf$constraints <-mf$smart <-
- mf$extra <- mf$... <- NULL
- mf[[1]] <- as.name("model.frame")
- mf2 <- mf
- mf <- eval(mf, parent.frame())
+ mf2 = mf
if(!missing(subset)) {
mf2$subset <- NULL
mf2 <- eval(mf2, parent.frame()) # mf2 is the full data frame.
@@ -64,24 +74,7 @@ vgam <- function(formula,
rm(mf2)
}
- if(method == "model.frame")
- return(mf)
-
- na.act <- attr(mf, "na.action")
- xvars <- as.character(attr(mt, "variables"))[-1]
- if ((yvar <- attr(mt, "response")) > 0)
- xvars <- xvars[-yvar]
- xlev <- if (length(xvars) > 0) {
- xlev <- lapply(mf[xvars], levels)
- xlev[!sapply(xlev, is.null)]
- }
- na.message <- attr(mf, "na.message")
-
- y <- model.response(mf, "numeric") # model.extract(m, "response")
- if(!is.empty.model(mt))
- x <- model.matrix(mt, mf, contrasts)
- attr(x, "assign") <- attrassigndefault(x, mt)
w <- model.weights(mf)
if(!length(w))
@@ -91,9 +84,6 @@ vgam <- function(formula,
- offset <- model.offset(mf)
- if(is.null(offset))
- offset <- 0 # yyy ???
if (is.character(family))
family <- get(family)
@@ -123,7 +113,7 @@ vgam <- function(formula,
# --------------------------------------------------------------
- aa <- attributes(mt)
+ aa <- attributes(mtsave)
smoothers <- aa$specials
@@ -146,7 +136,7 @@ vgam <- function(formula,
offset=offset, family=family, control=control,
criterion=control$criterion,
constraints=constraints, extra=extra, qr.arg=qr.arg,
- Terms=mt,
+ Terms=mtsave,
nonparametric=nonparametric, smooth.labels=smooth.labels,
function.name=function.name, ...)
@@ -178,7 +168,6 @@ vgam <- function(formula,
fit$misc$dataname <- dataname
- attr(fit, "na.message") <- na.message
if(smart)
fit$smart.prediction <- get.smart.prediction()
@@ -213,7 +202,8 @@ vgam <- function(formula,
slot(answer, "contrasts") = attr(x, "contrasts")
if(length(fit$fitted.values))
slot(answer, "fitted.values") = as.matrix(fit$fitted.values)
- slot(answer, "na.action") = if(length(na.act)) list(na.act) else list()
+ slot(answer, "na.action") = if(length(aaa <- attr(mf, "na.action")))
+ list(aaa) else list()
if(length(offset))
slot(answer, "offset") = as.matrix(offset)
if(length(fit$weights))
diff --git a/R/vgam.control.q b/R/vgam.control.q
index 4b61aeb..a0bb5c8 100644
--- a/R/vgam.control.q
+++ b/R/vgam.control.q
@@ -1,5 +1,5 @@
# These functions are
-# Copyright (C) 1998-2007 T.W. Yee, University of Auckland. All rights reserved.
+# Copyright (C) 1998-2008 T.W. Yee, University of Auckland. All rights reserved.
diff --git a/R/vgam.fit.q b/R/vgam.fit.q
index b35d662..1e202e8 100644
--- a/R/vgam.fit.q
+++ b/R/vgam.fit.q
@@ -1,5 +1,5 @@
# These functions are
-# Copyright (C) 1998-2007 T.W. Yee, University of Auckland. All rights reserved.
+# Copyright (C) 1998-2008 T.W. Yee, University of Auckland. All rights reserved.
@@ -12,6 +12,7 @@ vgam.fit <- function(x, y, w, mf,
nonparametric, smooth.labels,
function.name="vgam", ...)
{
+ specialCM = NULL
post = list()
check.Rank <- TRUE # Set this to false for family functions vppr() etc.
epsilon <- control$epsilon
@@ -126,7 +127,7 @@ vgam.fit <- function(x, y, w, mf,
if(length(family at constraints))
eval(family at constraints)
- Blist <- process.constraints(constraints, x, M)
+ Blist <- process.constraints(constraints, x, M, specialCM=specialCM)
ncolBlist <- unlist(lapply(Blist, ncol))
dimB <- sum(ncolBlist)
@@ -318,7 +319,8 @@ vgam.fit <- function(x, y, w, mf,
dimnames(fit$residuals) <- dimnames(fit$predictors) <-
list(yn, predictors.names)
- NewBlist <- process.constraints(constraints, x, M, by.col=FALSE)
+ NewBlist <- process.constraints(constraints, x, M, specialCM=specialCM,
+ by.col=FALSE)
misc <- list(
colnames.x = xn,
diff --git a/R/vgam.match.q b/R/vgam.match.q
index bad9f11..4af48c8 100644
--- a/R/vgam.match.q
+++ b/R/vgam.match.q
@@ -1,5 +1,5 @@
# These functions are
-# Copyright (C) 1998-2007 T.W. Yee, University of Auckland. All rights reserved.
+# Copyright (C) 1998-2008 T.W. Yee, University of Auckland. All rights reserved.
diff --git a/R/vglm.R b/R/vglm.R
index 50e126c..b0040fb 100644
--- a/R/vglm.R
+++ b/R/vglm.R
@@ -1,5 +1,5 @@
# These functions are
-# Copyright (C) 1998-2007 T.W. Yee, University of Auckland. All rights reserved.
+# Copyright (C) 1998-2008 T.W. Yee, University of Auckland. All rights reserved.
@@ -26,35 +26,26 @@ vglm <- function(formula,
if(smart)
setup.smart("write")
- mt <- terms(formula, data = data)
if(missing(data))
data <- environment(formula)
- mf <- match.call(expand=FALSE)
- mf$family <- mf$method <- mf$model <- mf$x.arg <- mf$y.arg <- mf$control <-
- mf$contrasts <- mf$constraints <- mf$extra <- mf$qr.arg <- NULL
- mf$coefstart <- mf$etastart <- mf$... <- NULL
- mf$smart <- NULL
- mf$drop.unused.levels <- TRUE
+ mf <- match.call(expand.dots = FALSE)
+ m <- match(c("formula", "data", "subset", "weights", "na.action",
+ "etastart", "mustart", "offset"), names(mf), 0)
+ mf <- mf[c(1, m)]
+ mf$drop.unused.levels <- TRUE
mf[[1]] <- as.name("model.frame")
-
- mf <- eval(mf, parent.frame())
-
- if(method == "model.frame")
- return(mf)
- na.act <- attr(mf, "na.action")
-
- xvars <- as.character(attr(mt, "variables"))[-1]
- if ((yvar <- attr(mt, "response")) > 0)
- xvars <- xvars[-yvar]
- xlev <- if (length(xvars) > 0) {
- xlev <- lapply(mf[xvars], levels)
- xlev[!sapply(xlev, is.null)]
- }
-
- y <- model.response(mf, "numeric") # model.extract(mf, "response")
- x <- model.matrix(mt, mf, contrasts)
+ mf <- eval(mf, parent.frame())
+ switch(method, model.frame = return(mf), vglm.fit = 1,
+ stop("invalid 'method': ", method))
+ mt <- attr(mf, "terms")
+
+ xlev = .getXlevels(mt, mf)
+ y <- model.response(mf, "any") # model.extract(mf, "response")
+ x <- if (!is.empty.model(mt)) model.matrix(mt, mf, contrasts) else
+ matrix(, NROW(Y), 0)
attr(x, "assign") <- attrassigndefault(x, mt) # So as to make it like Splus
+
offset <- model.offset(mf)
if(is.null(offset))
offset <- 0 # yyy ???
@@ -128,7 +119,8 @@ vglm <- function(formula,
slot(answer, "contrasts") = attr(x, "contrasts")
if(length(fit$fitted.values))
slot(answer, "fitted.values") = as.matrix(fit$fitted.values)
- slot(answer, "na.action") = if(length(na.act)) list(na.act) else list()
+ slot(answer, "na.action") = if(length(aaa <- attr(mf, "na.action")))
+ list(aaa) else list()
if(length(offset))
slot(answer, "offset") = as.matrix(offset)
diff --git a/R/vglm.control.q b/R/vglm.control.q
index 08a7b68..b7ed382 100644
--- a/R/vglm.control.q
+++ b/R/vglm.control.q
@@ -1,5 +1,5 @@
# These functions are
-# Copyright (C) 1998-2007 T.W. Yee, University of Auckland. All rights reserved.
+# Copyright (C) 1998-2008 T.W. Yee, University of Auckland. All rights reserved.
diff --git a/R/vglm.fit.q b/R/vglm.fit.q
index bf38307..0a84a2f 100644
--- a/R/vglm.fit.q
+++ b/R/vglm.fit.q
@@ -1,5 +1,5 @@
# These functions are
-# Copyright (C) 1998-2007 T.W. Yee, University of Auckland. All rights reserved.
+# Copyright (C) 1998-2008 T.W. Yee, University of Auckland. All rights reserved.
@@ -14,6 +14,7 @@ vglm.fit <- function(x, y, w=rep(1, length(x[, 1])),
extra=NULL,
Terms=Terms, function.name="vglm", ...)
{
+ specialCM = NULL
post = list()
check.rank <- TRUE # Set this to false for family functions vppr() etc.
nonparametric <- FALSE
@@ -213,7 +214,8 @@ vglm.fit <- function(x, y, w=rep(1, length(x[, 1])),
if(length(slot(family, "constraints")))
eval(slot(family, "constraints"))
- Blist <- process.constraints(constraints, x, M)
+
+ Blist <- process.constraints(constraints, x, M, specialCM=specialCM)
ncolBlist <- unlist(lapply(Blist, ncol))
diff --git a/R/vlm.R b/R/vlm.R
index 0358af1..6bd5e02 100644
--- a/R/vlm.R
+++ b/R/vlm.R
@@ -1,5 +1,5 @@
# These functions are
-# Copyright (C) 1998-2007 T.W. Yee, University of Auckland. All rights reserved.
+# Copyright (C) 1998-2008 T.W. Yee, University of Auckland. All rights reserved.
diff --git a/R/vlm.wfit.q b/R/vlm.wfit.q
index d3ff1bd..5002927 100644
--- a/R/vlm.wfit.q
+++ b/R/vlm.wfit.q
@@ -1,5 +1,5 @@
# These functions are
-# Copyright (C) 1998-2007 T.W. Yee, University of Auckland. All rights reserved.
+# Copyright (C) 1998-2008 T.W. Yee, University of Auckland. All rights reserved.
diff --git a/R/vsmooth.spline.q b/R/vsmooth.spline.q
index 1e9d270..a93c442 100644
--- a/R/vsmooth.spline.q
+++ b/R/vsmooth.spline.q
@@ -1,5 +1,5 @@
# These functions are
-# Copyright (C) 1998-2007 T.W. Yee, University of Auckland. All rights reserved.
+# Copyright (C) 1998-2008 T.W. Yee, University of Auckland. All rights reserved.
diff --git a/R/zzz.R b/R/zzz.R
index d6cf4a6..3e38373 100644
--- a/R/zzz.R
+++ b/R/zzz.R
@@ -1,5 +1,5 @@
# These functions are
-# Copyright (C) 1998-2007 T.W. Yee, University of Auckland. All rights reserved.
+# Copyright (C) 1998-2008 T.W. Yee, University of Auckland. All rights reserved.
diff --git a/data/aml.R b/data/leukemia.R
similarity index 74%
rename from data/aml.R
rename to data/leukemia.R
index 65e3390..091b145 100644
--- a/data/aml.R
+++ b/data/leukemia.R
@@ -1,9 +1,9 @@
-`aml` <-
+`leukemia` <-
structure(list(time = c(9, 13, 13, 18, 23, 28, 31, 34, 45, 48,
161, 5, 5, 8, 8, 12, 16, 23, 27, 30, 33, 43, 45), status = c(1,
1, 0, 1, 1, 0, 1, 1, 0, 1, 0, 1, 1, 1, 1, 1, 0, 1, 1, 1, 1, 1,
-1), x = structure(c(1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L,
-2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L), .Label = c("Maintained",
+1), x = structure(c(1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1,
+2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2), .Label = c("Maintained",
"Nonmaintained"), class = "factor")), .Names = c("time", "status",
"x"), row.names = c("1", "2", "3", "4", "5", "6", "7", "8", "9",
"10", "11", "12", "13", "14", "15", "16", "17", "18", "19", "20",
diff --git a/data/toxop.R b/data/toxop.R
index f0468a5..b56fc32 100644
--- a/data/toxop.R
+++ b/data/toxop.R
@@ -8,4 +8,4 @@ structure(list(rainfall = c(1735, 1936, 2000, 1973, 1750, 1800,
positive = c(2, 3, 1, 3, 2, 3, 2, 7, 3, 8, 7, 0, 15, 4, 0,
6, 0, 33, 4, 5, 2, 0, 8, 41, 24, 7, 46, 9, 23, 53, 8, 3,
1, 23)), .Names = c("rainfall", "ssize", "cityNo", "positive"
-), row.names = c(NA, -34L), class = "data.frame")
+), row.names = c(NA, -34), class = "data.frame")
diff --git a/man/CommonVGAMffArguments.Rd b/man/CommonVGAMffArguments.Rd
new file mode 100644
index 0000000..9fd0cc1
--- /dev/null
+++ b/man/CommonVGAMffArguments.Rd
@@ -0,0 +1,193 @@
+\name{CommonVGAMffArguments}
+\alias{CommonVGAMffArguments}
+\alias{TypicalVGAMfamilyFunction}
+\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.,
+ \code{lsigma},
+ \code{isigma}, \code{nsimEI}, \code{parallel} and \code{zero}.
+
+}
+\usage{
+TypicalVGAMfamilyFunction(lsigma="loge", esigma=list(),
+ isigma=NULL, parallel = TRUE,
+ 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.
+ Link function applied to a parameter and not necessarily a mean.
+ See \code{\link{Links}} for a selection of choices.
+ If there is only one parameter then this argument is often called
+ \code{link}.
+
+ }
+ \item{esigma}{
+ List.
+ Extra argument allowing for additional information, specific to the
+ link function.
+ See \code{\link{Links}} for more information.
+ If there is only one parameter then this argument is often called
+ \code{earg}.
+
+ }
+ \item{isigma}{
+ Optional initial values can often be inputted using an argument
+ beginning with \code{"i"}.
+ For example, \code{"isigma"} and \code{"ilocation"}, or just
+ \code{"init"} if there is one parameter.
+ A value of \code{NULL} means a value is computed internally, i.e.,
+ a \emph{self-starting} \pkg{VGAM} family function.
+ If a failure to converge occurs make use of these types of arguments.
+
+ }
+ \item{parallel}{
+ A logical, or formula specifying which terms have equal/unequal
+ coefficients.
+ This argument is common in \pkg{VGAM} family functions for categorical
+ responses, e.g., \code{\link{cumulative}}, \code{\link{acat}},
+ \code{\link{cratio}}, \code{\link{sratio}}.
+ For the proportional odds model (\code{\link{cumulative}}) having
+ parallel constraints applied to each explanatory variable (except for
+ the intercepts) means the fitted probabilities do not become negative
+ or greater than 1. However this parallelism or proportional-odds
+ assumption ought to be checked.
+
+ }
+ \item{nsimEIM}{
+ Some \pkg{VGAM} family functions use simulation to obtain an approximate
+ expected information matrix (EIM).
+ For those that do, the \code{nsimEIM} argument specifies the number
+ of random variates used per observation; the mean of \code{nsimEIM}
+ random variates is taken.
+ Thus \code{nsimEIM} controls the accuracy and a larger value may be
+ necessary if the EIMs are not positive-definite.
+ For intercept-only models (\code{y ~ 1)} the value of \code{nsimEIM}
+ can be smaller (since the common value used is also then taken as the
+ mean over the observations), especially if the number of observations
+ is large.
+
+ Some \pkg{VGAM} family functions provide two algorithms for estimating
+ the EIM.
+ If applicable, set \code{nsimEIM=NULL} to choose the other algorithm.
+
+ }
+ \item{method.init}{
+ An integer with value \code{1} or \code{2} or or \code{3} ... which
+ specifies the initialization method for some parameters or a specific
+ parameter. If failure to converge occurs try the next higher value.
+ For example, \code{method.init=1} might be the method of moments,
+ and \code{method.init=2} might be another method.
+ If no value of \code{method.init} works then it will be necessary
+ to use arguments such as \code{isigma}.
+
+ }
+ \item{zero}{
+ An integer specifying which linear/additive predictor is modelled as
+ intercepts-only. That is,
+ the regression coefficients are set to zero for all covariates
+ except for the intercept.
+ If \code{zero} is specified then it is a vector with values from the
+ set \eqn{\{1,2,\ldots,M\}}.
+ The value \code{zero=NULL} means model all linear/additive predictors
+ as functions of the explanatory variables.
+
+ Some \pkg{VGAM} family functions allow the \code{zero} argument to
+ accept negative values; if so then its absolute value is recycled
+ over each response. For example, \code{zero=-2} would mean,
+ for each response, the second linear/additive predictor is modelled
+ as intercepts-only. A specific example is the \eqn{k} parameter in
+ \code{\link{negbinomial}}; this \pkg{VGAM} family function can handle
+ a matrix of responses.
+
+ }
+}
+\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}}.
+
+}
+\section{Warning }{
+ The \code{zero} argument is supplied for convenience but conflicts
+ can arise with other arguments, e.g., the \code{constraints}
+ argument of \code{\link{vglm}} and \code{\link{vgam}}.
+ See Example 5 below for an example.
+ If not sure, use, e.g., \code{constraints(fit)} and
+ \code{coef(fit, matrix=TRUE)} to check the result of a fit \code{fit}.
+
+ \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
+ \code{summary(fit)},
+ \code{vcov(fit)},
+ etc. may be misleading.
+
+}
+
+\details{
+ Full details will be given in documentation yet to be written,
+ at a later date!
+
+}
+%\references{
+%}
+
+\seealso{
+ \code{\link{Links}},
+ \code{\link{vglmff-class}}.
+
+}
+\author{T. W. Yee}
+%\note{
+%
+%}
+\examples{
+# Example 1
+cumulative()
+cumulative(link="probit", reverse=TRUE, parallel=TRUE)
+
+# Example 2
+x = runif(n <- 1000)
+y = rweibull(n, shape=2+exp(1+x), scale = exp(-0.5))
+fit = vglm(y ~ x, weibull(lshape="logoff", eshape=list(offset=-2), zero=2))
+coef(fit, mat=TRUE)
+Coef(fit)
+
+# Example 3
+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(zero=-2)) # multivariate response
+coef(fit, matrix=TRUE)
+
+# Example 4
+\dontrun{
+# fit1 and fit2 are equivalent
+fit1 = vglm(ymatrix ~ x2 + x3 + x4 + x5,
+ cumulative(parallel=FALSE ~ 1 + x3 + x5), mydataframe)
+fit2 = vglm(ymatrix ~ x2 + x3 + x4 + x5,
+ cumulative(parallel=TRUE ~ x2 + x4), mydataframe)
+}
+
+# Example 5
+x = rnorm(n <- 200)
+y1 = rnorm(n, mean=1-3*x, sd=exp(1+0.2*x))
+y2 = rnorm(n, mean=1-3*x, sd=exp(1))
+args(normal1)
+fit1 = vglm(y1 ~ x, normal1) # This is ok
+fit2 = vglm(y2 ~ x, normal1(zero=2)) # This is ok
+
+# This creates potential conflict
+clist = list("(Intercept)"=diag(2), "x"=diag(2))
+fit3 = vglm(y2 ~ x, normal1(zero=2), constraints=clist) # Conflict!
+coef(fit3, matrix=TRUE) # Shows that clist[["x"]] was overwritten,
+constraints(fit3) # i.e., 'zero' seems to override the 'constraints' arg
+}
+\keyword{models}
+
diff --git a/man/Links.Rd b/man/Links.Rd
index 36c7587..00fa390 100644
--- a/man/Links.Rd
+++ b/man/Links.Rd
@@ -139,6 +139,7 @@ TypicalVGAMlinkFunction(theta, earg=list(), inverse=FALSE,
}
\seealso{
+ \code{\link{TypicalVGAMfamilyFunction}},
\code{\link{vglm}},
\code{\link{vgam}},
\code{\link{rrvglm}}.
@@ -186,8 +187,10 @@ fit3 = vgam(agaaus ~ altitude, binomialff(link="clog"), hunua) # not ok
# No matter what the link, the estimated var-cov matrix is the same
y = rbeta(n=1000, shape1=exp(0), shape2=exp(1))
-fit1 = vglm(y ~ 1, betaff(link="identity"), trace = TRUE, crit="c")
-fit2 = vglm(y ~ 1, betaff(link=logoff, earg=list(offset=1.1)),
+fit1 = vglm(y ~ 1, beta.ab(lshape1="identity", lshape2="identity"),
+ trace = TRUE, crit="c")
+fit2 = vglm(y ~ 1, beta.ab(lshape1=logoff, eshape1=list(offset=1.1),
+ lshape2=logoff, eshape2=list(offset=1.1)),
trace = TRUE, crit="c")
vcov(fit1, untran=TRUE)
vcov(fit1, untran=TRUE)-vcov(fit2, untran=TRUE) # Should be all 0s
diff --git a/man/Surv.Rd b/man/Surv.Rd
index 7e8cc20..9731a0e 100644
--- a/man/Surv.Rd
+++ b/man/Surv.Rd
@@ -16,6 +16,7 @@ Create a Survival Object
\description{
Create a survival object, usually used as a response variable in a
model formula.
+
}
\usage{
Surv(time, time2, event, type =, origin = 0)
@@ -58,12 +59,14 @@ is.SurvS4(x)
from one strata to another.}
}
\value{
- An object of class \code{Surv}. There are methods for \code{print},
- \code{is.na}, and subscripting survival objects. \code{Surv} objects
+ An object of class \code{SurvS4} (formerly \code{Surv}).
+ There are methods for \code{print},
+ \code{is.na}, and subscripting survival objects. \code{SurvS4} objects
are implemented as a matrix of 2 or 3 columns.
In the case of \code{is.SurvS4}, a logical value \code{TRUE} if \code{x}
- inherits from class \code{"SurvS4"}, otherwise an \code{FALSE}.
+ inherits from class \code{"SurvS4"}, otherwise a \code{FALSE}.
+
}
\details{
Typical usages are
@@ -107,30 +110,41 @@ guess wrong. Use 0/1 coding in this case.
\author{
The code and documentation comes from \pkg{survival}.
- Slight modifications have been made for conversion to S4
- by Thomas W. Yee.
-}
-\note{
- The purpose of having \code{Surv} 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"}.
+ Slight modifications have been made for conversion to S4 by T. W. Yee.
+ Also, for \code{"interval"} data, \code{as.character.SurvS4()} has
+ been modified to print intervals of the form
+ \code{(start, end]} and not
+ \code{[start, end]} as previously.
+ (This makes a difference for discrete data, such as for
+ \code{\link{cenpoisson}}).
+ All \pkg{VGAM} family functions beginning with \code{"cen"} require
+ the packaging function \code{Surv} to format the input.
}
+\note{
+ The purpose of having \code{Surv} 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
+ \code{\link{SurvS4-class}}.
+ The format \code{J+} is interpreted in \pkg{VGAM} as \eqn{\ge J}.
+ If \code{type="interval"} then these should not be used in \pkg{VGAM}:
+ \code{(L,U-]} or \code{(L,U+]}.
+% zz is this for type="count" only?
-
+}
\seealso{
\code{\link{SurvS4-class}},
- \code{\link[survival]{coxph}},
- \code{\link[survival]{survfit}},
+ \code{\link{cenpoisson}},
+% \code{\link[survival]{coxph}},
+% \code{\link[survival]{survfit}},
\code{\link[survival]{survreg}},
- \code{\link{aml}}.
+ \code{\link{leukemia}}.
}
\examples{
-with(aml, Surv(time, status))
+with(leukemia, Surv(time, status))
}
\keyword{survival}
% Converted by Sd2Rd version 0.3-2.
diff --git a/man/SurvS4-class.Rd b/man/SurvS4-class.Rd
index 6120f20..ed59328 100644
--- a/man/SurvS4-class.Rd
+++ b/man/SurvS4-class.Rd
@@ -27,12 +27,13 @@ Class \code{"\linkS4class{vector}"}, by class "matrix", distance 4, with explici
See \pkg{survival}.
}
\author{
- Thomas W. Yee.
+ T. W. Yee.
}
\note{
- The purpose of having \code{\link{Surv}} 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 purpose of having \code{\link{Surv}} 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}}.
+
}
\section{Warning }{
diff --git a/man/VGAM-package.Rd b/man/VGAM-package.Rd
index e8c7ff3..5ad2669 100644
--- a/man/VGAM-package.Rd
+++ b/man/VGAM-package.Rd
@@ -104,10 +104,13 @@ contains further information and examples.
\keyword{ package }
\keyword{models}
\keyword{regression}
-%\seealso{
+\seealso{
+ \code{\link{TypicalVGAMfamilyFunction}},
+ \code{\link{CommonVGAMffArguments}}.
+
%~~ Optional links to other man pages, e.g. ~~
%~~ \code{\link[<pkg>:<pkg>-package]{<pkg>}} ~~
-%}
+}
\examples{
# Example 1
# Fit the proportional odds model, p.179, in McCullagh and Nelder (1989)
diff --git a/man/alaplace3.Rd b/man/alaplace3.Rd
new file mode 100644
index 0000000..4e47eda
--- /dev/null
+++ b/man/alaplace3.Rd
@@ -0,0 +1,293 @@
+\name{alaplace}
+\alias{alaplace1}
+\alias{alaplace2}
+\alias{alaplace3}
+%- Also NEED an '\alias' for EACH other topic documented here.
+\title{ Asymmetric Laplace Distribution Family Functions }
+\description{
+ Maximum likelihood estimation of
+ the 1, 2 and 3-parameter asymmetric Laplace distributions (ALDs).
+ The 1-parameter ALD may be used for quantile regression.
+
+}
+\usage{
+alaplace1(tau = NULL, llocation = "identity", elocation = list(),
+ ilocation = NULL, kappa = sqrt(tau/(1 - tau)), Scale.arg = 1,
+ shrinkage.init = 0.95, parallelLocation = FALSE, digt = 4,
+ dfmu.init = 3, method.init = 1, zero = NULL)
+
+alaplace2(tau = NULL, llocation = "identity", lscale = "loge",
+ elocation = list(), escale = list(),
+ ilocation = NULL, iscale = NULL, kappa = sqrt(tau/(1 - tau)),
+ shrinkage.init = 0.95,
+ parallelLocation = FALSE, digt = 4, sameScale = TRUE,
+ dfmu.init = 3, method.init = 1, zero = "(1 + M/2):M")
+
+alaplace3(llocation = "identity", lscale = "loge", lkappa = "loge",
+ elocation = list(), escale = list(), ekappa = list(),
+ ilocation = NULL, iscale = NULL, ikappa = 1,
+ method.init = 1, zero = 2:3)
+}
+%- maybe also 'usage' for other objects documented here.
+\arguments{
+ \item{tau, kappa}{ Numeric vectors with
+ \eqn{0 < \tau < 1}{0 < tau < 1} and \eqn{\kappa >0}{kappa >0}.
+ Most users will only specify \code{tau} since the estimated
+ location parameter corresponds to the \eqn{\tau}{tau}th
+ regression quantile, which is easier to understand.
+ See below for details.
+
+ }
+ \item{llocation, lscale, lkappa}{ Character.
+ Parameter link functions for
+ location parameter \eqn{\xi}{xi},
+ scale parameter \eqn{b},
+ asymmetry parameter \eqn{\kappa}{kappa}.
+ See \code{\link{Links}} for more choices.
+ For example, the argument \code{llocation} can help handle
+ count data by restricting the quantiles to be positive
+ (use \code{llocation="loge"}).
+
+ }
+ \item{elocation, escale, ekappa}{
+ List. Extra argument for each of the links.
+ See \code{earg} in \code{\link{Links}} for general information.
+
+ }
+ \item{ilocation, iscale, ikappa}{
+ Optional initial values.
+ If given, it must be numeric and values are recycled to the
+ appropriate length.
+ The default is to choose the value internally.
+ }
+ \item{parallelLocation}{ Logical.
+ Should the quantiles be parallel on the transformed scale (argument
+ \code{llocation})?
+ Assigning this argument to \code{TRUE} circumvents the
+ seriously embarrassing quantile crossing problem.
+
+ }
+ \item{sameScale}{ Logical.
+ Should the scale parameters be equal? It is advised to keep
+ \code{sameScale=TRUE} unchanged because it does not make sense to
+ have different values for each \code{tau} value.
+
+
+ }
+ \item{method.init}{
+ Initialization method.
+ Either the value 1, 2, 3 or 4.
+
+ }
+ \item{dfmu.init}{
+ Degrees of freedom for the cubic smoothing spline fit applied to
+ get an initial estimate of the location parameter.
+ See \code{\link{vsmooth.spline}}.
+ Used only when \code{method.init=3}.
+
+ }
+ \item{shrinkage.init}{
+ How much shrinkage is used when initializing \eqn{\xi}{xi}.
+ The value must be between 0 and 1 inclusive, and
+ a value of 0 means the individual response values are used,
+ and a value of 1 means the median or mean is used.
+ This argument is used only when \code{method.init=4}.
+
+ }
+ \item{Scale.arg}{
+ The value of the scale parameter \eqn{b}.
+ This argument may be used to compute quantiles at different
+ \eqn{\tau}{tau} values from an existing fitted \code{alaplace2()} model
+ (practical only if it has a single value).
+ If the model has \code{parallelLocation = TRUE} then only the intercept
+ need be estimated; use an offset.
+ See below for an example.
+
+% This is because the expected information matrix is diagonal,
+% i.e., the location and scale parameters are asymptotically independent.
+
+ }
+ \item{digt }{
+ Passed into \code{\link[base]{Round}} as the \code{digits} argument
+ for the \code{tau} values;
+ used cosmetically for labelling.
+
+ }
+ \item{zero}{
+ See \code{\link{CommonVGAMffArguments}} for more information.
+ Where possible,
+ the default is to model all the \eqn{b} and \eqn{\kappa}{kappa}
+ as an intercept-only term.
+
+ }
+}
+\details{
+ These \pkg{VGAM} family functions implement one variant of asymmetric
+ Laplace distributions (ALDs) suitable for quantile regression.
+ Kotz et al. (2001) call it \emph{the} ALD.
+ Its density function is
+ \deqn{f(y;\xi,b,\kappa) = \frac{\sqrt{2}}{b} \,
+ \frac{\kappa}{1 + \kappa^2} \,
+ \exp \left( - \frac{\sqrt{2}}{b \, \kappa} |y - \xi |
+ \right) }{%
+ f(y) = (sqrt(2)/b) * (kappa/(1+ \kappa^2)) * exp( -
+ (sqrt(2) / (b * kappa)) * |y-xi| ) }
+ for \eqn{y \leq \xi}{y <= xi}, and
+ \deqn{f(y;\xi,b,\kappa) = \frac{\sqrt{2}}{b} \,
+ \frac{\kappa}{1 + \kappa^2} \,
+ \exp \left( - \frac{\sqrt{2} \, \kappa}{b} |y - \xi |
+ \right) }{%
+ f(y) = (sqrt(2)/b) * (kappa/(1+ \kappa^2)) * exp( -
+ (sqrt(2) * kappa / b) * |y-xi| ) }
+ for \eqn{y > \xi}{y > xi}.
+ Here, the ranges are
+ for all real \eqn{y} and \eqn{\xi}{xi}, positive \eqn{b} and
+ positive \eqn{\kappa}{kappa}.
+ The special case \eqn{\kappa=1}{kappa=1} corresponds to the
+ (symmetric) Laplace distribution of Kotz et al. (2001).
+ The mean is \eqn{\xi + b (1/\kappa - \kappa) / \sqrt{2}}{xi +
+ b * (1/kappa - kappa) / sqrt(2)}
+ and the variance is
+ \eqn{b^2 (1 + \kappa^4) / (2 \kappa^2)}{b^2 * (1 +
+ kappa^4) / (2 * kappa^2)}.
+ The enumeration of the linear/additive predictors used here is to
+ first have all the location parameters, followed by all the
+ scale parameters. Finally, for \code{alaplace3()}, the last one
+ is the asymmetry parameter.
+
+ It is known that the maximum likelihood estimate of the
+ location parameter \eqn{\xi}{xi} corresponds to the regression
+ quantile estimate
+ of the classical quantile regression approach of Koenker and Bassett
+ (1978). An important property of the ALD is that
+ \eqn{P(Y \leq \xi) = \tau}{P(Y <= xi) = tau} where
+ \eqn{\tau = \kappa^2 / (1 + \kappa^2)}{tau = kappa^2 / (1 + kappa^2)}
+ so that
+ \eqn{\kappa = \sqrt{\tau / (1-\tau)}}{kappa = sqrt(tau / (1-tau))}.
+ Thus \code{alaplace1()} may be used as an alternative to \code{rq}
+ in the \pkg{quantreg} package.
+
+ In general the response must be a vector or a 1-column matrix.
+ For \code{alaplace1()} and \code{alaplace2()}
+ the number of linear/additive predictors is dictated by the
+ length of \code{tau} or \code{kappa}.
+
+}
+\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}}.
+
+ In the \code{extra} slot of the fitted object are some list
+ components which are useful, e.g., the sample proportion of
+ values which are less than the fitted quantile curves.
+
+}
+\references{
+ Koenker, R. and Bassett, G. (1978)
+ Regression quantiles.
+ \emph{Econometrica},
+ \bold{46}, 33--50.
+
+Kotz, S., Kozubowski, T. J. and Podgorski, K. (2001)
+\emph{The Laplace distribution and generalizations:
+a revisit with applications to communications,
+economics, engineering, and finance},
+Boston: Birkhauser.
+
+ Yee, T. W. (2008)
+ Quantile regression by scoring
+ an asymmetric Laplace distribution.
+ In preparation.
+
+}
+\author{ Thomas W. Yee }
+\section{Warning}{
+ The MLE regularity conditions do not hold for this distribution
+ so that misleading inferences may result,
+ e.g., in the \code{summary} and \code{vcov} of the object.
+
+ Care is needed with \code{tau} values which are too small, e.g.,
+ for count data with \code{llocation="loge"} and if the sample
+ proportion of zeros is greater than \code{tau}.
+
+}
+\note{
+ These \pkg{VGAM} family functions use Fisher scoring.
+ Convergence may be slow and
+ half-stepping is usual (although one can use \code{trace=TRUE} to see
+ which is the best model and then use \code{maxit} to fit that model).
+
+ For large data sets it is a very good idea to keep the length of
+ \code{tau}/\code{kappa} low to avoid large memory requirements.
+ Then
+ for \code{parallelLoc=FALSE} one can repeatedly fit a model with
+ \code{alaplace1()} with one \eqn{\tau}{tau} at a time;
+ and
+ for \code{parallelLoc=TRUE} one can refit a model with
+ \code{alaplace1()} with one \eqn{\tau}{tau} at a time but
+ using offsets and an intercept-only model.
+
+ The functions \code{alaplace2()} and \code{\link{laplace}}
+ differ slightly in terms of the parameterizations.
+
+}
+
+\seealso{
+ \code{\link{ralaplace}},
+ \code{\link{laplace}},
+ \code{\link{lms.bcn}},
+ \code{\link{alsqreg}}.
+
+}
+
+\examples{
+# Example 1: quantile regression with smoothing splines
+alldat = 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)))
+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)
+fitp = vgam(y ~ s(x, df=mydof), alaplace1(tau=mytau, llocation="loge",
+ parallelLoc=TRUE), data=alldat, trace=TRUE)
+
+\dontrun{
+par(xpd=TRUE, las=1)
+mylwd = 1.5
+with(alldat, 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))
+finexgrid = seq(0, 1, len=1001)
+for(ii in 1:length(mytau))
+ lines(finexgrid, qpois(p=mytau[ii], lambda=mymu(finexgrid)),
+ col="blue", lwd=mylwd)
+}
+fit at extra # Contains useful information
+
+
+# Example 2: regression quantile at a new tau value from an existing fit
+# Nb. regression splines are used here since it is easier.
+fitp2 = vglm(y ~ bs(x, df=mydof),
+ family = alaplace1(tau=mytau, llocation="loge",
+ parallelLoc=TRUE),
+ data=alldat, 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)
+\dontrun{
+with(alldat, 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))
+}
+}
+\keyword{models}
+\keyword{regression}
+
diff --git a/man/alaplaceUC.Rd b/man/alaplaceUC.Rd
new file mode 100644
index 0000000..77bfcb2
--- /dev/null
+++ b/man/alaplaceUC.Rd
@@ -0,0 +1,96 @@
+\name{alaplaceUC}
+\alias{dalaplace}
+\alias{palaplace}
+\alias{qalaplace}
+\alias{ralaplace}
+%- Also NEED an '\alias' for EACH other topic documented here.
+\title{ The Laplace Distribution }
+\description{
+ Density, distribution function, quantile function and random generation
+ for the 3-parameter asymmetric Laplace distribution with location
+ parameter \code{location}, scale parameter \code{scale},
+ and asymmetry parameter \code{kappa}.
+
+}
+\usage{
+dalaplace(x, location=0, scale=1, tau=0.5, kappa=sqrt(tau/(1-tau)))
+palaplace(q, location=0, scale=1, tau=0.5, kappa=sqrt(tau/(1-tau)))
+qalaplace(p, location=0, scale=1, tau=0.5, kappa=sqrt(tau/(1-tau)))
+ralaplace(n, location=0, scale=1, tau=0.5, kappa=sqrt(tau/(1-tau)))
+}
+%- maybe also 'usage' for other objects documented here.
+\arguments{
+ \item{x, q}{vector of quantiles.}
+ \item{p}{vector of probabilities.}
+ \item{n}{number of observations. Positive integer of length 1.}
+ \item{location}{
+ the location parameter \eqn{\xi}{xi}.
+ }
+ \item{scale}{
+ the scale parameter \eqn{b}.
+ Must consist of positive values.
+ }
+ \item{tau}{
+ the quantile parameter \eqn{\tau}{tau}.
+ Must consist of values in \eqn{(0,1)}.
+ This argument is used to specify \code{kappa} and is ignored
+ if \code{kappa} is assigned.
+
+ }
+ \item{kappa}{
+ the asymmetry parameter \eqn{\kappa}{kappa}.
+ Must consist of positive values.
+ }
+}
+\details{
+ There are several variants of asymmetric Laplace distributions (ALDs) and
+ this one is known as \emph{the} ALD by Kotz et al. (2001).
+ See \code{\link{alaplace3}}, the \pkg{VGAM} family function
+ for estimating the three parameters by maximum likelihood estimation,
+ for formulae and details.
+ Apart from \code{n}, all the above arguments may be vectors and
+ are recyled to the appropriate length if necessary.
+
+}
+\value{
+ \code{dalaplace} gives the density,
+ \code{palaplace} gives the distribution function,
+ \code{qalaplace} gives the quantile function, and
+ \code{ralaplace} generates random deviates.
+}
+\references{
+Kotz, S., Kozubowski, T. J. and Podgorski, K. (2001)
+\emph{The Laplace distribution and generalizations:
+a revisit with applications to communications,
+economics, engineering, and finance},
+Boston: Birkhauser.
+
+}
+\author{ T. W. Yee }
+%\note{
+% The \pkg{VGAM} family function \code{\link{alaplace3}}
+% estimates the three parameters by maximum likelihood estimation.
+%}
+
+\seealso{
+ \code{\link{alaplace3}}.
+}
+\examples{
+x = seq(-5, 5, by=0.01)
+loc = 0; b = 1.5; kappa = 2
+\dontrun{
+plot(x, dalaplace(x, loc, b, kappa=kappa), type="l", col="blue",
+ main="Blue is density, red is cumulative distribution function",
+ ylim=c(0,1), sub="Purple are 5,10,...,95 percentiles", las=1, ylab="")
+abline(h=0, col="blue", lty=2)
+lines(qalaplace(seq(0.05,0.95,by=0.05), loc, b, kappa=kappa),
+ dalaplace(qalaplace(seq(0.05,0.95,by=0.05), loc, b, kappa=kappa),
+ loc, b, kappa=kappa), col="purple", lty=3, type="h")
+lines(x, palaplace(x, loc, b, kappa=kappa), type="l", col="red")
+abline(h=0, lty=2)
+}
+palaplace(qalaplace(seq(0.05,0.95,by=0.05), loc, b, kappa=kappa),
+ loc, b, kappa=kappa)
+}
+\keyword{distribution}
+
diff --git a/man/alsqreg.Rd b/man/alsqreg.Rd
index 1a68b48..da92da6 100644
--- a/man/alsqreg.Rd
+++ b/man/alsqreg.Rd
@@ -7,23 +7,44 @@
}
\usage{
-alsqreg(w=1, method.init=1)
+alsqreg(w.als=1, parallel=FALSE, lexpectile = "identity",
+ eexpectile = list(), iexpectile = NULL,
+ method.init=1, digw=4)
}
%- maybe also 'usage' for other objects documented here.
\arguments{
- \item{w}{
- Positive constant controlling the percentile.
+ \item{w.als}{
+ 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'').
The default value of unity results in the ordinary least squares
(OLS) solution.
}
+ \item{parallel}{
+ If \code{w.als} 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
+ not cross (although they may not cross anyway).
+ See \code{\link{CommonVGAMffArguments}} for more information.
+
+ }
+ \item{lexpectile, eexpectile, iexpectile}{
+ See \code{\link{CommonVGAMffArguments}} for more information.
+
+ }
\item{method.init}{
Integer, either 1 or 2 or 3. Initialization method.
Choose another value if convergence fails.
}
+ \item{digw }{
+ Passed into \code{\link[base]{Round}} as the \code{digits} argument
+ for the \code{w.als} values;
+ used cosmetically for labelling.
+
+ }
}
\details{
This method was proposed by Efron (1991) and full details can
@@ -42,8 +63,9 @@ alsqreg(w=1, method.init=1)
}
\value{
An object of class \code{"vglmff"} (see \code{\link{vglmff-class}}).
- The object is used by modelling functions such as \code{\link{vglm}},
+ The object is used by modelling functions such as \code{\link{vglm}}
and \code{\link{vgam}}.
+
}
\references{
Efron, B. (1991)
@@ -55,27 +77,41 @@ alsqreg(w=1, method.init=1)
\author{ Thomas W. Yee }
\note{
- On fitting, the \code{extra} slot has list components \code{"w"} and
+ On fitting, the \code{extra} slot has list components \code{"w.als"} 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} value giving a specified
+ One difficulty is finding the \code{w.als} 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{alsqreg} 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.
+
}
-\section{Warning }{
- The \code{loglikelihood} slot currently does not return the
- log-likelihood but negative the total asymmetric
- squared error loss (2.5).
+%\section{Warning }{
+% The \code{loglikelihood} slot currently does not return the
+% log-likelihood but negative the total asymmetric squared error
+% loss (2.5).
+% If \code{w} has more than one value then the value returned by
+% \code{loglikelihood} is the sum taken over all the \code{w} values.
+%}
-}
\seealso{
+ \code{\link{amlpoisson}},
+ \code{\link{amlbinomial}},
+ \code{\link{amlexponential}},
\code{\link{bminz}},
+ \code{\link{alaplace2}},
\code{\link{lms.bcn}} and similar variants are alternative
methods for quantile regression.
@@ -86,8 +122,7 @@ alsqreg(w=1, method.init=1)
data(bminz)
o = with(bminz, order(age))
bminz = bminz[o,] # Sort by age
-fit = vglm(BMI ~ bs(age), fam=alsqreg(w=0.07), data=bminz)
-fit # Note "loglikelihood" is -total asymmetric squared error loss (2.5)
+(fit = vglm(BMI ~ bs(age), fam=alsqreg(w.als=0.1), data=bminz))
fit at extra # Gives the w value and the percentile
coef(fit)
coef(fit, matrix=TRUE)
@@ -96,7 +131,7 @@ coef(fit, matrix=TRUE)
# Quantile plot
with(bminz, plot(age, BMI, col="blue", main=
paste(round(fit at extra$percentile, dig=1), "percentile curve")))
-with(bminz, lines(age, c(fitted(fit)), col="red"))
+with(bminz, lines(age, c(fitted(fit)), col="black"))
}
@@ -104,8 +139,8 @@ with(bminz, lines(age, c(fitted(fit)), col="red"))
# Example 2
# Find the w values that give the 25, 50 and 75 percentiles
findw = function(w, percentile=50) {
- fit = vglm(BMI ~ bs(age), fam=alsqreg(w=w), data=bminz)
- fit at extra$percentile - percentile
+ fit2 = vglm(BMI ~ bs(age), fam=alsqreg(w=w), data=bminz)
+ fit2 at extra$percentile - percentile
}
\dontrun{
# Quantile plot
@@ -113,12 +148,36 @@ with(bminz, plot(age, BMI, col="blue", las=1, main=
"25, 50 and 75 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)
- fit = vglm(BMI ~ bs(age), fam=alsqreg(w=bestw$root), data=bminz)
+ fit2 = vglm(BMI ~ bs(age), fam=alsqreg(w=bestw$root), data=bminz)
\dontrun{
- with(bminz, lines(age, c(fitted(fit)), 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.
+data(bminz)
+o = with(bminz, order(age))
+bminz = bminz[o,] # Sort by age
+fit3 = vgam(BMI ~ s(age, df=4), fam=alsqreg(w=c(.1,1,10), parallel=TRUE),
+ data=bminz, trac=TRUE)
+fit3 at extra # The w values, percentiles and weighted deviances
+
+# The linear components of the fit; not for human consumption:
+coef(fit3, matrix=TRUE)
+
+\dontrun{
+# Quantile plot
+with(bminz, plot(age, BMI, col="blue", main=
+ paste(paste(round(fit3 at extra$percentile, dig=1), collapse=", "),
+ "percentile curves")))
+with(bminz, matlines(age, fitted(fit3), col=1:fit3 at extra$M, lwd=2))
+with(bminz, lines(age, c(fitted(fit )), col="black")) # For comparison
+}
}
\keyword{models}
\keyword{regression}
diff --git a/man/fgm.Rd b/man/amh.Rd
similarity index 51%
copy from man/fgm.Rd
copy to man/amh.Rd
index 540ae60..d2ca0ff 100644
--- a/man/fgm.Rd
+++ b/man/amh.Rd
@@ -1,30 +1,32 @@
-\name{fgm}
-\alias{fgm}
+\name{amh}
+\alias{amh}
%- Also NEED an '\alias' for EACH other topic documented here.
-\title{ Farlie-Gumbel-Morgenstern's Bivariate Distribution Family Function }
+\title{ Ali-Mikhail-Haq Distribution Distribution Family Function }
\description{
- Estimate the association parameter of
- Farlie-Gumbel-Morgenstern's bivariate
- distribution using maximum likelihood estimation.
+ Estimate the association parameter of
+ Ali-Mikhail-Haq's bivariate
+ distribution by maximum likelihood estimation.
}
\usage{
-fgm(lapar="identity", earg=list(), iapar=NULL, method.init=1)
+amh(lalpha="rhobit", ealpha=list(), ialpha=NULL,
+ method.init=1, nsimEIM=250)
}
%- maybe also 'usage' for other objects documented here.
\arguments{
- \item{lapar}{
+ \item{lalpha}{
Link function applied to the association parameter
- \eqn{\alpha}{alpha}, which is real.
+ \eqn{\alpha}{alpha}, which is real
+ and \eqn{-1 < \alpha < 1}{-1 < alpha < 1}.
See \code{\link{Links}} for more choices.
}
- \item{earg}{
+ \item{ealpha}{
List. Extra argument for the link.
See \code{earg} in \code{\link{Links}} for general information.
}
- \item{iapar}{
+ \item{ialpha}{
Numeric. Optional initial value for \eqn{\alpha}{alpha}.
By default, an initial value is chosen internally.
If a convergence failure occurs try assigning a different value.
@@ -34,27 +36,30 @@ fgm(lapar="identity", earg=list(), iapar=NULL, method.init=1)
\item{method.init}{
An integer with value \code{1} or \code{2} which
specifies the initialization method. If failure to converge occurs
- try the other value, or else specify a value for \code{ia}.
+ try the other value, or else specify a value for \code{ialpha}.
+
+ }
+ \item{nsimEIM}{
+ See \code{\link{CommonVGAMffArguments}} for more information.
}
}
\details{
The cumulative distribution function is
\deqn{P(Y_1 \leq y_1, Y_2 \leq y_2) = y_1 y_2
- ( 1 + \alpha (1 - y_1) (1 - y_2) ) }{%
- P(Y1 <= y1, Y2 <= y2) =
- y1 * y2 * ( 1 + alpha * (1 - y1) * (1 - y2) ) }
- for real \eqn{\alpha}{alpha}
- (the range is data-dependent).
+ / ( 1 - \alpha (1 - y_1) (1 - y_2) ) }{%
+ P(Y1 <= y1, Y2 <= y2) =
+ y1 * y2 / ( 1 - alpha * (1 - y1) * (1 - y2) ) }
+ for \eqn{-1 < \alpha < 1}{-1 < alpha < 1}.
The support of the function is the unit square.
The marginal distributions are the standard uniform distributions.
- When \eqn{\alpha = 0}{alpha=0} then the random variables are
+ When \eqn{\alpha = 0}{alpha=0} the random variables are
independent.
- A variant of Newton-Raphson is used, which only seems to work for an
- intercept model.
- It is a very good idea to set \code{trace=TRUE}.
- This \pkg{VGAM} family function is prone to numerical difficulties.
+% A variant of Newton-Raphson is used, which only seems to work for an
+% intercept model.
+% It is a very good idea to set \code{trace=TRUE}.
+% This \pkg{VGAM} family function is prone to numerical difficulties.
}
\value{
@@ -65,36 +70,36 @@ fgm(lapar="identity", earg=list(), iapar=NULL, method.init=1)
\references{
-Castillo, E., Hadi, A. S., Balakrishnan, N. Sarabia, J. S. (2005)
-\emph{Extreme Value and Related Models with Applications in Engineering and Science},
-Hoboken, N.J.: Wiley-Interscience.
+Hutchinson, T. P. and Lai, C. D. (1990)
+\emph{Continuous Bivariate Distributions, Emphasising Applications},
+Adelaide, South Australia: Rumsby Scientific Publishing.
}
-\author{ T. W. Yee }
+\author{ T. W. Yee and C. S. Chee }
\note{
The response must be a two-column matrix. Currently, the fitted
value is a matrix with two columns and values equal to 0.5.
This is because each marginal distribution corresponds to a standard
uniform distribution.
-% This \pkg{VGAM} family function should be used with caution.
}
\seealso{
- \code{\link{frank}},
- \code{\link{morgenstern}}.
+ \code{\link{ramh}},
+ \code{\link{fgm}},
+ \code{\link{gumbelIbiv}}.
+
}
\examples{
-n = 1000
-ymat = cbind(runif(n), runif(n))
-\dontrun{plot(ymat)}
-fit = vglm(ymat ~ 1, fam=fgm, trace=TRUE)
-fit = vglm(ymat ~ 1, fam=fgm, trace=TRUE, crit="coef")
-coef(fit, matrix=TRUE)
+ymat = ramh(1000, alpha=rhobit(2, inverse=TRUE))
+fit = vglm(ymat ~ 1, amh, trace = TRUE)
+coef(fit, mat=TRUE)
Coef(fit)
-fitted(fit)[1:5,]
}
\keyword{models}
\keyword{regression}
+
+
+
diff --git a/man/amhUC.Rd b/man/amhUC.Rd
new file mode 100644
index 0000000..b9fb224
--- /dev/null
+++ b/man/amhUC.Rd
@@ -0,0 +1,70 @@
+\name{Amh}
+\alias{Amh}
+\alias{damh}
+\alias{pamh}
+\alias{ramh}
+\title{Ali-Mikhail-Haq Distribution's Bivariate Distribution}
+\description{
+ Density, distribution function, and random
+ generation for the (one parameter) bivariate
+ Ali-Mikhail-Haq distribution.
+
+}
+\usage{
+damh(x1, x2, alpha, log=FALSE)
+pamh(q1, q2, alpha)
+ramh(n, alpha)
+}
+\arguments{
+ \item{x1, x2, q1, q2}{vector of quantiles.}
+ \item{n}{number of observations.
+ Must be a positive integer of length 1.}
+ \item{alpha}{the association parameter.}
+ \item{log}{
+ Logical.
+ If \code{TRUE} then the logarithm is returned.
+
+ }
+}
+\value{
+ \code{damh} gives the density,
+ \code{pamh} gives the distribution function, and
+ \code{ramh} generates random deviates (a two-column matrix).
+}
+%\references{
+%
+%}
+\author{ T. W. Yee and C. S. Chee}
+\details{
+ See \code{\link{amh}}, the \pkg{VGAM}
+ family functions for estimating the
+ parameter by maximum likelihood estimation, for the formula of the
+ cumulative distribution function and other details.
+
+}
+%\note{
+%}
+\seealso{
+ \code{\link{amh}}.
+
+}
+\examples{
+x = seq(0, 1, len=(N <- 101))
+alpha = 0.7
+ox = expand.grid(x, x)
+z = damh(ox[,1], ox[,2], alpha=alpha)
+\dontrun{
+contour(x, x, matrix(z, N, N), col="blue")
+z = pamh(ox[,1], ox[,2], alpha=alpha)
+contour(x, x, matrix(z, N, N), col="blue")
+
+plot(r <- ramh(n=1000, alpha=alpha), col="blue")
+par(mfrow=c(1,2))
+hist(r[,1]) # Should be uniform
+hist(r[,2]) # Should be uniform
+}
+}
+\keyword{distribution}
+
+
+
diff --git a/man/amlbinomial.Rd b/man/amlbinomial.Rd
new file mode 100644
index 0000000..e5ffb2c
--- /dev/null
+++ b/man/amlbinomial.Rd
@@ -0,0 +1,137 @@
+\name{amlbinomial}
+\alias{amlbinomial}
+%- Also NEED an '\alias' for EACH other topic documented here.
+\title{ Binomial Logistic Regression by Asymmetric Maximum Likelihood Estimation }
+\description{
+ Binomial quantile regression estimated by maximizing an asymmetric
+ likelihood function.
+
+}
+\usage{
+amlbinomial(w.aml=1, parallel=FALSE, digw=4, link="logit", earg=list())
+}
+%- maybe also 'usage' for other objects documented here.
+\arguments{
+ \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'').
+ The default value of unity results in the ordinary maximum likelihood
+ (MLE) solution.
+
+ }
+ \item{parallel}{
+ 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
+ not cross (although they may not cross anyway).
+ See \code{\link{CommonVGAMffArguments}} for more information.
+
+ }
+ \item{digw }{
+ Passed into \code{\link[base]{Round}} as the \code{digits} argument
+ for the \code{w.aml} values;
+ used cosmetically for labelling.
+
+ }
+ \item{link, earg}{
+ See \code{\link{binomialff}}.
+
+ }
+}
+\details{
+ The general methodology behind this \pkg{VGAM} family function
+ is given in Efron (1992) and full details can be obtained there.
+% Equation numbers below refer to that article.
+ This model is essentially a logistic regression model
+ (see \code{\link{binomialff}}) but the usual deviance is replaced by an
+ asymmetric squared error loss function; it is multiplied by
+ \eqn{w.aml} for positive residuals.
+ The solution is the set of regression coefficients that minimize the
+ sum of these deviance-type values over the data set, weighted by
+ the \code{weights} argument (so that it can contain frequencies).
+ Newton-Raphson estimation is used here.
+
+}
+\value{
+ An object of class \code{"vglmff"} (see \code{\link{vglmff-class}}).
+ The object is used by modelling functions such as \code{\link{vglm}}
+ and \code{\link{vgam}}.
+
+}
+\references{
+ Efron, B. (1992)
+ Poisson overdispersion estimates based on the method of
+ asymmetric maximum likelihood.
+ \emph{Journal of the American Statistical Association},
+ \bold{87}, 98--107.
+
+}
+
+\author{ Thomas W. Yee }
+\note{
+ 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.
+ 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.
+
+}
+
+\section{Warning }{
+ If \code{w.aml} has more than one value then the value returned by
+ \code{deviance} is the sum of all the (weighted) deviances taken over
+ all the \code{w.aml} values.
+ See Equation (1.6) of Efron (1992).
+
+}
+\seealso{
+ \code{\link{amlpoisson}},
+ \code{\link{amlexponential}},
+ \code{\link{alsqreg}}.
+
+}
+
+\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))
+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))
+fit at extra
+
+\dontrun{
+par(mfrow=c(1,2))
+# Quantile plot
+with(mydat, plot(x, jitter(y), col="blue", las=1, main=
+ paste(paste(round(fit at extra$percentile, dig=1), collapse=", "),
+ "expectile curves")))
+with(mydat, matlines(x, fitted(fit), lwd=2, col="blue", lty=1))
+
+
+# Compare the fitted expectiles with the quantiles
+with(mydat, plot(x, jitter(y), col="blue", las=1, main=
+ paste(paste(round(fit at extra$percentile, dig=1), collapse=", "),
+ "percentile curves are red")))
+with(mydat, matlines(x, fitted(fit), lwd=2, col="blue", lty=1))
+
+for(ii in fit at extra$percentile)
+ with(mydat, matlines(x, qbinom(p=ii/100, size=sizevec, prob=prob)/sizevec,
+ col="red", lwd=2, lty=1))
+}
+}
+\keyword{models}
+\keyword{regression}
+
diff --git a/man/amlexponential.Rd b/man/amlexponential.Rd
new file mode 100644
index 0000000..8df359c
--- /dev/null
+++ b/man/amlexponential.Rd
@@ -0,0 +1,144 @@
+\name{amlexponential}
+\alias{amlexponential}
+%- Also NEED an '\alias' for EACH other topic documented here.
+\title{ Exponential Regression by Asymmetric Maximum Likelihood Estimation }
+\description{
+ Exponential expectile regression estimated by maximizing an asymmetric
+ likelihood function.
+
+}
+\usage{
+amlexponential(w.aml=1, parallel=FALSE, method.init=1, digw=4,
+ link="loge", earg=list())
+}
+%- maybe also 'usage' for other objects documented here.
+\arguments{
+ \item{w.aml}{
+ Numeric, a vector of positive constants controlling the expectiles.
+ The larger the value the larger the fitted expectile value
+ (the proportion of points below the ``w-regression plane'').
+ The default value of unity results in the ordinary maximum likelihood
+ (MLE) solution.
+
+ }
+ \item{parallel}{
+ 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
+ not cross (although they may not cross anyway).
+ See \code{\link{CommonVGAMffArguments}} for more information.
+
+ }
+ \item{method.init}{
+ Integer, either 1 or 2 or 3. Initialization method.
+ Choose another value if convergence fails.
+
+ }
+ \item{digw }{
+ Passed into \code{\link[base]{Round}} as the \code{digits} argument
+ for the \code{w.aml} values;
+ used cosmetically for labelling.
+
+ }
+ \item{link, earg}{
+ See \code{\link{exponential}} and the warning below.
+
+ }
+}
+\details{
+ The general methodology behind this \pkg{VGAM} family function
+ is given in Efron (1992) and full details can be obtained there.
+% Equation numbers below refer to that article.
+ This model is essentially an exponential regression model
+ (see \code{\link{exponential}}) but the usual deviance is replaced by an
+ asymmetric squared error loss function; it is multiplied by
+ \eqn{w.aml} for positive residuals.
+ The solution is the set of regression coefficients that minimize the
+ sum of these deviance-type values over the data set, weighted by
+ the \code{weights} argument (so that it can contain frequencies).
+ Newton-Raphson estimation is used here.
+
+}
+\value{
+ An object of class \code{"vglmff"} (see \code{\link{vglmff-class}}).
+ The object is used by modelling functions such as \code{\link{vglm}}
+ and \code{\link{vgam}}.
+
+}
+\references{
+ Efron, B. (1992)
+ Poisson overdispersion estimates based on the method of
+ asymmetric maximum likelihood.
+ \emph{Journal of the American Statistical Association},
+ \bold{87}, 98--107.
+
+}
+
+\author{ Thomas W. Yee }
+\note{
+ 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.
+ 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.
+
+}
+
+\section{Warning }{
+ Note that the \code{link} argument of \code{\link{exponential}} and
+ \code{\link{amlexponential}} are currently different: one is the
+ rate parameter and the other is the mean (expectile) parameter.
+
+ If \code{w.aml} has more than one value then the value returned by
+ \code{deviance} is the sum of all the (weighted) deviances taken over
+ all the \code{w.aml} values.
+ See Equation (1.6) of Efron (1992).
+
+}
+\seealso{
+ \code{\link{exponential}},
+ \code{\link{amlbinomial}},
+ \code{\link{amlpoisson}},
+ \code{\link{alsqreg}}.
+
+}
+
+\examples{
+n = 2000
+mydat = data.frame(x = seq(0, 1, length=n))
+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))
+(fit = vgam(y ~ s(x,df=5), amlexponential(w=c(0.001,0.1,0.5,5,60)),
+ data=mydat, trace=TRUE))
+fit at extra
+
+\dontrun{
+# These plots are against the sqrt scale (to increase clarity)
+par(mfrow=c(1,2))
+# Quantile plot
+with(mydat, plot(x, sqrt(y), col="blue", las=1, main=
+ paste(paste(round(fit at extra$percentile, dig=1), collapse=", "),
+ "expectile curves")))
+with(mydat, matlines(x, sqrt(fitted(fit)), lwd=2, col="blue", lty=1))
+
+# Compare the fitted expectiles with the quantiles
+with(mydat, plot(x, sqrt(y), col="blue", las=1, main=
+ paste(paste(round(fit at extra$percentile, dig=1), collapse=", "),
+ "percentile curves are red")))
+with(mydat, matlines(x, sqrt(fitted(fit)), lwd=2, col="blue", lty=1))
+
+for(ii in fit at extra$percentile)
+ with(mydat, matlines(x, sqrt(qexp(p=ii/100, rate=1/mu)), col="red"))
+}
+}
+\keyword{models}
+\keyword{regression}
+
diff --git a/man/amlpoisson.Rd b/man/amlpoisson.Rd
new file mode 100644
index 0000000..79019f6
--- /dev/null
+++ b/man/amlpoisson.Rd
@@ -0,0 +1,150 @@
+\name{amlpoisson}
+\alias{amlpoisson}
+%- Also NEED an '\alias' for EACH other topic documented here.
+\title{ Poisson Regression by Asymmetric Maximum Likelihood Estimation }
+\description{
+ Poisson quantile regression estimated by maximizing an
+ asymmetric likelihood function.
+
+}
+\usage{
+amlpoisson(w.aml=1, parallel=FALSE, method.init=1, digw=4,
+ link="loge", earg=list())
+}
+%- maybe also 'usage' for other objects documented here.
+\arguments{
+ \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'').
+ The default value of unity results in the ordinary maximum likelihood
+ (MLE) solution.
+
+ }
+ \item{parallel}{
+ 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
+ not cross (although they may not cross anyway).
+ See \code{\link{CommonVGAMffArguments}} for more information.
+
+ }
+ \item{method.init}{
+ Integer, either 1 or 2 or 3. Initialization method.
+ Choose another value if convergence fails.
+
+ }
+ \item{digw }{
+ Passed into \code{\link[base]{Round}} as the \code{digits} argument
+ for the \code{w.aml} values;
+ used cosmetically for labelling.
+
+ }
+ \item{link, earg}{
+ See \code{\link{poissonff}}.
+
+ }
+}
+\details{
+ This method was proposed by Efron (1992) and full details can
+ be obtained there.
+% Equation numbers below refer to that article.
+ The model is essentially a Poisson regression model
+ (see \code{\link{poissonff}}) but the usual deviance is replaced by an
+ asymmetric squared error loss function; it is multiplied by
+ \eqn{w.aml} for positive residuals.
+ The solution is the set of regression coefficients that minimize the
+ sum of these deviance-type values over the data set, weighted by
+ the \code{weights} argument (so that it can contain frequencies).
+ Newton-Raphson estimation is used here.
+
+}
+\value{
+ An object of class \code{"vglmff"} (see \code{\link{vglmff-class}}).
+ The object is used by modelling functions such as \code{\link{vglm}}
+ and \code{\link{vgam}}.
+
+}
+\references{
+ Efron, B. (1991)
+ Regression percentiles using asymmetric squared error loss.
+ \emph{Statistica Sinica},
+ \bold{1}, 93--125.
+
+ Efron, B. (1992)
+ Poisson overdispersion estimates based on the method of
+ asymmetric maximum likelihood.
+ \emph{Journal of the American Statistical Association},
+ \bold{87}, 98--107.
+
+ Koenker, R. and Bassett, G. (1978)
+ Regression quantiles.
+ \emph{Econometrica},
+ \bold{46}, 33--50.
+
+ Newey, W. K. and Powell, J. L. (1987)
+ Asymmetric least squares estimation and testing.
+ \emph{Econometrica},
+ \bold{55}, 819--847.
+
+}
+
+\author{ Thomas W. Yee }
+\note{
+ 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. Also,
+ 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.
+ This was deliberate so as to distinguish them from the original
+ \emph{regression quantiles} of Koenker and Bassett (1978).
+ Efron (1991) and Efron (1992) use the general name
+ \emph{regression percentile} to apply to all forms of asymmetric
+ fitting.
+ Although the asymmetric maximum likelihood method very nearly gives
+ regression percentiles in the strictest sense for the normal and
+ Poisson cases, the phrase \emph{quantile regression} is used loosely
+ in this \pkg{VGAM} documentation.
+
+}
+
+\section{Warning }{
+ If \code{w.aml} has more than one value then the value returned by
+ \code{deviance} is the sum of all the (weighted) deviances taken over
+ all the \code{w.aml} values.
+ See Equation (1.6) of Efron (1992).
+
+}
+\seealso{
+ \code{\link{alsqreg}},
+ \code{\link{amlbinomial}}.
+
+}
+
+\examples{
+set.seed(1234)
+mydat = data.frame(x = sort(runif(n <- 200)))
+mydat = transform(mydat, y = rpois(n, 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))
+fit at extra
+
+\dontrun{
+# Quantile plot
+with(mydat, plot(x, jitter(y), col="blue", las=1, main=
+ paste(paste(round(fit at extra$percentile, dig=1), collapse=", "),
+ "percentile curves")))
+with(mydat, matlines(x, fitted(fit), lwd=2))
+}
+}
+\keyword{models}
+\keyword{regression}
+
diff --git a/man/betaff.Rd b/man/beta.ab.Rd
similarity index 73%
copy from man/betaff.Rd
copy to man/beta.ab.Rd
index 9218447..11e6db7 100644
--- a/man/betaff.Rd
+++ b/man/beta.ab.Rd
@@ -1,27 +1,28 @@
-\name{betaff}
-\alias{betaff}
+\name{beta.ab}
+\alias{beta.ab}
%- Also NEED an '\alias' for EACH other topic documented here.
\title{ The Two-parameter Beta Distribution Family Function }
\description{
- Estimation of the shape parameters of the
- two-parameter Beta distribution.
+ Estimation of the shape parameters of the two-parameter beta
+ distribution.
}
\usage{
-betaff(link = "loge", earg=list(),
- i1 = NULL, i2 = NULL, trim = 0.05,
- A = 0, B = 1, zero = NULL)
+beta.ab(lshape1="loge", lshape2="loge",
+ eshape1=list(), eshape2=list(),
+ i1 = NULL, i2 = NULL, trim = 0.05,
+ A = 0, B = 1, parallel=FALSE, zero=NULL)
}
%- maybe also 'usage' for other objects documented here.
\arguments{
- \item{link}{
- Parameter link function applied to the two shape parameters.
+ \item{lshape1, lshape2}{
+ Parameter link functions applied to the two shape parameters.
See \code{\link{Links}} for more choices.
- A log link (default) ensures that the parameters are positive.
+ The log link (defaults) ensures that the parameters are positive.
}
- \item{earg}{
- List. Extra argument for the link.
+ \item{eshape1, eshape2}{
+ List. Extra argument for the links.
See \code{earg} in \code{\link{Links}} for general information.
}
@@ -43,16 +44,13 @@ betaff(link = "loge", earg=list(),
where the response lies between 0 and 1.
}
- \item{zero}{
- An integer-valued vector specifying which
- linear/additive predictors are modelled as intercepts only.
- If used, the value must be from the set \{1,2\} which correspond to
- the first and second shape parameters respectively.
+ \item{parallel, zero}{
+ See \code{\link{CommonVGAMffArguments}} for more information.
}
}
\details{
- The two-parameter Beta distribution is given by
+ The two-parameter beta distribution is given by
\eqn{f(y) =}
\deqn{(y-A)^{shape1-1} \times (B-y)^{shape2-1} / [Beta(shape1,shape2)
\times (B-A)^{shape1+shape2-1}]}{%
@@ -75,6 +73,9 @@ betaff(link = "loge", earg=list(),
\eqn{\mu=shape1 / (shape1 + shape2)}{mu=shape1 / (shape1 + shape2)}
is the mean of \eqn{Y}.
+ Another parameterization of the beta distribution involving the mean
+ and a precision parameter is implemented in \code{\link{betaff}}.
+
If \eqn{A} and \eqn{B} are unknown, then the \pkg{VGAM} family function
\code{beta4()} can be used to estimate these too.
@@ -108,10 +109,12 @@ betaff(link = "loge", earg=list(),
\author{ Thomas W. Yee }
\note{
The response must have values in the interval (\eqn{A}, \eqn{B}).
+ \pkg{VGAM} 0.7-4 and prior called this function \code{\link{betaff}}.
}
\seealso{
+ \code{\link{betaff}},
\code{\link[stats:Beta]{Beta}},
\code{\link{genbetaII}},
\code{\link{betaII}},
@@ -120,26 +123,29 @@ betaff(link = "loge", earg=list(),
\code{\link{betaprime}},
\code{\link{rbetageom}},
\code{\link{rbetanorm}},
+ \code{\link{kumar}},
\code{beta4}.
+
}
\examples{
y = rbeta(n=1000, shape1=exp(0), shape2=exp(1))
-fit = vglm(y ~ 1, betaff(link="identity"), trace = TRUE, crit="c")
-fit = vglm(y ~ 1, betaff, trace = TRUE, crit="c")
+fit = vglm(y ~ 1, beta.ab(lshape1="identity", lshape2="identity"),
+ trace = TRUE, crit="c")
+fit = vglm(y ~ 1, beta.ab, 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, betaff(A=5, B=13), trace = TRUE)
+fit = vglm(Y ~ 1, beta.ab(A=5, B=13), trace = TRUE)
Coef(fit)
-fitted(fit)[1:4,]
+c(mean(Y), fitted(fit)[1:2,])
}
\keyword{models}
\keyword{regression}
% 3/1/06; this works well:
-% fit=vglm(y~1, betaffqn(link=logoff,earg=list(offset=1)), tr=TRUE, cri="c")
+% fit=vglm(y~1, beta.abqn(link=logoff,earg=list(offset=1)), tr=TRUE, cri="c")
% 3/1/06; this does not work so well:
-% it=vglm(y~1, betaffqn(link=logoff,earg=list(offset=0)), tr=TRUE, cri="c")
+% it=vglm(y~1, beta.abqn(link=logoff,earg=list(offset=0)), tr=TRUE, cri="c")
% Interesting!!
diff --git a/man/betaff.Rd b/man/betaff.Rd
index 9218447..a25e703 100644
--- a/man/betaff.Rd
+++ b/man/betaff.Rd
@@ -3,102 +3,91 @@
%- Also NEED an '\alias' for EACH other topic documented here.
\title{ The Two-parameter Beta Distribution Family Function }
\description{
- Estimation of the shape parameters of the
- two-parameter Beta distribution.
+ Estimation of the mean and precision parameters of the beta distribution.
}
\usage{
-betaff(link = "loge", earg=list(),
- i1 = NULL, i2 = NULL, trim = 0.05,
- A = 0, B = 1, zero = NULL)
+betaff(A=0, B=1,
+ lmu=if(A==0 & B==1) "logit" else "elogit", lphi="loge",
+ emu=if(lmu=="elogit") list(min=A,max=B) else list(),
+ ephi=list(), imu=NULL, iphi=NULL, method.init=1, zero=NULL)
}
%- maybe also 'usage' for other objects documented here.
\arguments{
- \item{link}{
- Parameter link function applied to the two shape parameters.
+ \item{A, B}{
+ Lower and upper limits of the distribution.
+ The defaults correspond to the \emph{standard beta distribution}
+ where the response lies between 0 and 1.
+
+ }
+ \item{lmu, lphi}{
+ Link function for the mean and precision parameters.
+ See below for more details.
See \code{\link{Links}} for more choices.
- A log link (default) ensures that the parameters are positive.
}
- \item{earg}{
- List. Extra argument for the link.
+ \item{emu, ephi}{
+ List. Extra argument for the respective links.
See \code{earg} in \code{\link{Links}} for general information.
}
- \item{i1, i2}{
- Initial value for the first and second shape parameters respectively.
- A \code{NULL} value means it is obtained in the \code{initialize} slot.
+ \item{imu, iphi}{
+ Optional initial value for the mean and precision parameters
+ respectively. A \code{NULL} value means a value is obtained in the
+ \code{initialize} slot.
}
- \item{trim}{
- An argument which is fed into \code{mean()}; it is the fraction (0
- to 0.5) of observations to be trimmed from each end of the response
- \code{y} before the mean is computed. This is used when computing
- initial values, and guards against outliers.
-
- }
- \item{A, B}{
- Lower and upper limits of the distribution.
- The defaults correspond to the \emph{standard beta distribution}
- where the response lies between 0 and 1.
-
- }
- \item{zero}{
- An integer-valued vector specifying which
- linear/additive predictors are modelled as intercepts only.
- If used, the value must be from the set \{1,2\} which correspond to
- the first and second shape parameters respectively.
+ \item{method.init, zero}{
+ See \code{\link{CommonVGAMffArguments}} for more information.
}
}
\details{
- The two-parameter Beta distribution is given by
+ The two-parameter beta distribution can be written
\eqn{f(y) =}
- \deqn{(y-A)^{shape1-1} \times (B-y)^{shape2-1} / [Beta(shape1,shape2)
- \times (B-A)^{shape1+shape2-1}]}{%
- (y-A)^(shape1-1) * (B-y)^(shape2-1) / [Beta(shape1,shape2) *
- (B-A)^(shape1+shape2-1)]}
- for \eqn{A < y < B}, and \eqn{Beta(.,.)} is the beta function
- (see \code{\link[base:Special]{beta}}).
- The shape parameters are positive, and
- here, the limits \eqn{A} and \eqn{B} are known.
- The mean of \eqn{Y} is \eqn{E(Y) = A + (B-A) \times shape1 /
- (shape1 + shape2)}{E(Y) = A + (B-A) * shape1 /
- (shape1 + shape2)}, and these are the fitted values of the object.
-
- For the standard beta distribution the variance of \eqn{Y} is
- \eqn{shape1 \times shape2 / [(1+shape1+shape2) \times (shape1+shape2)^2]}{
- shape1 * shape2 / ((1+shape1+shape2) * (shape1+shape2)^2)}.
- If \eqn{\sigma^2= 1 / (1+shape1+shape2)}
- then the variance of \eqn{Y} can be written
- \eqn{\sigma^2 \mu (1-\mu)}{mu*(1-mu)*sigma^2} where
- \eqn{\mu=shape1 / (shape1 + shape2)}{mu=shape1 / (shape1 + shape2)}
- is the mean of \eqn{Y}.
-
- If \eqn{A} and \eqn{B} are unknown, then the \pkg{VGAM} family function
+ \deqn{(y-A)^{\mu_1 \phi-1} \times (B-y)^{(1-\mu_1) \phi-1} / [beta(\mu_1
+ \phi,(1-\mu_1) \phi) \times (B-A)^{\phi-1}]}{%
+ (y-A)^(mu1*phi-1) * (B-y)^((1-mu1)*phi-1) / [beta(mu1*phi,(1-mu1)*phi) *
+ (B-A)^(phi-1)]}
+ for \eqn{A < y < B}, and \eqn{beta(.,.)} is the beta function
+ (see \code{\link[base:Special]{beta}}).
+ The parameter \eqn{\mu_1}{mu1} satisfies
+ \eqn{\mu_1 = (\mu - A) / (B-A)}{mu1 = (mu - A) / (B-A)}
+ where \eqn{\mu}{mu} is the mean of \eqn{Y}.
+ That is, \eqn{\mu_1}{mu1} is the mean of of a standard beta distribution:
+ \eqn{E(Y) = A + (B-A) \times \mu_1}{E(Y) = A + (B-A)*mu1},
+ and these are the fitted values of the object.
+ Also, \eqn{\phi}{phi} is positive and \eqn{A < \mu < B}{A < mu < B}.
+ Here, the limits \eqn{A} and \eqn{B} are \emph{known}.
+
+ Another parameterization of the beta distribution involving the raw
+ shape parameters is implemented in \code{\link{beta.ab}}.
+
+ For general \eqn{A} and \eqn{B}, the variance of \eqn{Y} is
+ \eqn{(B-A)^2 \times \mu_1 \times (1-\mu_1) / (1+\phi)}{(B-A)^2 *
+ mu1 * (1-mu1) / (1+phi)}.
+ Then \eqn{\phi}{phi} can be interpreted as a \emph{precision} parameter
+ in the sense that, for fixed \eqn{\mu}{mu}, the larger the value of
+ \eqn{\phi}{phi}, the smaller the variance of \eqn{Y}.
+ Also, \eqn{\mu_1 = shape1/(shape1+shape2)}{mu1=shape1/(shape1+shape2)} and
+ \eqn{\phi = shape1+shape2}{phi = shape1+shape2}.
+
+ Fisher scoring is implemented.
+ If \eqn{A} and \eqn{B} are unknown then the \pkg{VGAM} family function
\code{beta4()} can be used to estimate these too.
}
\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{
- Johnson, N. L. and Kotz, S. and Balakrishnan, N. (1995)
- Chapter 25 of:
- \emph{Continuous Univariate Distributions},
- 2nd edition, Volume 2, New York: Wiley.
-
- Gupta, A. K. and Nadarajah, S. (2004)
- \emph{Handbook of Beta Distribution and Its Applications},
- NY: Marcel Dekker, Inc.
-
-%Evans, M., Hastings, N. and Peacock, B. (2000)
-%\emph{Statistical Distributions},
-%New York: Wiley-Interscience, Third edition.
+ Ferrari, S. L. P. and Francisco C.-N. (2004)
+ Beta regression for modelling rates and proportions.
+ \emph{Journal of Applied Statistics},
+ \bold{31}, 799--815.
Documentation accompanying the \pkg{VGAM} package at
\url{http://www.stat.auckland.ac.nz/~yee}
@@ -112,6 +101,7 @@ betaff(link = "loge", earg=list(),
}
\seealso{
+ \code{\link{beta.ab}},
\code{\link[stats:Beta]{Beta}},
\code{\link{genbetaII}},
\code{\link{betaII}},
@@ -120,26 +110,27 @@ betaff(link = "loge", earg=list(),
\code{\link{betaprime}},
\code{\link{rbetageom}},
\code{\link{rbetanorm}},
- \code{beta4}.
+ \code{\link{kumar}},
+ \code{beta4},
+ \code{\link{elogit}}.
+
}
\examples{
-y = rbeta(n=1000, shape1=exp(0), shape2=exp(1))
-fit = vglm(y ~ 1, betaff(link="identity"), trace = TRUE, crit="c")
-fit = vglm(y ~ 1, betaff, trace = TRUE, crit="c")
+y = rbeta(n <- 1000, shape1=exp(0), shape2=exp(1))
+fit = vglm(y ~ 1, betaff, 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 ~ 1, betaff(A=5, B=13), trace = TRUE)
-Coef(fit)
-fitted(fit)[1:4,]
+fit = vglm(Y ~ x, betaff(A=5,B=13), trace=TRUE)
+coef(fit, mat=TRUE)
}
\keyword{models}
\keyword{regression}
-
-% 3/1/06; this works well:
-% fit=vglm(y~1, betaffqn(link=logoff,earg=list(offset=1)), tr=TRUE, cri="c")
-% 3/1/06; this does not work so well:
-% it=vglm(y~1, betaffqn(link=logoff,earg=list(offset=0)), tr=TRUE, cri="c")
-% Interesting!!
-
diff --git a/man/betanormUC.Rd b/man/betanormUC.Rd
index e080c25..b0fcc4c 100644
--- a/man/betanormUC.Rd
+++ b/man/betanormUC.Rd
@@ -11,7 +11,7 @@
}
\usage{
-dbetanorm(x, shape1, shape2, mean=0, sd=1, log.arg=FALSE)
+dbetanorm(x, shape1, shape2, mean=0, sd=1, log=FALSE)
pbetanorm(q, shape1, shape2, mean=0, sd=1, lower.tail=TRUE, log.p=FALSE)
qbetanorm(p, shape1, shape2, mean=0, sd=1)
rbetanorm(n, shape1, shape2, mean=0, sd=1)
@@ -32,7 +32,7 @@ rbetanorm(n, shape1, shape2, mean=0, sd=1)
normal distribution.
}
- \item{log.arg, log.p}{
+ \item{log, log.p}{
Logical.
If \code{TRUE} then all probabilities \code{p} are given as \code{log(p)}.
diff --git a/man/binomialff.Rd b/man/binomialff.Rd
index e455828..3fa4ab1 100644
--- a/man/binomialff.Rd
+++ b/man/binomialff.Rd
@@ -37,9 +37,9 @@ binomialff(link = "logit", earg = list(),
}
\item{mv}{
Multivariate response? If \code{TRUE}, then the response is interpreted
- as \eqn{M} binary responses, where \eqn{M} is the number of columns
- of the response matrix. In this case, the response matrix should have
- zero/one values only.
+ as \eqn{M} independent binary responses, where \eqn{M} is the number
+ of columns of the response matrix. In this case, the response matrix
+ should have zero/one values only.
If \code{FALSE} and the response is a (2-column) matrix, then the number
of successes is given in the first column, and the second column is
@@ -97,8 +97,9 @@ binomialff(link = "logit", earg = list(),
}
\references{
- McCullagh, P. and Nelder, J. A. (1989)
+ McCullagh, P. and Nelder, J. A. (1989)
\emph{Generalized Linear Models}, 2nd ed. London: Chapman & Hall.
+
}
\author{ Thomas W. Yee }
@@ -135,8 +136,11 @@ binomialff(link = "logit", earg = list(),
\code{\link{cao}},
\code{\link{zibinomial}},
\code{\link{dexpbinomial}},
+ \code{\link{mbinomial}},
\code{\link{seq2binomial}},
+ \code{\link{amlbinomial}},
\code{\link[stats:Binomial]{binomial}}.
+
}
\section{Warning }{
With a multivariate response, assigning a known dispersion parameter
diff --git a/man/borel.tanner.Rd b/man/borel.tanner.Rd
new file mode 100644
index 0000000..63bef95
--- /dev/null
+++ b/man/borel.tanner.Rd
@@ -0,0 +1,113 @@
+\name{borel.tanner}
+\alias{borel.tanner}
+%- Also NEED an '\alias' for EACH other topic documented here.
+\title{Borel-Tanner Distribution Family Function}
+\description{
+ Estimates the parameter of a Borel-Tanner distribution
+ by maximum likelihood estimation.
+
+}
+\usage{
+borel.tanner(Qsize=1, link="logit", earg=list(), method.init=1)
+}
+%- maybe also 'usage' for other objects documented here.
+\arguments{
+ \item{Qsize}{
+ A positive integer. It is called \eqn{Q} below and is the initial
+ queue size.
+
+ }
+ \item{link, earg}{
+ Link function and extra argument for the parameter.
+ See \code{\link{Links}} for more choices and for general information.
+
+ }
+ \item{method.init}{
+ See \code{\link{CommonVGAMffArguments}}.
+ Valid values are 1, 2, 3 or 4.
+
+ }
+}
+\details{
+ The Borel-Tanner distribution (Tanner, 1953) describes the
+ distribution of the total number of customers served before a queue
+ vanishes given a single queue with random arrival times of
+ customers (at a constant rate \eqn{r} per unit time,
+ and each customer taking a constant time \eqn{b} to be served).
+ Initially the queue has \eqn{Q} people and the first one starts to
+ be served.
+ The two parameters appear in the density only in the form of the product
+ \eqn{rb}, therefore we use \eqn{a=rb}, say, to denote the single
+ parameter to be estimated.
+ The density function is
+ \deqn{f(y;a) =
+ \frac{ Q! }{(y-Q)!} y^{y-Q-1} a^{y-Q} \exp(-ay)
+ }{%
+ f(y;a) =
+ (Q! / (y-Q)!) * y^(y-Q-1) * a^(y-Q) * exp(-ay)}
+ where \eqn{y=Q,Q+1,Q+2,\ldots}{y=Q,Q+1,Q+2,...}.
+ The case \eqn{Q=1} corresponds to the \emph{Borel} distribution
+ (Borel, 1942).
+ For the \eqn{Q=1} case it is necessary for \eqn{0 < a < 1} for the
+ distribution to be proper.
+ The Borel distribution is a basic Lagrangian distribution of the
+ first kind.
+ The Borel-Tanner distribution is an \eqn{Q}-fold convolution of the
+ Borel distribution.
+
+ The mean is \eqn{Q/(1-a)} (returned as the fitted values) and the
+ variance is \eqn{Q a / (1-a)^3}{Q*a/(1-a)^3}.
+ The distribution has a very long tail unless \eqn{a} is small.
+ Fisher scoring is implemented.
+
+}
+\value{
+ An object of class \code{"vglmff"} (see \code{\link{vglmff-class}}).
+ The object is used by modelling functions such as \code{\link{vglm}}
+ and \code{\link{vgam}}.
+
+}
+\references{
+Tanner, J. C. (1953)
+A problem of interference between two queues.
+\emph{Biometrika}, \bold{40}, 58--69.
+
+Borel, E. (1942)
+Sur l'emploi du theoreme de Bernoulli pour faciliter le
+calcul d'une infinite de coefficients.
+Application au probleme de l'attente a un guichet.
+\emph{Comptes Rendus, Academie des Sciences, Paris, Series A},
+\bold{214}, 452--456.
+
+ Page 328 of
+ Johnson N. L., Kemp, A. W. and Kotz S. (2005)
+ \emph{Univariate Discrete Distributions},
+ 3rd edition,
+ Hoboken, New Jersey: Wiley.
+
+Consul, P. C. and Famoye, F. (2006)
+\emph{Lagrangian Probability Distributions},
+Boston: Birkhauser.
+
+}
+\author{ T. W. Yee }
+%\note{
+%
+%}
+
+\seealso{
+ \code{\link{rbort}},
+ \code{\link{poissonff}},
+ \code{\link{felix}}.
+
+}
+\examples{
+y = rbort(n <- 200)
+fit = vglm(y ~ 1, borel.tanner, trace=TRUE, crit="c")
+coef(fit, matrix=TRUE)
+Coef(fit)
+summary(fit)
+}
+\keyword{models}
+\keyword{regression}
+
diff --git a/man/bortUC.Rd b/man/bortUC.Rd
new file mode 100644
index 0000000..ff2caa1
--- /dev/null
+++ b/man/bortUC.Rd
@@ -0,0 +1,64 @@
+\name{Bort}
+\alias{Bort}
+\alias{dbort}
+%\alias{pbort}
+%\alias{qbort}
+\alias{rbort}
+\title{The Borel-Tanner Distribution}
+\description{
+ Density
+% distribution function, quantile function
+ and random generation for the Borel-Tanner distribution.
+
+}
+\usage{
+dbort(x, Qsize=1, a=0.5)
+%pbort(q, Qsize=1, a=0.5)
+%qbort(p, Qsize=1, a=0.5)
+rbort(n, Qsize=1, a=0.5)
+}
+\arguments{
+ \item{x}{vector of quantiles.}
+% \item{p}{vector of probabilities.}
+ \item{n}{number of observations.
+ Must be a positive integer of length 1.}
+ \item{Qsize, a}{ See \code{\link{borel.tanner}}.
+ }
+}
+\value{
+ \code{dbort} gives the density,
+% \code{pbort} gives the distribution function,
+% \code{qbort} gives the quantile function, and
+ \code{rbort} generates random deviates.
+
+}
+\author{ T. W. Yee }
+\details{
+ See \code{\link{borel.tanner}}, the \pkg{VGAM} family function
+ for estimating the parameter,
+ for the formula of the probability density function and other details.
+
+}
+\section{Warning }{
+ Looping is used for \code{\link{rbort}}, therefore
+ values of \code{a} close to 1 will result in long (or infinite!)
+ computational times.
+ The default value of \code{a} is subjective.
+
+}
+\seealso{
+ \code{\link{borel.tanner}}.
+
+}
+\examples{
+\dontrun{
+qsize = 1; a = 0.5
+x = qsize:(qsize+10)
+plot(x, dbort(x, qsize, a), type="h", las=1, col="blue",
+ ylab=paste("fbort(qsize=", qsize, ", a=", a, ")"),
+ main="Borel-Tanner density function")
+}
+}
+\keyword{distribution}
+
+
diff --git a/man/cao.Rd b/man/cao.Rd
index 393080d..a8b409b 100644
--- a/man/cao.Rd
+++ b/man/cao.Rd
@@ -35,8 +35,11 @@ cao(formula, family, data = list(),
}
\item{family}{
- a function of class \code{"vglmff"} describing what statistical
- model is to be fitted.
+ a function of class \code{"vglmff"} (see \code{\link{vglmff-class}})
+ describing what statistical model is to be fitted. This is called a
+ ``\pkg{VGAM} family function''. See \code{\link{CommonVGAMffArguments}}
+ for general information about many types of arguments found in this
+ type of function.
See \code{\link{cqo}} for a list of those presently implemented.
}
@@ -223,6 +226,10 @@ Yee, T. W. (2006)
Constrained additive ordination.
\emph{Ecology}, \bold{87}, 203--213.
+ 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{
diff --git a/man/cardUC.Rd b/man/cardUC.Rd
new file mode 100644
index 0000000..31224f0
--- /dev/null
+++ b/man/cardUC.Rd
@@ -0,0 +1,80 @@
+\name{Card}
+\alias{Card}
+\alias{dcard}
+\alias{pcard}
+\alias{qcard}
+\alias{rcard}
+%- Also NEED an '\alias' for EACH other topic documented here.
+\title{ Cardioid Distribution }
+\description{
+ Density, distribution function, quantile function and random generation
+ for the cardioid distribution.
+
+}
+\usage{
+dcard(x, mu, rho)
+pcard(q, mu, rho)
+qcard(p, mu, rho, tolerance = 1e-07, maxits = 500)
+rcard(n, mu, rho, ...)
+}
+%- maybe also 'usage' for other objects documented here.
+\arguments{
+ \item{x, q}{vector of quantiles.}
+ \item{p}{vector of probabilities.}
+ \item{n}{number of observations. Must be a single positive integer. }
+ \item{mu, rho}{
+ See \code{\link{cardioid}} for more information.
+
+ }
+ \item{tolerance, maxits, ...}{
+ The first two are control parameters for the algorithm
+ used to solve for the roots of a nonlinear system of equations;
+ \code{tolerance} controls for the accuracy and
+ \code{maxits} is the maximum number of iterations.
+ \code{rcard} calls \code{qcard} so the \code{...} can be used
+ to vary the two arguments.
+
+ }
+}
+\details{
+ See \code{\link{cardioid}}, the \pkg{VGAM} family function
+ for estimating the two parameters by maximum likelihood estimation,
+ for the formula of the probability density function and other details.
+
+}
+\value{
+ \code{dcard} gives the density,
+ \code{pcard} gives the distribution function,
+ \code{qcard} gives the quantile function, and
+ \code{rcard} generates random deviates.
+}
+%\references{ }
+\author{ Thomas W. Yee }
+\note{
+ Convergence problems might occur with \code{rcard}.
+
+}
+
+\seealso{
+ \code{\link{cardioid}}.
+
+}
+\examples{
+\dontrun{
+mu = 4; rho = 0.4
+x = seq(0, 2*pi, len=501)
+plot(x, dcard(x, mu, rho), type="l", las=1, ylim=c(0,1), col="blue",
+ ylab=paste("[dp]card(mu=", mu, ", rho=", rho, ")"),
+ main="Blue is density, red is cumulative distribution function",
+ sub="Purple lines are the 10,20,...,90 percentiles")
+lines(x, pcard(x, mu, rho), col="red")
+
+probs = seq(0.1, 0.9, by=0.1)
+Q = qcard(probs, mu, rho)
+lines(Q, dcard(Q, mu, rho), col="purple", lty=3, type="h")
+lines(Q, pcard(Q, mu, rho), col="purple", lty=3, type="h")
+abline(h=c(0,probs,1), v=c(0,2*pi), col="purple", lty=3)
+max(abs(pcard(Q, mu, rho) - probs)) # Should be 0
+}
+}
+\keyword{distribution}
diff --git a/man/cardioid.Rd b/man/cardioid.Rd
new file mode 100644
index 0000000..48ed8b2
--- /dev/null
+++ b/man/cardioid.Rd
@@ -0,0 +1,107 @@
+\name{cardioid}
+\alias{cardioid}
+%- Also NEED an '\alias' for EACH other topic documented here.
+\title{ Cardioid Distribution Family Function }
+\description{
+ Estimates the two parameters of the
+ cardioid distribution by maximum likelihood estimation.
+}
+\usage{
+cardioid(lmu="elogit", lrho="elogit",
+ emu=if(lmu=="elogit") list(min=0, max=2*pi) else list(),
+ erho=if(lmu=="elogit") list(min=-0.5, max=0.5) else list(),
+ imu=NULL, irho=0.3, nsimEIM=100, zero=NULL)
+}
+%- maybe also 'usage' for other objects documented here.
+\arguments{
+ \item{lmu, lrho}{
+ Parameter link functions applied to the \eqn{\mu}{mu}
+ and \eqn{\rho}{rho} parameters, respectively.
+ See \code{\link{Links}} for more choices.
+
+ }
+ \item{emu, erho}{
+ List. Extra argument for each of the link functions.
+ See \code{earg} in \code{\link{Links}} for general information.
+
+ }
+ \item{imu, irho}{
+ Initial values.
+ A \code{NULL} means an initial value is chosen internally.
+ See \code{\link{CommonVGAMffArguments}} for more information.
+
+ }
+ \item{nsimEIM, zero}{
+ See \code{\link{CommonVGAMffArguments}} for more information.
+
+ }
+
+}
+\details{
+ The two-parameter cardioid distribution
+ has a density that can be written as
+ \deqn{f(y;\mu,\rho) = \frac{1}{2\pi}
+ \left(1 + 2\, \rho \cos(y - \mu) \right) }{%
+ f(y;mu,rho) = (1 + 2*rho*cos(y-mu)) / (2*pi)}
+ where \eqn{0 < y < 2\pi}{0 < y < 2*pi},
+ \eqn{0 < \mu < 2\pi}{0 < mu < 2*pi}, and
+ \eqn{-0.5 < \rho < 0.5}{-0.5 < rho < 0.5} is the concentration parameter.
+ The default link functions enforce the range constraints
+ of the parameters.
+
+ For positive \eqn{\rho} the distribution is unimodal and symmetric about
+ \eqn{\mu}{mu}.
+ The mean of \eqn{Y} (which make up the fitted values) is
+ \eqn{\pi + (\rho/\pi) ((2 \pi-\mu) \sin(2 \pi-\mu) +
+ \cos(2 \pi-\mu) - \mu \sin(\mu) - \cos(\mu))}{
+ pi + (rho/pi) ((2*pi-mu)*sin(2*pi-mu) +
+ cos(2*pi-mu) - mu*sin(mu) - cos(mu))}.
+
+}
+\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{
+
+Jammalamadaka, S. R. and SenGupta, A. (2001)
+\emph{Topics in Circular Statistics},
+Singapore: World Scientific.
+
+}
+\author{ T. W. Yee }
+\note{
+ Fisher scoring using simulation is used.
+
+}
+\section{Warning }{
+ Numerically, this distribution can be difficult to fit because of a
+ log-likelihood having multiple maxima.
+ The user is therefore encouraged to try different starting values,
+ i.e., make use of \code{imu} and \code{irho}.
+
+}
+
+\seealso{
+ \code{\link{rcard}},
+ \code{\link{elogit}},
+ \code{\link{vonmises}}.
+
+ \pkg{CircStats} and \pkg{circular} currently have a lot more
+ R functions for circular data than the \pkg{VGAM} package.
+
+}
+\examples{
+y = rcard(n=1000, mu=4, rho=0.45)
+fit = vglm(y ~ 1, cardioid, trace=TRUE)
+coef(fit, matrix=TRUE)
+Coef(fit)
+c(mean(y), fitted(fit)[1,])
+summary(fit)
+}
+\keyword{models}
+\keyword{regression}
+
diff --git a/man/cauchit.Rd b/man/cauchit.Rd
index 9a31d6f..0173dc0 100644
--- a/man/cauchit.Rd
+++ b/man/cauchit.Rd
@@ -96,6 +96,7 @@ cauchit(theta, earg = list(bvalue= .Machine$double.eps),
\code{\link{probit}},
\code{\link{cloglog}},
\code{\link{loge}},
+ \code{\link{cauchy}},
\code{\link{cauchy1}}.
}
\examples{
diff --git a/man/cauchy.Rd b/man/cauchy.Rd
new file mode 100644
index 0000000..9060fd4
--- /dev/null
+++ b/man/cauchy.Rd
@@ -0,0 +1,140 @@
+\name{cauchy}
+\alias{cauchy}
+\alias{cauchy1}
+%- Also NEED an '\alias' for EACH other topic documented here.
+\title{ Cauchy Distribution Family Function }
+\description{
+ Estimates either the location parameter or both the location and scale
+ parameters of the Cauchy distribution by maximum likelihood estimation.
+
+}
+\usage{
+cauchy(llocation="identity", lscale="loge", elocation=list(),
+ escale=list(), ilocation=NULL, iscale=NULL,
+ iprobs = seq(0.2, 0.8, by=0.2),
+ method.init=1, nsimEIM=NULL, zero=2)
+cauchy1(scale.arg=1, llocation="identity",
+ elocation=list(), ilocation=NULL, method.init=1)
+}
+%- maybe also 'usage' for other objects documented here.
+\arguments{
+ \item{llocation, lscale}{
+ Parameter link functions for the location parameter \eqn{a}{a}
+ and the scale parameter \eqn{b}{b}.
+ See \code{\link{Links}} for more choices.
+
+ }
+ \item{elocation, escale}{
+ List. Extra argument for each link.
+ See \code{earg} in \code{\link{Links}} for general information.
+
+ }
+ \item{ilocation, iscale}{
+ Optional initial value for \eqn{a}{a} and \eqn{b}{b}.
+ By default, an initial value is chosen internally for each.
+
+ }
+ \item{method.init}{
+ Integer, either 1 or 2 or 3. Initial method, three algorithms are
+ implemented. Choose the another value if convergence fails, or use
+ \code{ilocation} and/or \code{iscale}.
+
+ }
+ \item{iprobs}{
+ Probabilities used to find the respective sample quantiles;
+ used to compute \code{iscale}.
+
+ }
+ \item{zero, nsimEIM}{
+ See \code{\link{CommonVGAMffArguments}} for more information.
+
+ }
+ \item{scale.arg}{
+ Known (positive) scale parameter, called \eqn{b}{b} below.
+
+ }
+}
+\details{
+ The Cauchy distribution has density function
+ \deqn{f(y;a,b) = \left\{ \pi b [1 + ((y-a)/b)^2] \right\}^{-1} }{%
+ f(y;a,b) = 1 / [pi * b * [1 + ((y-a)/b)^2]] }
+ where \eqn{y} and \eqn{a} are real and finite,
+ and \eqn{b>0}{b>0}.
+ The distribution is symmetric about \eqn{a} and has a heavy tail.
+ Its median and mode are \eqn{a} but the mean does not exist.
+ The fitted values are the estimates of \eqn{a}.
+ Fisher scoring is the default but if \code{nsimEIM} is specified then
+ Fisher scoring with simulation is used.
+
+ If the scale parameter is known (\code{cauchy1}) then there
+ may be multiple local maximum likelihood solutions for the location
+ parameter. However, if both location and scale parameters are to
+ be estimated (\code{cauchy}) then there is a unique maximum
+ likelihood solution provided \eqn{n > 2} and less than half the data
+ are located at any one point.
+
+}
+\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)
+\emph{Statistical Distributions},
+New York: Wiley-Interscience, Third edition.
+
+Barnett, V. D. (1966)
+Evaluation of the maximum-likehood estimator where the
+likelihood equation has multiple roots.
+\emph{Biometrika},
+\bold{53}, 151--165.
+
+Copas, J. B. (1975)
+On the unimodality of the likelihood for the Cauchy distribution.
+\emph{Biometrika},
+\bold{62}, 701--704.
+
+Efron, B. and Hinkley, D. V. (1978)
+Assessing the accuracy of the maximum likelihood estimator:
+Observed versus expected Fisher information.
+\emph{Biometrika},
+\bold{65}, 457--481.
+
+}
+\author{ T. W. Yee }
+\note{
+ Good initial values are needed.
+ By default these \pkg{VGAM} family functions search for a starting
+ value for \eqn{a}{a} on a grid.
+ It also pays to select a wide range
+ of initial values via the \code{ilocation} and/or \code{iscale}
+ and/or \code{method.init} arguments.
+
+}
+
+\seealso{
+ \code{\link[stats:Cauchy]{Cauchy}},
+ \code{\link{cauchit}}.
+}
+\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)
+coef(fit, matrix=TRUE)
+fitted(fit)[1:4] # 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")
+coef(fit, matrix=TRUE)
+}
+\keyword{models}
+\keyword{regression}
+
diff --git a/man/cauchy1.Rd b/man/cauchy1.Rd
deleted file mode 100644
index b9cf024..0000000
--- a/man/cauchy1.Rd
+++ /dev/null
@@ -1,97 +0,0 @@
-\name{cauchy1}
-\alias{cauchy1}
-%- Also NEED an '\alias' for EACH other topic documented here.
-\title{ Cauchy Distribution Family Function }
-\description{
- Estimates the location parameter of the Cauchy distribution by maximum
- likelihood estimation.
-
-}
-\usage{
-cauchy1(scale.arg=1, llocation="identity",
- elocation=list(), ilocation=NULL, method.init=1)
-}
-%- maybe also 'usage' for other objects documented here.
-\arguments{
- \item{scale.arg}{
- Known (positive) scale parameter, called \eqn{s}{s} below.
-
- }
- \item{llocation}{
- Parameter link function for the \eqn{a}{a} location parameter.
- See \code{\link{Links}} for more choices.
-
- }
- \item{elocation}{
- List. Extra argument for the link.
- See \code{earg} in \code{\link{Links}} for general information.
-
- }
- \item{ilocation}{
- Optional initial value for \eqn{a}{a}.
- By default, an initial value is chosen internally.
-
- }
- \item{method.init}{
- Integer, either 1 or 2 or 3. Initial method, three algorithms are
- implemented. Choose the another value if convergence fails, or use
- \code{ilocation}.
-
- }
-}
-\details{
- The Cauchy distribution has a density function
- \deqn{f(y;a,s) = \left\{ \pi s [1 + ((y-a)/s)^2] \right\}^{-1} }{%
- f(y;a,s) = 1 / [pi * s * [1 + ((y-a)/s)^2]] }
- where \eqn{y} and \eqn{a} are real and finite,
- and \eqn{s>0}{s>0}.
- The distribution is symmetric about \eqn{a} and has a heavy tail.
- Its median and mode are \eqn{a}, but the mean does not exist, therefore
- the fitted values are all \code{NA}s.
- Fisher scoring is used.
-
-}
-\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{
-
-Evans, M., Hastings, N. and Peacock, B. (2000)
-\emph{Statistical Distributions},
-New York: Wiley-Interscience, Third edition.
-
-}
-\author{ T. W. Yee }
-\note{
- Good initial values are needed. It pays to select a wide range
- of initial values via the \code{ilocation} and \code{method.init}
- arguments.
-
-}
-
-\seealso{
- \code{\link[stats:Cauchy]{Cauchy}},
- \code{\link{cauchit}}.
-}
-\examples{
-set.seed(123)
-n = 500
-x = runif(n)
-
-y = rcauchy(n, loc=1+5*x, scale=.4)
-fit = vglm(y ~ x, cauchy1(scale=0.4), trace =TRUE, crit="c")
-coef(fit, matrix=TRUE)
-
-y = rcauchy(n, loc=exp(1+0.5*x), scale=.4)
-\dontrun{hist(y)}
-fit = vglm(y ~ x, cauchy1(scale=0.4, lloc="loge"), trace=TRUE, crit="c")
-coef(fit, matrix=TRUE)
-fitted(fit)[1:4]
-summary(fit)
-}
-\keyword{models}
-\keyword{regression}
-
diff --git a/man/cenpoisson.Rd b/man/cenpoisson.Rd
new file mode 100644
index 0000000..06524eb
--- /dev/null
+++ b/man/cenpoisson.Rd
@@ -0,0 +1,147 @@
+\name{cenpoisson}
+%\alias{cenpoisson}
+\alias{cenpoisson}
+%- Also NEED an '\alias' for EACH other topic documented here.
+\title{ Censored Poisson Family Function }
+\description{
+ Family function for a censored
+ Poisson response.
+
+}
+\usage{
+cenpoisson(link = "loge", earg = list(), imu = NULL)
+}
+%- maybe also 'usage' for other objects documented here.
+\arguments{
+ \item{link}{
+ Link function applied to the mean.
+ See \code{\link{Links}} for more choices.
+
+ }
+ \item{earg}{
+ Extra argument optionally used by the link function.
+ See \code{\link{Links}} for more information.
+
+ }
+ \item{imu}{
+ Optional initial value.
+ See \code{\link{CommonVGAMffArguments}} for more information.
+
+ }
+}
+\details{
+ 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}}.
+ Only a univariate response is allowed.
+ The Newton-Raphson algorithm is used.
+
+}
+\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{
+ See \pkg{survival} for background.
+
+}
+
+\author{ Thomas W. Yee }
+
+\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}},
+ nor is \code{type="counting"}.
+
+}
+\section{Warning }{
+ As the response is discrete,
+ care is required with \code{\link{Surv}}, especially with
+ \code{"interval"} censored data because of the
+ \code{(start, end]} format.
+ See the examples below.
+ The examples have
+ \code{y < L} as left censored and
+ \code{y >= U} (formatted as \code{U+}) as right censored observations,
+ therefore
+ \code{L <= y < U} is for uncensored and/or interval censored observations.
+ Consequently the input must be tweaked to conform to the
+ \code{(start, end]} format.
+
+}
+
+\seealso{
+ \code{\link{Surv}},
+ \code{\link{poissonff}},
+ \code{\link{Links}}.
+
+}
+\examples{
+# Example 1: right censored data
+set.seed(123)
+y = rpois(n <- 100, exp(3))
+U = 20
+cy = pmin(U, y)
+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)
+coef(fit, mat=TRUE)
+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
+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)
+coef(fit, mat=TRUE)
+
+
+# Example 3: interval censored data
+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
+status = ifelse(rcensored, 0, status) # 0 means right censored
+status = ifelse(lcensored, 2, status) # 2 means left censored
+# Have to adjust Lvec and Uvec because of the (start, end] format:
+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
+
+fit = vglm(Surv(Lvec, Uvec, status, type="interval") ~ 1,
+ cenpoisson, trace=TRUE)
+coef(fit, mat=TRUE)
+table(print(fit at y)) # Another check
+
+
+# Example 4: Add in some uncensored observations
+index = (1:n)[icensored]
+index = index[1:min(4,length(index))]
+status[index] = 1 # actual or uncensored value
+Lvec[index] = y[index]
+table(i <- print(Surv(Lvec, Uvec, status, type="interval"))) # Check
+
+fit = vglm(Surv(Lvec, Uvec, status, type="interval") ~ 1,
+ cenpoisson, trace=TRUE, crit="c")
+coef(fit, mat=TRUE)
+table(print(fit at y)) # Another check
+}
+\keyword{models}
+\keyword{regression}
+
diff --git a/man/chisq.Rd b/man/chisq.Rd
index 8cb776c..427f607 100644
--- a/man/chisq.Rd
+++ b/man/chisq.Rd
@@ -26,6 +26,7 @@ chisq(link = "loge", earg=list())
The degrees of freedom is treated as a parameter to be estimated.
It is treated as real and not integer.
Being positive, a log link is used by default.
+ Fisher scoring is used.
}
\value{
diff --git a/man/constraints.Rd b/man/constraints.Rd
index b0e1e03..982d323 100644
--- a/man/constraints.Rd
+++ b/man/constraints.Rd
@@ -90,15 +90,12 @@ information.
# Fit the proportional odds model
data(pneumo)
pneumo = transform(pneumo, let=log(exposure.time))
-fit = vglm(cbind(normal, mild, severe) ~ let,
- cumulative(parallel=TRUE, reverse=TRUE), pneumo)
-fit
+(fit = vglm(cbind(normal, mild, severe) ~ let,
+ cumulative(parallel=TRUE, reverse=TRUE), pneumo))
coef(fit, matrix=TRUE)
constraints(fit) # Parallel assumption results in this
-
-
# Fit a rank-1 stereotype (RR-multinomial logit) model
data(car.all)
fit = rrvglm(Country ~ Width + Height + HP, multinomial, car.all, Rank=1)
diff --git a/man/cqo.Rd b/man/cqo.Rd
index 1bb884b..d5b90ca 100644
--- a/man/cqo.Rd
+++ b/man/cqo.Rd
@@ -31,8 +31,11 @@ cqo(formula, family, data = list(), weights = NULL, subset = NULL,
}
\item{family}{
- a function of class \code{"vglmff"} describing what statistical model
- is to be fitted.
+ a function of class \code{"vglmff"} (see \code{\link{vglmff-class}})
+ describing what statistical model is to be fitted. This is called a
+ ``\pkg{VGAM} family function''. See \code{\link{CommonVGAMffArguments}}
+ for general information about many types of arguments found in this
+ type of function.
Currently the following families are supported:
\code{\link{poissonff}},
\code{\link{binomialff}}
diff --git a/man/cumulative.Rd b/man/cumulative.Rd
index ba3b1f3..ad6cb4e 100644
--- a/man/cumulative.Rd
+++ b/man/cumulative.Rd
@@ -1,5 +1,6 @@
\name{cumulative}
\alias{cumulative}
+\alias{scumulative}
%- Also NEED an '\alias' for EACH other topic documented here.
\title{ Ordinal Regression with Cumulative Probabilities }
\description{
@@ -11,37 +12,56 @@
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,M+1}, so that
+ with ordered values \eqn{1,2,\dots,J+1}.
\eqn{M} is the number of linear/additive predictors
- \eqn{\eta_j}{eta_j}.
+ \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{M} cumulative probabilities.
+ Link function applied to the \eqn{J} cumulative probabilities.
See \code{\link{Links}} for more choices.
}
- \item{earg}{
- List. Extra argument for the link function.
+ \item{lscale}{
+ Link function applied to the \eqn{J} scaling parameters.
+ See \code{\link{Links}} for more choices.
+
+ }
+ \item{earg, escale}{
+ List. Extra argument for the respective link functions.
See \code{earg} in \code{\link{Links}} for general information.
}
\item{parallel}{
+ A logical or formula specifying which terms have
+ equal/unequal coefficients.
+
+ }
+ \item{sparallel}{
+ For the scaling parameters.
A logical, or formula specifying which terms have
equal/unequal coefficients.
+ This argument is not applied to the intercept.
+ The \code{scumulative()} function requires covariates; for
+ intercept models use \code{cumulative()}.
}
\item{reverse}{
Logical.
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 M)}{P(Y<=M)}.
+ \dots, \eqn{P(Y\leq J)}{P(Y<=J)}.
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 M+1)}{P(Y>=M+1)} will be used.
+ \eqn{P(Y\geq J+1)}{P(Y>=J+1)} will be used.
This should be set to \code{TRUE} for \code{link=}
\code{\link{golf}},
@@ -54,7 +74,7 @@ cumulative(link = "logit", earg = list(),
\item{mv}{
Logical.
Multivariate response? If \code{TRUE} then the input should be
- a matrix with values \eqn{1,2,\dots,L}, where \eqn{L} is the
+ a matrix with values \eqn{1,2,\dots,L}, where \eqn{L=J+1} is the
number of levels.
Each column of the matrix is a response, i.e., multivariate response.
A suitable matrix can be obtained from \code{Cut}.
@@ -69,6 +89,10 @@ cumulative(link = "logit", earg = list(),
\code{\link{nbolf}}.
}
+ \item{iscale}{
+ Numeric. Initial values for the scale parameters.
+
+ }
}
\details{
By default, the non-parallel cumulative logit model is fitted, i.e.,
@@ -92,6 +116,12 @@ cumulative(link = "logit", earg = list(),
Currently, reduced-rank vector generalized additive models
(RR-VGAMs) have not been implemented here.
+ The scaled version of \code{cumulative()}, called \code{scumulative()},
+ has \eqn{J} positive scaling factors.
+ They are described in pages 154 and 177 of McCullagh and Nelder (1989);
+ see their equation (5.4) in particular,
+ which they call the \emph{generalized rational model}.
+
}
\value{
An object of class \code{"vglmff"} (see \code{\link{vglmff-class}}).
@@ -110,7 +140,7 @@ Dobson, A. J. (2001)
2nd ed. Boca Raton: Chapman & Hall/CRC Press.
McCullagh, P. and Nelder, J. A. (1989)
- \emph{Generalized Linear Models}, 2nd ed. London: Chapman & Hall.
+\emph{Generalized Linear Models}, 2nd ed. London: Chapman & Hall.
Simonoff, J. S. (2003)
\emph{Analyzing Categorical Data},
@@ -139,8 +169,8 @@ contains further information and examples.
With the logit link, setting \code{parallel=TRUE} will fit a
proportional odds model. Note that the \code{TRUE} here does
not apply to the intercept term.
- In practice, the validity of the proportional odds
- assumption needs to be checked, e.g., by a likelihood ratio test.
+ In practice, the validity of the proportional odds assumption
+ needs to be checked, e.g., by a likelihood ratio test (LRT).
If acceptable on the data,
then numerical problems are less likely to occur during the fitting,
and there are less parameters. Numerical problems occur when
@@ -194,18 +224,32 @@ weights(fit, type="prior") # Number of observations
coef(fit, matrix=TRUE)
constraints(fit) # Constraint matrices
-# Check that the model is linear in let
+# Check that the model is linear in let ----------------------
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)
}
-# Check the proportional odds assumption with a likelihood ratio test
+# 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)))
+
+# A factor() version of fit ----------------------------------
+nobs = round(fit at y * c(weights(fit, type="prior")))
+sumnobs = apply(nobs, 2, sum)
+mydat = data.frame(
+ response = ordered(c(rep("normal", times=sumnobs["normal"]),
+ rep("mild", times=sumnobs["mild"]),
+ rep("severe", times=sumnobs["severe"])),
+ levels = c("normal","mild","severe")),
+ LET = c(with(pneumo, rep(let, times=nobs[,"normal"])),
+ with(pneumo, rep(let, times=nobs[,"mild"])),
+ with(pneumo, rep(let, times=nobs[,"severe"]))))
+(fit4 = vglm(response ~ LET, data=mydat,
+ cumulative(parallel=TRUE, reverse=TRUE), trace=TRUE))
}
\keyword{models}
\keyword{regression}
diff --git a/man/dexpbinomial.Rd b/man/dexpbinomial.Rd
index 05c106a..7c84dab 100644
--- a/man/dexpbinomial.Rd
+++ b/man/dexpbinomial.Rd
@@ -130,11 +130,11 @@ cmlist = list("(Intercept)"=diag(2),
"I(srainfall^3)"=rbind(1,0),
"I(sN)"=rbind(0,1),
"I(sN^2)"=rbind(0,1))
-elist = list(min=0, max=1.25)
+dlist = list(min=0, max=1.25)
fit = vglm(phat ~ I(srainfall) + I(srainfall^2) + I(srainfall^3) +
I(sN) + I(sN^2),
fam = dexpbinomial(ldisp="elogit", idisp=0.2,
- edisp=elist, zero=NULL),
+ edisp=dlist, zero=NULL),
data=toxop, weight=ssize, trace=TRUE, constraints=cmlist)
# Now look at the results
@@ -147,7 +147,7 @@ sqrt(diag(vcov(fit))) # Standard errors
# Effective sample size (not quite the last column of Table 1)
predict(fit)[1:4,]
-Dispersion = elogit(predict(fit)[,2], earg=elist, inverse=TRUE)
+Dispersion = elogit(predict(fit)[,2], earg=dlist, inverse=TRUE)
c(round(weights(fit, type="prior") * Dispersion, dig=1))
@@ -162,7 +162,7 @@ cmlist2 = list("(Intercept)"=diag(2),
"poly(sN, 2)"=rbind(0,1))
fit2 = vglm(phat ~ poly(srainfall, 3) + poly(sN, 2),
fam = dexpbinomial(ldisp="elogit", idisp=0.2,
- edisp=list(min=0, max=1.25), zero=NULL),
+ edisp=dlist, zero=NULL),
data=toxop, weight=ssize, trace=TRUE, constraints=cmlist2)
\dontrun{
par(mfrow=c(1,2))
diff --git a/man/dirichlet.Rd b/man/dirichlet.Rd
index 58b449a..53ec133 100644
--- a/man/dirichlet.Rd
+++ b/man/dirichlet.Rd
@@ -113,7 +113,7 @@ New York: Wiley-Interscience, Third edition.
}
\examples{
-y = rdiric(n=1000, shape=c(3, 1, 4))
+y = rdiric(n=1000, shape=exp(c(-1,1,0)))
fit = vglm(y ~ 1, dirichlet, trace = TRUE, crit="c")
Coef(fit)
coef(fit, matrix=TRUE)
diff --git a/man/exponential.Rd b/man/exponential.Rd
index c202d9e..dc0a026 100644
--- a/man/exponential.Rd
+++ b/man/exponential.Rd
@@ -67,7 +67,10 @@ New York: Wiley-Interscience, Third edition.
}
\seealso{
% \code{\link{cexpon}},
+ \code{\link{amlexponential}},
+ \code{\link{laplace}},
\code{\link{poissonff}},
+ \code{\link{mix2exp}},
\code{\link{freund61}}.
}
diff --git a/man/felix.Rd b/man/felix.Rd
new file mode 100644
index 0000000..bf9a09e
--- /dev/null
+++ b/man/felix.Rd
@@ -0,0 +1,73 @@
+\name{felix}
+\alias{felix}
+%- Also NEED an '\alias' for EACH other topic documented here.
+\title{Felix Distribution Family Function}
+\description{
+ Estimates the parameter of a Felix distribution
+ by maximum likelihood estimation.
+
+}
+\usage{
+felix(link = "elogit", earg = if (link == "elogit") list(min
+ = 0, max = 0.5) else list(), method.init=1)
+}
+%- maybe also 'usage' for other objects documented here.
+\arguments{
+ \item{link, earg}{
+ Link function and extra argument for the parameter.
+ See \code{\link{Links}} for more choices and for general information.
+
+ }
+ \item{method.init}{
+ See \code{\link{CommonVGAMffArguments}}.
+ Valid values are 1, 2, 3 or 4.
+
+ }
+}
+\details{
+ The Felix distribution is an important basic Lagrangian distribution.
+ The density function is
+ \deqn{f(y;a) =
+ \frac{ 1 }{((y-1)/2)!} y^{(y-3)/2} a^{(y-1)/2} \exp(-ay)
+ }{%
+ f(y;a) =
+ (1 / ((y-1)/2)!) * y^((y-3)/2) * a^((y-1)/2) * exp(-ay)}
+ where \eqn{y=1,3,5,\ldots} and
+ \eqn{0 < a < 0.5}.
+ The mean is \eqn{1/(1-2a)} (returned as the fitted values).
+ Fisher scoring is implemented.
+
+}
+\value{
+ An object of class \code{"vglmff"} (see \code{\link{vglmff-class}}).
+ The object is used by modelling functions such as \code{\link{vglm}}
+ and \code{\link{vgam}}.
+
+}
+\references{
+
+Consul, P. C. and Famoye, F. (2006)
+\emph{Lagrangian Probability Distributions},
+Boston: Birkhauser.
+
+}
+\author{ T. W. Yee }
+%\note{
+%
+%}
+
+\seealso{
+ \code{\link{dfelix}},
+ \code{\link{borel.tanner}}.
+
+}
+\examples{
+y = 2*rpois(n <- 200, 1) + 1 # Not real data!
+fit = vglm(y ~ 1, felix, trace=TRUE, crit="c")
+coef(fit, matrix=TRUE)
+Coef(fit)
+summary(fit)
+}
+\keyword{models}
+\keyword{regression}
+
diff --git a/man/felixUC.Rd b/man/felixUC.Rd
new file mode 100644
index 0000000..132b8b4
--- /dev/null
+++ b/man/felixUC.Rd
@@ -0,0 +1,61 @@
+\name{Felix}
+\alias{Felix}
+\alias{dfelix}
+%\alias{pfelix}
+%\alias{qfelix}
+%\alias{rfelix}
+\title{The Felix Distribution}
+\description{
+ Density
+% distribution function, quantile function
+% and random generation for the
+ Felix distribution.
+
+}
+\usage{
+dfelix(x, a=0.25)
+%pfelix(q, a=0.25)
+%qfelix(p, a=0.25)
+%rfelix(n, a=0.25)
+}
+\arguments{
+ \item{x}{vector of quantiles.}
+% \item{p}{vector of probabilities.}
+% \item{n}{number of observations.
+% Must be a positive integer of length 1.}
+ \item{a}{ See \code{\link{felix}}.
+ }
+}
+\value{
+ \code{dfelix} gives the density.
+% \code{pfelix} gives the distribution function,
+% \code{qfelix} gives the quantile function, and
+% \code{rfelix} generates random deviates.
+
+}
+\author{ T. W. Yee }
+\details{
+ See \code{\link{felix}}, the \pkg{VGAM} family function
+ for estimating the parameter,
+ for the formula of the probability density function and other details.
+
+}
+\section{Warning }{
+ The default value of \code{a} is subjective.
+
+}
+\seealso{
+ \code{\link{felix}}.
+
+}
+\examples{
+\dontrun{
+a = 0.25; x = 1:15
+plot(x, dfelix(x, a), type="h", las=1, col="blue",
+ ylab=paste("dfelix(a=", a, ")"),
+ main="Felix density function")
+}
+}
+\keyword{distribution}
+
+
diff --git a/man/fgm.Rd b/man/fgm.Rd
index 540ae60..c68616a 100644
--- a/man/fgm.Rd
+++ b/man/fgm.Rd
@@ -5,11 +5,12 @@
\description{
Estimate the association parameter of
Farlie-Gumbel-Morgenstern's bivariate
- distribution using maximum likelihood estimation.
+ distribution by maximum likelihood estimation.
}
\usage{
-fgm(lapar="identity", earg=list(), iapar=NULL, method.init=1)
+fgm(lapar="rhobit", earg=list(), iapar=NULL,
+ method.init=1, nsimEIM=200)
}
%- maybe also 'usage' for other objects documented here.
\arguments{
@@ -37,6 +38,10 @@ fgm(lapar="identity", earg=list(), iapar=NULL, method.init=1)
try the other value, or else specify a value for \code{ia}.
}
+ \item{nsimEIM}{
+ See \code{\link{CommonVGAMffArguments}} for more information.
+
+ }
}
\details{
The cumulative distribution function is
@@ -44,17 +49,16 @@ fgm(lapar="identity", earg=list(), iapar=NULL, method.init=1)
( 1 + \alpha (1 - y_1) (1 - y_2) ) }{%
P(Y1 <= y1, Y2 <= y2) =
y1 * y2 * ( 1 + alpha * (1 - y1) * (1 - y2) ) }
- for real \eqn{\alpha}{alpha}
- (the range is data-dependent).
+ for \eqn{-1 < \alpha < 1}{-1 < alpha < 1}.
The support of the function is the unit square.
The marginal distributions are the standard uniform distributions.
- When \eqn{\alpha = 0}{alpha=0} then the random variables are
+ When \eqn{\alpha = 0}{alpha=0} the random variables are
independent.
- A variant of Newton-Raphson is used, which only seems to work for an
- intercept model.
- It is a very good idea to set \code{trace=TRUE}.
- This \pkg{VGAM} family function is prone to numerical difficulties.
+% A variant of Newton-Raphson is used, which only seems to work for an
+% intercept model.
+% It is a very good idea to set \code{trace=TRUE}.
+% This \pkg{VGAM} family function is prone to numerical difficulties.
}
\value{
@@ -82,15 +86,15 @@ Hoboken, N.J.: Wiley-Interscience.
}
\seealso{
+ \code{\link{rfgm}},
\code{\link{frank}},
\code{\link{morgenstern}}.
+
}
\examples{
-n = 1000
-ymat = cbind(runif(n), runif(n))
-\dontrun{plot(ymat)}
+ymat = rfgm(n = 1000, alpha=rhobit(3, inverse=TRUE))
+\dontrun{plot(ymat, col="blue")}
fit = vglm(ymat ~ 1, fam=fgm, trace=TRUE)
-fit = vglm(ymat ~ 1, fam=fgm, trace=TRUE, crit="coef")
coef(fit, matrix=TRUE)
Coef(fit)
fitted(fit)[1:5,]
@@ -98,3 +102,4 @@ fitted(fit)[1:5,]
\keyword{models}
\keyword{regression}
+% for real \eqn{\alpha}{alpha} (the range is data-dependent).
diff --git a/man/fgmUC.Rd b/man/fgmUC.Rd
new file mode 100644
index 0000000..c3827d7
--- /dev/null
+++ b/man/fgmUC.Rd
@@ -0,0 +1,70 @@
+\name{Fgm}
+\alias{Fgm}
+\alias{dfgm}
+\alias{pfgm}
+\alias{rfgm}
+\title{Farlie-Gumbel-Morgenstern's Bivariate Distribution}
+\description{
+ Density, distribution function, and random
+ generation for the (one parameter) bivariate
+ Farlie-Gumbel-Morgenstern's distribution.
+
+}
+\usage{
+dfgm(x1, x2, alpha, log=FALSE)
+pfgm(q1, q2, alpha)
+rfgm(n, alpha)
+}
+\arguments{
+ \item{x1, x2, q1, q2}{vector of quantiles.}
+ \item{n}{number of observations.
+ Must be a positive integer of length 1.}
+ \item{alpha}{the association parameter.}
+ \item{log}{
+ Logical.
+ If \code{TRUE} then the logarithm is returned.
+
+ }
+}
+\value{
+ \code{dfgm} gives the density,
+ \code{pfgm} gives the distribution function, and
+ \code{rfgm} generates random deviates (a two-column matrix).
+}
+%\references{
+%
+%}
+\author{ T. W. Yee }
+\details{
+ See \code{\link{fgm}}, the \pkg{VGAM}
+ family functions for estimating the
+ parameter by maximum likelihood estimation, for the formula of the
+ cumulative distribution function and other details.
+
+}
+%\note{
+%}
+\seealso{
+ \code{\link{fgm}}.
+
+}
+\examples{
+\dontrun{
+N = 101
+x = seq(0.0, 1.0, len=N)
+alpha = 0.7
+ox = expand.grid(x, x)
+z = dfgm(ox[,1], ox[,2], alpha=alpha)
+contour(x, x, matrix(z, N, N), col="blue")
+z = pfgm(ox[,1], ox[,2], alpha=alpha)
+contour(x, x, matrix(z, N, N), col="blue")
+
+plot(r <- rfgm(n=3000, alpha=alpha), col="blue")
+par(mfrow=c(1,2))
+hist(r[,1]) # Should be uniform
+hist(r[,2]) # Should be uniform
+}
+}
+\keyword{distribution}
+
+
diff --git a/man/fitted.vlm.Rd b/man/fitted.vlm.Rd
index 2f71a05..d2eba00 100644
--- a/man/fitted.vlm.Rd
+++ b/man/fitted.vlm.Rd
@@ -23,8 +23,9 @@ fitted.vlm(object, matrix = TRUE, ...)
\details{
The ``fitted values'' usually corresponds to the mean response,
however, because the \pkg{VGAM} package fits so many models,
- this sometimes refers to quantities such as quantiles. It may
- even not exist, e.g., for a Cauchy distribution.
+ this sometimes refers to quantities such as quantiles.
+ The mean may even not exist, e.g., for a Cauchy distribution.
+
}
\value{
The fitted values as returned by the
diff --git a/man/fnormUC.Rd b/man/fnormUC.Rd
new file mode 100644
index 0000000..6d1d13c
--- /dev/null
+++ b/man/fnormUC.Rd
@@ -0,0 +1,76 @@
+\name{Fnorm}
+\alias{Fnorm}
+\alias{dfnorm}
+\alias{pfnorm}
+\alias{qfnorm}
+\alias{rfnorm}
+\title{The Folded-Normal Distribution}
+\description{
+ Density, distribution function, quantile function and random
+ generation for the (generalized) folded-normal distribution.
+
+}
+\usage{
+dfnorm(x, mean=0, sd=1, a1=1, a2=1)
+pfnorm(q, mean=0, sd=1, a1=1, a2=1)
+qfnorm(p, mean=0, sd=1, a1=1, a2=1, ...)
+rfnorm(n, mean=0, sd=1, a1=1, a2=1)
+}
+\arguments{
+ \item{x, q}{vector of quantiles.}
+ \item{p}{vector of probabilities.}
+ \item{n}{number of observations.
+ Must be a positive integer of length 1.}
+ \item{mean, sd}{ see \code{\link[stats]{rnorm}}. }
+ \item{a1, a2}{ see \code{\link{fnormal1}}. }
+ \item{\ldots}{
+ Arguments that can be passed into \code{\link[stats]{uniroot}}.
+
+ }
+}
+\value{
+ \code{dfnorm} gives the density,
+ \code{pfnorm} gives the distribution function,
+ \code{qfnorm} gives the quantile function, and
+ \code{rfnorm} generates random deviates.
+}
+\author{ T. W. Yee }
+\details{
+ See \code{\link{fnormal1}}, the \pkg{VGAM} family function
+ for estimating the parameters,
+ for the formula of the probability density function and other details.
+
+}
+\note{
+ \code{qfnorm} runs very slowly because it calls
+ \code{\link[stats]{uniroot}} for each value of the argument \code{p}.
+ The solution is consequently not exact; the \code{...} can be used
+ to obtain a more accurate solution if necessary.
+
+}
+\seealso{
+ \code{\link{fnormal1}},
+ \code{\link[stats]{uniroot}}.
+
+}
+\examples{
+\dontrun{
+m = 1.5; SD=exp(0)
+x = seq(-1, 4, len=501)
+plot(x, dfnorm(x, m=m, sd=SD), type="l", ylim=0:1, las=1,
+ ylab=paste("fnorm(m=", m, ", sd=", round(SD, dig=3), ")"), col="blue",
+ main="Blue is density, red is cumulative distribution function",
+ sub="Purple lines are the 10,20,...,90 percentiles")
+lines(x, pfnorm(x, m=m, sd=SD), col="red")
+abline(h=0)
+probs = seq(0.1, 0.9, by=0.1)
+Q = qfnorm(probs, m=m, sd=SD)
+lines(Q, dfnorm(Q, m=m, sd=SD), col="purple", lty=3, type="h")
+lines(Q, pfnorm(Q, m=m, sd=SD), col="purple", lty=3, type="h")
+abline(h=probs, col="purple", lty=3)
+max(abs(pfnorm(Q, m=m, sd=SD) - probs)) # Should be 0
+}
+}
+\keyword{distribution}
+
+
diff --git a/man/fnormal1.Rd b/man/fnormal1.Rd
new file mode 100644
index 0000000..0a492c0
--- /dev/null
+++ b/man/fnormal1.Rd
@@ -0,0 +1,126 @@
+\name{fnormal1}
+\alias{fnormal1}
+%- Also NEED an '\alias' for EACH other topic documented here.
+\title{ Folded Normal Distribution Family Function }
+\description{
+ 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)
+}
+%- 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
+ deviation parameters of the usual univariate normal distribution.
+ They are \eqn{\mu}{mu} and \eqn{\sigma}{sigma} respectively.
+ See \code{\link{Links}} for more choices.
+
+ }
+ \item{emean, esd}{
+ List. Extra argument for each of the links.
+ See \code{earg} in \code{\link{Links}} for general information.
+
+ }
+ \item{imean, isd}{
+ Optional initial values for \eqn{\mu}{mu} and \eqn{\sigma}{sigma}.
+ A \code{NULL} means a value is computed internally.
+
+ }
+ \item{a1, a2}{
+ Positive weights, called \eqn{a_1}{a1} and \eqn{a_2}{a2} below.
+ Each must be of length 1.
+
+ }
+ \item{nsimEIM, method.init, zero}{
+ See \code{\link{CommonVGAMffArguments}}.
+
+ }
+}
+\details{
+ If a random variable has an ordinary univariate normal distribution then
+ the absolute value of that random variable has an ordinary \emph{folded
+ 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)}
+ where \eqn{a_1}{a1} and \eqn{a_2}{a2} are positive weights.
+ This means that \eqn{Y = a_1 X}{Y = a1*X} for \eqn{X > 0}, and
+ \eqn{Y = a_2 X}{Y = a2*X} for \eqn{X < 0}.
+ Then \eqn{Y} is said to have a \emph{generalized folded normal distribution}.
+ 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
+ \eqn{y \ge 0}.
+ By default, \code{mean} and \code{log(sd)} are the linear/additive
+ predictors.
+ Having \code{mean=0} and \code{sd=1} results in the
+ \emph{half-normal} distribution.
+ The mean of an ordinary folded normal distribution is
+ \deqn{E(Y) = \sigma \sqrt{2/\pi} \exp(-\mu^2/(2\sigma^2)) +
+ \mu [1-2\Phi(-\mu/\sigma)] }{%
+ E(Y) = sigma*sqrt(2/pi)*exp(-mu^2/(2*sigma^2)) +
+ mu*[1-2*Phi(-mu/sigma)] }
+ and these are returned as the fitted values.
+ Here, \eqn{\Phi()}{Phi} is the cumulative distribution function of a
+ standard normal (\code{\link[stats]{pnorm}}).
+
+}
+\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{
+ Lin, P. C. (2005)
+ Application of the generalized folded-normal distribution to the process
+ capability measures.
+ \emph{International Journal of Advanced Manufacturing Technology},
+ \bold{26}, 825--830.
+
+}
+\author{ Thomas W. Yee }
+\note{
+ The response variable for this family function is the same as
+ \code{\link{normal1}} except positive values are required.
+ Reasonably good initial values are needed.
+ Fisher scoring using simulation is implemented.
+
+}
+
+\section{Warning }{
+ Under- or over-flow may occur if the data is ill-conditioned.
+ It is recommended that several different initial values be used
+ to help avoid local solutions.
+
+}
+\seealso{
+ \code{\link{rfnorm}},
+ \code{\link{normal1}},
+ \code{\link[stats]{dnorm}},
+ \code{\link{skewnormal1}}.
+}
+
+\examples{
+m = 2; SD = exp(1)
+y = rfnorm(n <- 1000, m=m, sd=SD)
+\dontrun{hist(y, prob=TRUE, main=paste("fnormal1(m=",m,", sd=",round(SD,2),")"))}
+fit = vglm(y ~ 1, fam=fnormal1, trace=TRUE)
+coef(fit, mat=TRUE)
+(Cfit = Coef(fit))
+mygrid = seq(min(y), max(y), len=200) # Add the fit to the histogram
+\dontrun{lines(mygrid, dfnorm(mygrid, Cfit[1], Cfit[2]), col="red")}
+}
+\keyword{models}
+\keyword{regression}
diff --git a/man/frank.Rd b/man/frank.Rd
index 31192a3..1072898 100644
--- a/man/frank.Rd
+++ b/man/frank.Rd
@@ -4,11 +4,11 @@
\title{ Frank's Bivariate Distribution Family Function }
\description{
Estimate the association parameter of Frank's bivariate distribution
- using maximum likelihood estimation.
+ by maximum likelihood estimation.
}
\usage{
-frank(lapar="loge", eapar=list(), iapar=2)
+frank(lapar="loge", eapar=list(), iapar=2, nsimEIM=250)
}
%- maybe also 'usage' for other objects documented here.
\arguments{
@@ -28,6 +28,10 @@ frank(lapar="loge", eapar=list(), iapar=2)
If a convergence failure occurs try assigning a different value.
}
+ \item{nsimEIM}{
+ See \code{\link{CommonVGAMffArguments}}.
+
+ }
}
\details{
The cumulative distribution function is
@@ -55,8 +59,10 @@ frank(lapar="loge", eapar=list(), iapar=2)
As \eqn{\alpha}{alpha} approaches infinity then
\eqn{H(y_1,y_2) = \max(0, y_1+y_2-1)}{H(y1,y2)=max(0,y1+y2-1)}.
- A variant of Newton-Raphson is used, which only seems to work for an
- intercept model.
+ The default is to use Fisher scoring implemented using
+ \code{\link{rfrank}}.
+ For intercept-only models an alternative is to set \code{nsimEIM=NULL}
+ so that a variant of Newton-Raphson is used.
}
\value{
@@ -86,10 +92,11 @@ Frank's family of bivariate distributions.
\seealso{
\code{\link{rfrank}},
\code{\link{fgm}}.
+
}
\examples{
ymat = rfrank(n=2000, alpha=exp(4))
-\dontrun{plot(ymat)}
+\dontrun{plot(ymat, col="blue")}
fit = vglm(ymat ~ 1, fam=frank, trace=TRUE)
coef(fit, matrix=TRUE)
Coef(fit)
diff --git a/man/frankUC.Rd b/man/frankUC.Rd
index dac9dcc..a9669e4 100644
--- a/man/frankUC.Rd
+++ b/man/frankUC.Rd
@@ -5,8 +5,8 @@
\alias{rfrank}
\title{Frank's Bivariate Distribution}
\description{
- Density, distribution function, quantile function and random
- generation for the one parameter Frank distribution.
+ Density, distribution function, and random
+ generation for the (one parameter) bivariate Frank distribution.
}
\usage{
diff --git a/man/freund61.Rd b/man/freund61.Rd
index 78f10a1..92382ed 100644
--- a/man/freund61.Rd
+++ b/man/freund61.Rd
@@ -5,7 +5,7 @@
\description{
Estimate the four parameters of the Freund (1961) bivariate extension
of the exponential distribution
- using maximum likelihood estimation.
+ by maximum likelihood estimation.
}
\usage{
diff --git a/man/gammahyp.Rd b/man/gammahyp.Rd
index b62320c..df0f7db 100644
--- a/man/gammahyp.Rd
+++ b/man/gammahyp.Rd
@@ -4,7 +4,7 @@
\title{ Gamma Hyperbola Bivariate Distribution }
\description{
Estimate the parameter of a gamma hyperbola bivariate distribution
- using maximum likelihood estimation.
+ by maximum likelihood estimation.
}
\usage{
gammahyp(ltheta="loge", itheta=NULL, expected=FALSE)
diff --git a/man/gaussianff.Rd b/man/gaussianff.Rd
index d18a74d..2d456da 100644
--- a/man/gaussianff.Rd
+++ b/man/gaussianff.Rd
@@ -111,6 +111,7 @@ gaussianff(dispersion = 0, parallel = FALSE, zero = NULL)
\seealso{
\code{\link{normal1}},
+ \code{\link{lqnorm}},
\code{vlm},
\code{\link{vglm}},
\code{\link{vgam}},
diff --git a/man/genpoisson.Rd b/man/genpoisson.Rd
index 10f4315..63fa548 100644
--- a/man/genpoisson.Rd
+++ b/man/genpoisson.Rd
@@ -6,23 +6,20 @@
Estimation of the two parameters of a generalized Poisson distribution.
}
\usage{
-genpoisson(llambda = "logit", ltheta = "loge",
- elambda=list(), etheta=list(),
- ilambda = 0.5, itheta = NULL, zero = NULL)
+genpoisson(llambda="elogit", ltheta="loge",
+ elambda=if(llambda=="elogit") list(min=-1,max=1) else list(),
+ etheta=list(), ilambda=NULL, itheta=NULL,
+ use.approx=TRUE, method.init=1, zero=1)
}
%- maybe also 'usage' for other objects documented here.
\arguments{
- \item{llambda}{
- Parameter link function for \code{lambda}.
+ \item{llambda, ltheta}{
+ Parameter link functions for \eqn{\lambda} and \eqn{\theta}.
See \code{\link{Links}} for more choices.
- The parameter lies in the unit interval, therefore the
- logit link is a reasonable default.
-
- }
- \item{ltheta}{
- Parameter link function for \code{theta}.
- See \code{\link{Links}} for more choices.
- The parameter is positive, therefore the default is the log link.
+ The \eqn{\lambda} parameter lies at least within the interval
+ \eqn{[-1,1]}; see below for more details.
+ The \eqn{\theta} parameter is positive, therefore the default is the
+ log link.
}
\item{elambda, etheta}{
@@ -30,49 +27,94 @@ genpoisson(llambda = "logit", ltheta = "loge",
See \code{earg} in \code{\link{Links}} for general information.
}
- \item{ilambda}{ Optional initial value for \code{lambda}. }
- \item{itheta}{ Optional initial value for \code{theta}. }
- \item{zero}{ An integer vector, containing the value 1 or 2. If so,
- \code{lambda} or \code{theta} respectively are modelled as an intercept only.
- The default value \code{NULL} means both linear/additive predictors
- are modelled as functions of the explanatory variables.
-}
+ \item{ilambda, itheta}{
+ Optional initial values for \eqn{\lambda} and \eqn{\theta}.
+ The default is to choose values internally.
+
+ }
+ \item{use.approx}{
+ Logical. If \code{TRUE} then an approximation to the expected
+ information matrix is used, otherwise Newton-Raphson is used.
+
+ }
+ \item{method.init}{
+ An integer with value \code{1} or \code{2} which
+ specifies the initialization method for the parameters.
+ If failure to converge occurs try another value
+ and/or else specify a value for \code{ilambda} and/or \code{itheta}.
+
+ }
+ \item{zero}{
+ An integer vector, containing the value 1 or 2.
+ If so, \eqn{\lambda} or \eqn{\theta} respectively
+ are modelled as an intercept only.
+ If set to \code{NULL} then both linear/additive predictors are modelled
+ as functions of the explanatory variables.
+
+ }
}
\details{
- See Consul (1989) for details.
+The generalized Poisson distribution has density
+ \deqn{f(y) = \theta(\theta+\lambda y)^{y-1} \exp(-\theta-\lambda y) / y!}
+
+%{% f(y) = theta*(theta+lambda*y)^(y-1) exp(-theta-lambda*y) / y!}
+for \eqn{\theta > 0} and \eqn{y = 0,1,2,\ldots}.
+Now \eqn{\max(-1,-\theta/m) \leq \lambda \leq 1}{\max(-1,-\theta/m) \le \lambda \le 1}
+where \eqn{m (\geq 4)}{m (\ge 4)} is the greatest positive
+integer satisfying \eqn{\theta + m\lambda > 0}
+when \eqn{\lambda < 0}
+[and then \eqn{P(Y=y)=0} for \eqn{y > m}].
+Note the complicated support for this distribution means,
+for some data sets,
+the default link for \code{llambda} is not always appropriate.
+
+An ordinary Poisson distribution corresponds to \eqn{\lambda=0}{lambda=0}.
+The mean (returned as the fitted values) is
+\eqn{E(Y) = \theta / (1 - \lambda)}
+and the variance is \eqn{\theta / (1 - \lambda)^3}.
+
+ For more information see Consul and Famoye (2006) for a summary and
+ Consul (1989) for full details.
+
}
\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{
+Consul, P. C. and Famoye, F. (2006)
+\emph{Lagrangian Probability Distributions},
+Boston: Birkhauser.
+
Jorgensen, B. (1997)
\emph{The Theory of Dispersion Models}.
London: Chapman & Hall
Consul, P. C. (1989)
-\emph{Generalized Poisson Distributions: Properties and Applications},
-Marcel Dekker.
+\emph{Generalized Poisson Distributions: Properties and Applications}.
+New York: Marcel Dekker.
}
\author{ T. W. Yee }
\note{
- Convergence problems may occur when \code{lambda} is very close to 0.
This distribution is useful for dispersion modelling.
+ Convergence problems may occur when \code{lambda} is very close to 0
+ or 1.
+
}
\seealso{
\code{\link{poissonff}}.
-}
+}
\examples{
-y = rpois(n=100, lam=24)
-fit = vglm(y ~ 1, genpoisson, trace=TRUE)
-fitted(fit)[1:5]
-mean(y)
-summary(fit)
+n = 200
+x = runif(n)
+y = rpois(n, lam=exp(2-x))
+fit = vglm(y ~ x, genpoisson(zero=1), trace=TRUE)
coef(fit, matrix=TRUE)
-Coef(fit)
+summary(fit)
}
\keyword{models}
\keyword{regression}
diff --git a/man/golf.Rd b/man/golf.Rd
index ceb08d2..c23242c 100644
--- a/man/golf.Rd
+++ b/man/golf.Rd
@@ -69,13 +69,13 @@ golf(theta, earg = list(lambda = 1), inverse = FALSE, deriv = 0,
}
\value{
- See Yee (2006) for details.
+ See Yee (2007) for details.
}
\references{
- Yee, T. W. (2006)
+ Yee, T. W. (2007)
\emph{Ordinal ordination with normalizing link functions for count data},
- (submitted for publication).
+ (in preparation).
}
\author{ Thomas W. Yee }
diff --git a/man/gumbelIbiv.Rd b/man/gumbelIbiv.Rd
index c242d06..c0be1fe 100644
--- a/man/gumbelIbiv.Rd
+++ b/man/gumbelIbiv.Rd
@@ -4,7 +4,7 @@
\title{ Gumbel's Type I Bivariate Distribution Family Function }
\description{
Estimate the association parameter of Gumbel's Type I bivariate
- distribution using maximum likelihood estimation.
+ distribution by maximum likelihood estimation.
}
\usage{
diff --git a/man/hunua.Rd b/man/hunua.Rd
index d6b2a56..b907257 100644
--- a/man/hunua.Rd
+++ b/man/hunua.Rd
@@ -1,14 +1,14 @@
\name{hunua}
\alias{hunua}
-\non_function{}
+\docType{data}
\title{Hunua Ranges Data}
-\usage{data(hunua)}
\description{
The \code{hunua} data frame has 392 rows and 18 columns.
Altitude is explanatory, and there are binary responses
(presence/absence = 1/0 respectively) for 17 plant species.
}
+\usage{data(hunua)}
\format{
This data frame contains the following columns:
\describe{
diff --git a/man/hzeta.Rd b/man/hzeta.Rd
index c0ed513..61dfc16 100644
--- a/man/hzeta.Rd
+++ b/man/hzeta.Rd
@@ -6,7 +6,7 @@
Estimating the parameter of Haight's Zeta function.
}
\usage{
-hzeta(link = "loglog", earg=list(), init.alpha = NULL)
+hzeta(link = "loglog", earg=list(), ialpha = NULL, nsimEIM=100)
}
%- maybe also 'usage' for other objects documented here.
\arguments{
@@ -22,12 +22,16 @@ hzeta(link = "loglog", earg=list(), init.alpha = NULL)
See \code{earg} in \code{\link{Links}} for general information.
}
- \item{init.alpha}{
+ \item{ialpha}{
Optional initial value for the (positive) parameter.
The default is to obtain an initial value internally. Use this argument
if the default fails.
}
+ \item{nsimEIM}{
+ See \code{\link{CommonVGAMffArguments}} for more information.
+
+ }
}
\details{
The probability function is
@@ -53,12 +57,11 @@ hzeta(link = "loglog", earg=list(), init.alpha = NULL)
}
\references{
- Page 470 of
- Johnson N. L., Kotz S. and Kemp, A. W. (1993)
+ Page 533 of
+ Johnson N. L., Kemp, A. W. and Kotz S. (2005)
\emph{Univariate Discrete Distributions},
- 2nd edition,
- Volume 2,
- New York: Wiley.
+ 3rd edition,
+ Hoboken, New Jersey: Wiley.
}
\author{ T. W. Yee }
@@ -72,12 +75,13 @@ hzeta(link = "loglog", earg=list(), init.alpha = NULL)
\code{\link{loglog}}.
}
\examples{
-alpha = exp(exp(0.5)) # The parameter
+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)
Coef(fit) # Useful for intercept-only models; should be same as alpha
-fitted(fit)[1:4,]
+c(mean(y), fitted(fit)[1,])
+summary(fit)
}
\keyword{models}
\keyword{regression}
diff --git a/man/hzetaUC.Rd b/man/hzetaUC.Rd
index 1773d33..7de1172 100644
--- a/man/hzetaUC.Rd
+++ b/man/hzetaUC.Rd
@@ -47,12 +47,11 @@ rhzeta(n, alpha)
}
\references{
-Page 470 of
-Johnson N. L., Kotz S. and Kemp, A. W. (1993)
-\emph{Univariate Discrete Distributions},
-2nd edition,
-Volume 2,
-New York: Wiley.
+ Page 533 of
+ Johnson N. L., Kemp, A. W. and Kotz S. (2005)
+ \emph{Univariate Discrete Distributions},
+ 3rd edition,
+ Hoboken, New Jersey: Wiley.
}
\author{ T. W. Yee }
@@ -67,18 +66,18 @@ New York: Wiley.
\code{\link{zetaff}}.
}
\examples{
-dhzeta(1:20, 0.5)
-rhzeta(20, 0.5)
+dhzeta(1:20, 2.1)
+rhzeta(20, 2.1)
round(1000 * dhzeta(1:8, 2))
table(rhzeta(1000, 2))
\dontrun{
-alpha = 0.5; x = 1:10
-plot(x, dhzeta(x, alpha=alpha), type="h", ylim=0:1,
- sub="alpha=0.5", las=1, col="blue", ylab="Probability",
+alpha = 1.1; x = 1:10
+plot(x, dhzeta(x, alpha=alpha), type="h", ylim=0:1, lwd=2,
+ sub=paste("alpha =", alpha), las=1, col="blue", ylab="Probability",
main="Haight's zeta: blue=density; red=distribution function")
-lines(x+0.1, phzeta(x, alpha=alpha), col="red", lty=3, type="h")
+lines(x+0.1, phzeta(x, alpha=alpha), col="red", lty=3, lwd=2, type="h")
}
}
\keyword{distribution}
diff --git a/man/invbinomial.Rd b/man/invbinomial.Rd
new file mode 100644
index 0000000..030979f
--- /dev/null
+++ b/man/invbinomial.Rd
@@ -0,0 +1,115 @@
+\name{invbinomial}
+\alias{invbinomial}
+%- Also NEED an '\alias' for EACH other topic documented here.
+\title{Inverse Binomial Distribution Family Function}
+\description{
+ Estimates the two parameters of an inverse binomial distribution
+ by maximum likelihood estimation.
+
+}
+\usage{
+invbinomial(lrho="elogit", llambda="loge",
+ erho=if(lrho=="elogit") list(min = 0.5, max = 1) else list(),
+ elambda=list(), irho=NULL, ilambda=NULL, zero=NULL)
+}
+%- maybe also 'usage' for other objects documented here.
+\arguments{
+ \item{lrho, llambda}{
+ Link function for the \eqn{\rho}{rho} and \eqn{\lambda}{lambda} parameters.
+ See \code{\link{Links}} for more choices.
+
+ }
+ \item{erho, elambda}{
+ List. Extra argument for each of the links.
+ See \code{earg} in \code{\link{Links}} for general information.
+
+ }
+ \item{irho, ilambda}{
+ Numeric.
+ Optional initial values for \eqn{\rho}{rho} and \eqn{\lambda}{lambda}.
+
+ }
+ \item{zero}{
+ See \code{\link{CommonVGAMffArguments}}.
+
+ }
+}
+\details{
+ The inverse binomial distribution of Yanagimoto (1989) has density function
+ \deqn{f(y;\rho,\lambda) =
+ \frac{ \lambda \,\Gamma(2y+\lambda) }{\Gamma(y+1) \, \Gamma(y+\lambda+1) }
+ \{ \rho(1-\rho) \}^y \rho^{\lambda}}{%
+ f(y;rho,lambda) =
+ (lambda * Gamma(2y+lambda)) * [rho*(1-rho)]^y *
+ rho^lambda / (Gamma(y+1) * Gamma(y+lambda+1))}
+ where \eqn{y=0,1,2,\ldots}{y=0,1,2,...} and
+ \eqn{\frac12 < \rho < 1}{0.5 < rho < 1},
+ and \eqn{\lambda > 0}{lambda > 0}.
+ The first two moments exist for \eqn{\rho>\frac12}{rho>0.5};
+ then the mean is \eqn{\lambda (1-\rho) /(2 \rho-1)}{lambda*(1-rho)/(2*rho-1)}
+ (returned as the fitted values) and the
+ variance is
+ \eqn{\lambda \rho (1-\rho) /(2 \rho-1)^3}{lambda*rho*(1-rho)/(2*rho-1)^3}.
+ The inverse binomial distribution is a special
+ case of the generalized negative binomial distribution of
+ Jain and Consul (1971).
+ It holds that \eqn{Var(Y) > E(Y)} so that the inverse binomial distribution
+ is overdispersed compared with the Poisson distribution.
+
+}
+\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{
+ Yanagimoto, T. (1989)
+ The inverse binomial distribution as a statistical model.
+ \emph{Communications in Statistics: Theory and Methods},
+ \bold{18}, 3625--3633.
+
+ Jain, G. C. and Consul, P. C. (1971)
+ A generalized negative binomial distribution.
+ \emph{SIAM Journal on Applied Mathematics},
+ \bold{21}, 501--513.
+
+ Jorgensen, B. (1997)
+ \emph{The Theory of Dispersion Models}.
+ London: Chapman & Hall
+
+}
+\author{ T. W. Yee }
+\note{
+This \pkg{VGAM} family function only works reasonably well with
+intercept-only models.
+Good initial values are needed; if convergence failure occurs use
+\code{irho} and/or \code{ilambda}.
+
+Some elements of the working weight matrices use the expected
+information matrix while other elements use the observed
+information matrix.
+Yet to do: using the mean and the reciprocal of \eqn{\lambda}{lambda}
+results in a EIM that is diagonal.
+
+}
+
+\seealso{
+ \code{\link{negbinomial}},
+ \code{\link{poissonff}}.
+
+}
+\examples{
+y <- rnbinom(n <- 1000, mu=exp(3), size=exp(1))
+fit <- vglm(y ~ 1, invbinomial, trace=TRUE)
+c(mean(y), fitted(fit)[1:5])
+summary(fit)
+coef(fit, matrix=TRUE)
+Coef(fit)
+sum(weights(fit)) # sum of the prior weights
+sum(weights(fit, type="w")) # sum of the working weights
+}
+\keyword{models}
+\keyword{regression}
+
+%fit = vglm(y ~ 1, invbinomial(ilambda=1), tr=TRUE, cri="c", checkwz=FALSE)
diff --git a/man/kumar.Rd b/man/kumar.Rd
new file mode 100644
index 0000000..4371579
--- /dev/null
+++ b/man/kumar.Rd
@@ -0,0 +1,86 @@
+\name{kumar}
+\alias{kumar}
+%- Also NEED an '\alias' for EACH other topic documented here.
+\title{Kumaraswamy Distribution Family Function}
+\description{
+ Estimates the two parameters of the Kumaraswamy distribution
+ by maximum likelihood estimation.
+
+}
+\usage{
+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{
+ \item{lshape1, lshape2}{
+ Link function for the two positive shape parameters.
+ See \code{\link{Links}} for more choices.
+
+ }
+ \item{eshape1, eshape2}{
+ List. Extra argument for each of the links.
+ See \code{earg} in \code{\link{Links}} for general information.
+
+ }
+ \item{ishape1, ishape2}{
+ Numeric.
+ Optional initial values for the two positive shape parameters.
+
+ }
+ \item{nsimEIM, zero}{
+ See \code{\link{CommonVGAMffArguments}}.
+
+ }
+}
+\details{
+ The Kumaraswamy distribution has density function
+ \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,
+ \eqn{a} and \eqn{b}, are positive.
+ The mean is \eqn{b Beta(1+1/a,b)}
+ (returned as the fitted values) and the variance is
+ \eqn{b Beta(1+2/a,b) - (b Beta(1+1/a,b))^2}.
+ Applications of the Kumaraswamy distribution include the storage
+ volume of a water reservoir.
+
+}
+\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{
+ Kumaraswamy, P. (1980).
+ A generalized probability density function
+ for double-bounded random processes.
+ \emph{Journal of Hydrology},
+ \bold{46}, 79--88.
+
+}
+\author{ T. W. Yee }
+%\note{
+%
+%}
+
+\seealso{
+ \code{\link{dkumar}},
+ \code{\link{betaff}}.
+
+}
+\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)
+Coef(fit)
+summary(fit)
+}
+\keyword{models}
+\keyword{regression}
+
diff --git a/man/kumarUC.Rd b/man/kumarUC.Rd
new file mode 100644
index 0000000..46211f5
--- /dev/null
+++ b/man/kumarUC.Rd
@@ -0,0 +1,68 @@
+\name{Kumar}
+\alias{Kumar}
+\alias{dkumar}
+\alias{pkumar}
+\alias{qkumar}
+\alias{rkumar}
+\title{The Kumaraswamy Distribution}
+\description{
+ Density, distribution function, quantile function and random
+ generation for the Kumaraswamy distribution.
+
+}
+\usage{
+dkumar(x, shape1, shape2)
+pkumar(q, shape1, shape2)
+qkumar(p, shape1, shape2)
+rkumar(n, shape1, shape2)
+}
+\arguments{
+ \item{x, q}{vector of quantiles.}
+ \item{p}{vector of probabilities.}
+ \item{n}{number of observations.
+ Must be a positive integer of length 1.}
+ \item{shape1, shape2}{ positive shape parameters. }
+}
+\value{
+ \code{dkumar} gives the density,
+ \code{pkumar} gives the distribution function,
+ \code{qkumar} gives the quantile function, and
+ \code{rkumar} generates random deviates.
+}
+\author{ T. W. Yee }
+\details{
+ See \code{\link{kumar}}, the \pkg{VGAM} family function
+ for estimating the parameters,
+ for the formula of the probability density function and other details.
+
+}
+%\note{
+%}
+\seealso{
+ \code{\link{kumar}}.
+
+}
+\examples{
+\dontrun{
+# shape1 = shape2 = 0.5;
+shape1 = 2; shape2 = 2;
+nn = 201
+x = seq(0.01, 0.99, len=nn)
+plot(x, dkumar(x, shape1, shape2), type="l", las=1, ylim=c(0,1.5),
+ ylab=paste("fkumar(shape1=", shape1, ", shape2=", shape2, ")"),
+ col="blue",
+ main="Blue is density, red is cumulative distribution function",
+ sub="Purple lines are the 10,20,...,90 percentiles")
+lines(x, pkumar(x, shape1, shape2), col="red")
+abline(h=0)
+probs = seq(0.1, 0.9, by=0.1)
+Q = qkumar(probs, shape1, shape2)
+lines(Q, dkumar(Q, shape1, shape2), col="purple", lty=3, type="h")
+lines(Q, pkumar(Q, shape1, shape2), col="purple", lty=3, type="h")
+abline(h=probs, col="purple", lty=3)
+max(abs(pkumar(Q, shape1, shape2) - probs)) # Should be 0
+}
+}
+\keyword{distribution}
+
+
diff --git a/man/laplace.Rd b/man/laplace.Rd
index dfd02c3..f9ffcae 100644
--- a/man/laplace.Rd
+++ b/man/laplace.Rd
@@ -3,13 +3,15 @@
%- Also NEED an '\alias' for EACH other topic documented here.
\title{ Laplace Distribution }
\description{
- Maximum likelihood estimation of the 2-parameter Laplace distribution.
+ Maximum likelihood estimation of
+ the 2-parameter classical Laplace distribution.
+
}
\usage{
laplace(llocation="identity", lscale="loge",
elocation=list(), escale=list(),
ilocation=NULL, iscale=NULL,
- method.init=1, zero=NULL)
+ method.init=1, zero=2)
}
%- maybe also 'usage' for other objects documented here.
\arguments{
@@ -36,13 +38,7 @@ laplace(llocation="identity", lscale="loge",
}
\item{zero}{
- An integer-valued vector specifying which
- linear/additive predictors are modelled as intercepts only.
- The value (possibly values) must be from the
- set \{1,2\} corresponding
- respectively to \eqn{a} and \eqn{b}.
- By default all linear/additive predictors are modelled as
- a linear combination of the explanatory variables.
+ See \code{\link{CommonVGAMffArguments}} for more information.
}
}
@@ -58,6 +54,9 @@ laplace(llocation="identity", lscale="loge",
\eqn{-\infty<a<\infty}{-Inf<a<Inf} and
\eqn{b>0}.
Its mean is \eqn{a} and its variance is \eqn{2b^2}.
+ This parameterization is called the \emph{classical Laplace
+ distribution} by Kotz et al. (2001), and the density is symmetric
+ about \eqn{a}.
For \code{y ~ 1} (where \code{y} is the response) the maximum likelihood
estimate (MLE) for the location parameter is the sample median, and
@@ -95,7 +94,11 @@ Boston: Birkhauser.
}
\seealso{
- \code{\link{rlaplace}}.
+ \code{\link{rlaplace}},
+ \code{\link{alaplace2}} (which differs slightly from this parameterization),
+ \code{\link{exponential}},
+ \code{\link[stats]{median}}.
+
}
\examples{
diff --git a/man/aml.Rd b/man/leukemia.Rd
similarity index 72%
rename from man/aml.Rd
rename to man/leukemia.Rd
index 057b1e2..c59c23b 100644
--- a/man/aml.Rd
+++ b/man/leukemia.Rd
@@ -1,12 +1,13 @@
-\name{aml}
-\docType{data}
-\alias{aml}
+%\name{aml}
+\name{leukemia}
+%\alias{aml}
\alias{leukemia}
+\docType{data}
\title{Acute Myelogenous Leukemia Survival Data}
\description{Survival in patients with Acute Myelogenous Leukemia}
\usage{
-aml
-leukemia
+%data(aml)
+data(leukemia)
}
\format{
\tabular{ll}{
@@ -22,6 +23,7 @@ leukemia
ISBN: 0-471-25218-2.
}
\note{
- This data set has been transferred from \pkg{survival}.
+ This data set has been transferred from \pkg{survival} and renamed
+ from \code{aml} to \code{leukemia}.
}
\keyword{datasets}
diff --git a/man/lms.yjn.Rd b/man/lms.yjn.Rd
index dbba440..256e96c 100644
--- a/man/lms.yjn.Rd
+++ b/man/lms.yjn.Rd
@@ -1,5 +1,6 @@
\name{lms.yjn}
\alias{lms.yjn}
+\alias{lms.yjn2}
%- Also NEED an '\alias' for EACH other topic documented here.
\title{ LMS Quantile Regression with a Yeo-Johnson Transformation to Normality }
\description{
@@ -7,13 +8,16 @@
to normality.
}
\usage{
-lms.yjn(percentiles = c(25, 50, 75), zero = NULL,
- link.lambda = "identity", link.sigma = "loge",
- elambda=list(), esigma=list(),
- dfmu.init=4, dfsigma.init=2,
- init.lambda = 1, init.sigma = NULL,
- rule = c(10, 5), yoffset = NULL,
- diagW=FALSE, iters.diagW=6)
+lms.yjn(percentiles = c(25, 50, 75), zero = NULL,
+ link.lambda = "identity", link.sigma = "loge", elambda=list(),
+ esigma=list(), dfmu.init=4, dfsigma.init=2, init.lambda = 1,
+ init.sigma = NULL, rule = c(10, 5), yoffset = NULL, diagW=FALSE,
+ iters.diagW=6)
+lms.yjn2(percentiles=c(25,50,75), zero=NULL,
+ link.lambda="identity", link.mu = "identity", link.sigma="loge",
+ elambda=list(), emu = list(), esigma=list(), dfmu.init=4,
+ dfsigma.init=2, init.lambda=1.0, init.sigma=NULL, yoffset=NULL,
+ nsimEIM=250)
}
%- maybe also 'usage' for other objects documented here.
\arguments{
@@ -32,19 +36,13 @@ lms.yjn(percentiles = c(25, 50, 75), zero = NULL,
functions of the covariates.
}
- \item{link.lambda}{
- Parameter link function applied to the first linear/additive predictor.
+ \item{link.lambda, link.mu, link.sigma}{
+ Parameter link function applied to the first, second and third
+ linear/additive predictor.
See \code{\link{Links}} for more choices.
}
- \item{link.sigma}{
- Parameter link function applied to the third linear/additive predictor.
- See \code{\link{Links}} for more choices.
-
-% It is the natural log by default because sigma is positive.
-
- }
- \item{elambda, esigma}{
+ \item{elambda, emu, esigma}{
List. Extra argument for each of the links.
See \code{earg} in \code{\link{Links}} for general information.
@@ -108,19 +106,27 @@ lms.yjn(percentiles = c(25, 50, 75), zero = NULL,
Only used if \code{diagW = TRUE}.
}
+ \item{nsimEIM}{
+ See \code{\link{CommonVGAMffArguments}} for more information.
+
+ }
}
\details{
Given a value of the covariate, this function applies a Yeo-Johnson
transformation to the response to best obtain normality. The parameters
chosen to do this are estimated by maximum likelihood or penalized
maximum likelihood.
-
+ The function \code{lms.yjn2()} estimates the expected information
+ matrices using simulation (and is consequently slower) while
+ \code{lms.yjn()} uses numerical integration.
+ Try the other if one function fails.
+
}
\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}}
+ The object is used by modelling functions such as \code{\link{vglm}}
and \code{\link{vgam}}.
+
}
\references{
Yeo, I.-K. and Johnson, R. A. (2000)
@@ -181,6 +187,7 @@ The generic function \code{predict}, when applied to a
\code{\link{cdf.lmscreg}},
\code{\link{bminz}},
\code{\link{alsqreg}}.
+
}
\examples{
data(bminz)
diff --git a/man/loge.Rd b/man/loge.Rd
index 45d7fe4..ee6a969 100644
--- a/man/loge.Rd
+++ b/man/loge.Rd
@@ -79,7 +79,7 @@ nloge(theta, earg = list(), inverse = FALSE, deriv = 0,
\note{
This function is called \code{loge} to avoid conflict with the
- \code{\link[base]{log}} function.
+ \code{\link[base:Log]{log}} function.
Numerical instability may occur when \code{theta} is close to 0 unless
\code{earg} is used.
@@ -91,7 +91,7 @@ nloge(theta, earg = list(), inverse = FALSE, deriv = 0,
\code{\link{logit}},
\code{\link{logc}},
\code{\link{loglog}},
- \code{\link[base]{log}},
+ \code{\link[base:Log]{log}},
\code{\link{logoff}}.
}
\examples{
diff --git a/man/logff.Rd b/man/logff.Rd
index a0e3fe1..2ed98a3 100644
--- a/man/logff.Rd
+++ b/man/logff.Rd
@@ -46,10 +46,13 @@ logff(link = "logit", earg=list(), init.c = NULL)
}
\references{
+
Chapter 7 of
-Johnson N. L., Kotz S. and Kemp, A. W. (1993)
-\emph{Univariate Discrete Distributions},
-2nd edition, Volume 2, New York: Wiley.
+ Johnson N. L., Kemp, A. W. and Kotz S. (2005)
+ \emph{Univariate Discrete Distributions},
+ 3rd edition,
+ Hoboken, New Jersey: Wiley.
+
Evans, M., Hastings, N. and Peacock, B. (2000)
\emph{Statistical Distributions},
@@ -61,15 +64,15 @@ contains further information and examples.
}
\author{ T. W. Yee }
\note{
- The function \code{\link[base]{log}} computes the natural logarithm. In
- the \pkg{VGAM} library, a link function with option \code{\link{loge}}
- corresponds to this.
+ The function \code{\link[base:Log]{log}} computes the natural logarithm.
+ In the \pkg{VGAM} library, a link function with option
+ \code{\link{loge}} corresponds to this.
}
\seealso{
\code{\link{rlog}},
- \code{\link[base]{log}},
+ \code{\link[base:Log]{log}},
\code{\link{loge}},
\code{\link{logoff}}.
}
diff --git a/man/lqnorm.Rd b/man/lqnorm.Rd
new file mode 100644
index 0000000..407aa5f
--- /dev/null
+++ b/man/lqnorm.Rd
@@ -0,0 +1,131 @@
+\name{lqnorm}
+%\alias{lqnorm}
+\alias{lqnorm}
+%- Also NEED an '\alias' for EACH other topic documented here.
+\title{ Minimizing the L-q norm Family Function }
+\description{
+ Minimizes the L-q norm of residuals in a linear model.
+
+}
+\usage{
+lqnorm(qpower=2, link="identity", earg=list(),
+ method.init=1, imu=NULL, shrinkage.init=0.95)
+}
+%- maybe also 'usage' for other objects documented here.
+\arguments{
+ \item{qpower}{
+ A single numeric, must be greater than one, called \eqn{q} below.
+ The absolute value of residuals are raised to the power of this argument,
+ and then summed.
+ This quantity is minimized with respect to the regression coefficients.
+
+ }
+ \item{link, earg}{
+ Link function applied to the `mean' \eqn{\mu}{mu},
+ and extra argument optionally used by the link function.
+ See \code{\link{Links}} for more details.
+
+ }
+ \item{method.init}{
+ Must be 1, 2 or 3.
+ See \code{\link{CommonVGAMffArguments}} for more information.
+ Ignored if \code{imu} is specified.
+
+ }
+ \item{imu}{
+ Numeric, optional initial values used for the fitted values.
+ The default is to use \code{method.init=1}.
+
+ }
+ \item{shrinkage.init}{
+ How much shrinkage is used when initializing the fitted values.
+ The value must be between 0 and 1 inclusive, and
+ a value of 0 means the individual response values are used,
+ and a value of 1 means the median or mean is used.
+ This argument is used in conjunction with \code{method.init=3}.
+
+ }
+}
+\details{
+ This function minimizes the objective function
+ \deqn{ \sum_{i=1}^n \; w_i (|y_i - \mu_i|)^q }{%
+ sum_{i=1}^n w_i (|y_i - mu_i|)^q }
+ where \eqn{q} is the argument \code{qpower},
+ \eqn{\eta_i = g(\mu_i)}{eta_i = g(mu_i)} where \eqn{g} is
+ the link function, and
+ \eqn{\eta_i}{eta_i} is the vector of linear/additive predictors.
+ The prior weights \eqn{w_i} can be inputted using the \code{weights}
+ argument of \code{vlm}/\code{\link{vglm}}/\code{\link{vgam}} etc.;
+ it should be just a vector here since
+ this function handles only a single vector or one-column response.
+
+ Numerical problem will occur when \eqn{q} is too close to one.
+ Probably reasonable values range from 1.5 and up, say.
+ The value \eqn{q=2} corresponds to ordinary least squares while
+ \eqn{q=1} corresponds to the MLE of a double exponential (Laplace)
+ distibution. The procedure becomes more sensitive to outliers the
+ larger the value of \eqn{q}.
+
+}
+\value{
+ An object of class \code{"vglmff"} (see \code{\link{vglmff-class}}).
+ The object is used by modelling functions such as \code{\link{vglm}},
+ and \code{\link{vgam}}.
+
+}
+\references{
+ Yee, T. W. and Wild, C. J. (1996)
+ Vector generalized additive models.
+ \emph{Journal of the Royal Statistical Society, Series B, Methodological},
+ \bold{58}, 481--493.
+
+}
+\author{ Thomas W. Yee }
+
+\note{
+ This \pkg{VGAM} family function is an initial attempt to
+ provide a more robust alternative for regression and/or offer
+ a little more flexibility than least squares.
+ The \code{@misc} slot of the fitted object contains a list component
+ called \code{objectiveFunction} which is the value of the
+ objective function at the final iteration.
+
+}
+
+\section{Warning }{
+ Convergence failure is common, therefore the user is advised to be
+ cautious and monitor convergence!
+
+}
+
+\seealso{
+ \code{\link{gaussianff}}.
+
+}
+
+\examples{
+set.seed(123)
+d = data.frame(x = sort(runif(n <- 100)))
+realfun = function(x) 4 + 5*x
+d = transform(d, y = realfun(x) + rnorm(n, sd=exp(1)))
+d$y[1] = 4 * d$y[1] # Outlier
+d$x[1] = -1 # Outlier
+fit = vglm(y ~ x, fam = lqnorm(qpower=1.2), data=d)
+coef(fit, matrix=TRUE)
+fitted(fit)[1:4,]
+fit at misc$qpower
+fit at misc$objectiveFunction
+
+\dontrun{
+# Graphical check
+with(d, 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"))
+}
+}
+\keyword{models}
+\keyword{regression}
+
diff --git a/man/mbinomial.Rd b/man/mbinomial.Rd
new file mode 100644
index 0000000..3f4c0f8
--- /dev/null
+++ b/man/mbinomial.Rd
@@ -0,0 +1,167 @@
+\name{mbinomial}
+\alias{mbinomial}
+%- Also NEED an '\alias' for EACH other topic documented here.
+\title{ The Matched Binomial Distribution Family Function }
+\description{
+ Estimation of a binomial regression in a
+ matched case-control study.
+
+}
+\usage{
+mbinomial(mvar=NULL, link="logit", earg=list(),
+ parallel = TRUE, smallno = .Machine$double.eps^(3/4))
+}
+%- maybe also 'usage' for other objects documented here.
+\arguments{
+ \item{mvar}{
+ Formula specifying the matching variable.
+ This shows which observation belongs to which matching set.
+ The intercept should be suppressed from the formula, and
+ the term must be a \code{\link[base]{factor}}.
+
+ }
+ \item{link}{
+ Parameter link function applied to the probability.
+% called \eqn{p} below.
+ See \code{\link{Links}} for more choices.
+
+ }
+ \item{earg}{
+ List. Extra arguments for the links.
+ See \code{earg} in \code{\link{Links}} for general information.
+
+ }
+ \item{parallel}{
+ This should always be set \code{TRUE} otherwise there will be
+ too many parameters to estimate.
+ See \code{\link{CommonVGAMffArguments}} for more information.
+
+ }
+ \item{smallno}{
+ Numeric, a small positive value.
+ For a specific observation, used to nullify the linear/additive
+ predictors that are not needed.
+
+ }
+}
+\details{
+ By default, this \pkg{VGAM} family function fits a logistic regression
+ model to a binary response from a matched case-control study. Here,
+ each case \eqn{(Y=1}) is matched with one or more controls \eqn{(Y=0})
+ with respect to some matching variables (confounders). For example,
+ the first matched set is all women aged from 20 to 25, the second
+ matched set is women aged between 26 to 30, etc. The logistic
+ regression has a different intercept for each matched set but the other
+ regression coefficients are assumed to be the same across matched sets
+ (\code{parallel=TRUE}).
+
+ Let \eqn{C} be the number of matched sets.
+ This \pkg{VGAM} family function uses a trick by allowing \eqn{M},
+ the number of linear/additive predictors, to be equal to \eqn{C},
+ and then nullifying all but one of them for a particular observation.
+ The term specified by the \code{mvar} argument must be a
+ \code{\link[base]{factor}}.
+ Consequently, the model matrix contains an intercept plus one
+ column for each level of the factor (except the first (this is
+ the default in R)).
+ Altogether there are \eqn{C} columns.
+ The algorithm here constructs a different constraint matrix for
+ each of the \eqn{C} columns.
+
+}
+\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{
+ Section 8.2 of
+ Hastie, T. J. and Tibshirani, R. J. (1990)
+ \emph{Generalized Additive Models}, London: Chapman & Hall.
+
+ Pregibon, D. (1984)
+ Data analytic methods for matched case-control studies.
+ \emph{Biometrics},
+ \bold{40},
+ 639--651.
+
+ Chapter 7 of
+ Breslow, N. E. and Day, N. E. (1980)
+ \emph{Statistical Methods in Cancer Research I: The Analysis
+ of Case-Control Studies}.
+ Lyon: International Agency for Research on Cancer.
+
+ Holford, T. R. and White, C. and Kelsey, J. L. (1978)
+ Multivariate analysis for matched case-control studies.
+ \emph{American Journal of Epidemiology},
+ \bold{107}, 245--256.
+
+}
+
+\author{ Thomas W. Yee }
+\note{
+ The response is assumed to be in a format that can also be inputted
+ into \code{\link{binomialff}}.
+
+}
+\section{Warning }{
+ Both the memory requirements and computational time of this \pkg{VGAM}
+ family function grows very quickly with respect to the number of
+ matched sets. For example, the large model matrix of a data set with 100
+ matched sets consisting of one case and one control per set will take
+ up at least (about) 20Mb of memory. For a constant number of cases and controls
+ per matched set, the memory requirements are \eqn{O(C^3)} and the
+ the computational time is \eqn{O(C^4)} flops.
+
+ The example below has been run successfully with \code{n=700} (this
+ corresponds to \eqn{C=350}) but only on a big machine and it took over
+ 10 minutes. The large model matrix was 670Mb.
+
+}
+
+\seealso{
+ \code{\link{binomialff}}.
+
+}
+\examples{
+\dontrun{
+# cf. Hastie and Tibshirani (1990) p.209. The variable n must be even.
+n = 700 # Requires a big machine with lots of memory. Expensive wrt time
+n = 100 # This requires a reasonably big machine.
+mydat = data.frame(x2 = rnorm(n), x3 = rep(rnorm(n/2), each=2))
+xmat = with(mydat, cbind(x2,x3))
+mydat = transform(mydat, eta = -0.1 + 0.2 * x2 + 0.3 * x3)
+etamat = with(mydat, matrix(eta, n/2, 2))
+condmu = exp(etamat[,1]) / (exp(etamat[,1]) + exp(etamat[,2]))
+y1 = ifelse(runif(n/2) < condmu, 1, 0)
+y = cbind(y1, 1-y1)
+mydat = transform(mydat, y = c(y1, 1-y1),
+ ID = factor(c(row(etamat))))
+fit = vglm(y ~ 1 + ID + x2, trace=TRUE,
+ fam = mbinomial(mvar = ~ ID - 1), data=mydat)
+coef(fit, mat=TRUE)
+summary(fit)
+fitted(fit)[1:5]
+objsizemb = function(object) round(object.size(object) / 2^20, dig=2)
+objsizemb(fit) # in Mb
+
+VLMX = model.matrix(fit, type="vlm") # The big model matrix
+dim(VLMX)
+objsizemb(VLMX) # in Mb
+rm(VLMX)
+}
+}
+\keyword{models}
+\keyword{regression}
+
+% Some summary(fit) output
+%ID347 -1.6699e-01 2.01099 -8.3039e-02
+%ID348 -3.0398e-01 2.00455 -1.5165e-01
+%ID349 1.7915e-01 2.00147 8.9509e-02
+%ID350 -3.7716e-02 2.00423 -1.8818e-02
+%x2 2.5748e-01 0.10647 2.4183e+00
+%# Use the trick of Holford et al. (1978)
+
+
+
diff --git a/man/mccullagh89.Rd b/man/mccullagh89.Rd
index c5ff8a6..a8d6ed7 100644
--- a/man/mccullagh89.Rd
+++ b/man/mccullagh89.Rd
@@ -59,12 +59,10 @@ The mean is of \eqn{Y} is \eqn{\nu \theta / (1+\nu)}{nu*theta/(1+nu)},
and these are returned as the fitted values.
This distribution is related to the Leipnik distribution (see Johnson
-et al. (1995)), is related to ultraspherical functions,
-and under certain conditions, arises as exit
-distributions for Brownian motion.
-Fisher scoring is implemented here and it uses a diagonal matrix
-so the parameters are globally orthogonal in the Fisher information
-sense.
+et al. (1995)), is related to ultraspherical functions, and under
+certain conditions, arises as exit distributions for Brownian motion.
+Fisher scoring is implemented here and it uses a diagonal matrix so
+the parameters are globally orthogonal in the Fisher information sense.
McCullagh (1989) also states that, to some extent, \eqn{\theta}{theta}
and \eqn{\nu}{nu} have the properties of a location parameter and a
precision parameter, respectively.
diff --git a/man/mckaygamma2.Rd b/man/mckaygamma2.Rd
index 4d40bb4..655bdb4 100644
--- a/man/mckaygamma2.Rd
+++ b/man/mckaygamma2.Rd
@@ -4,7 +4,7 @@
\title{ McKay's Bivariate Gamma Distribution }
\description{
Estimate the two parameters of McKay's bivariate gamma distribution
- using maximum likelihood estimation.
+ by maximum likelihood estimation.
}
\usage{
mckaygamma2(la = "loge", lp = "loge", lq = "loge",
diff --git a/man/mix2poisson.Rd b/man/mix2exp.Rd
similarity index 50%
copy from man/mix2poisson.Rd
copy to man/mix2exp.Rd
index 271d219..626c9aa 100644
--- a/man/mix2poisson.Rd
+++ b/man/mix2exp.Rd
@@ -1,29 +1,31 @@
-\name{mix2poisson}
-\alias{mix2poisson}
+\name{mix2exp}
+\alias{mix2exp}
%- Also NEED an '\alias' for EACH other topic documented here.
-\title{ Mixture of Two Poisson Distributions }
+%- Adapted from mix2poisson.Rd
+\title{ Mixture of Two Exponential Distributions }
\description{
- Estimates the three parameters of a mixture of two Poisson distributions
- by maximum likelihood estimation.
+ Estimates the three parameters of a mixture of two exponential
+ distributions by maximum likelihood estimation.
}
\usage{
-mix2poisson(lphi = "logit", llambda = "loge",
- ephi=list(), el1=list(), el2=list(),
- iphi = 0.5, il1 = NULL, il2 = NULL,
- qmu = c(0.2, 0.8), zero = 1)
+mix2exp(lphi="logit", llambda="loge",
+ ephi=list(), el1=list(), el2=list(),
+ iphi=0.5, il1=NULL, il2=NULL,
+ qmu=c(0.8, 0.2), nsimEIM=100, zero=1)
}
%- maybe also 'usage' for other objects documented here.
\arguments{
\item{lphi}{
Link function for the parameter \eqn{\phi}{phi}.
- See below for more details.
See \code{\link{Links}} for more choices.
}
\item{llambda}{
- Link function applied to each \eqn{\lambda}{lambda} parameter.
+ Link function applied to each \eqn{\lambda}{lambda} (rate) parameter.
See \code{\link{Links}} for more choices.
+ Note that the mean of an ordinary exponential distribution is
+ \eqn{1 / \lambda}.
}
\item{ephi, el1, el2}{
@@ -51,6 +53,10 @@ mix2poisson(lphi = "logit", llambda = "loge",
\code{\link[stats]{quantile}}.
}
+ \item{nsimEIM}{
+ See \code{\link{CommonVGAMffArguments}}.
+
+ }
\item{zero}{
An integer specifying which linear/additive predictor is modelled as
intercepts only. If given, the value must be either 1 and/or 2 and/or
@@ -58,18 +64,19 @@ mix2poisson(lphi = "logit", llambda = "loge",
is a single parameter even when there are explanatory variables.
Set \code{zero=NULL} to model all linear/additive predictors as
functions of the explanatory variables.
+ See \code{\link{CommonVGAMffArguments}} for more information.
}
}
\details{
The probability function can be loosely written as
- \deqn{P(Y=y) = \phi \, Poisson(\lambda_1) + (1-\phi) \, Poisson(\lambda_2)}{%
- P(Y=y) = phi * Poisson(lambda1) + (1-phi) * Poisson(lambda2)}
+ \deqn{P(Y=y) = \phi\,Exponential(\lambda_1) + (1-\phi)\,Exponential(\lambda_2)}{%
+ P(Y=y) = phi * Exponential(lambda1) + (1-phi) * Exponential(lambda2)}
where \eqn{\phi}{phi} is the probability an observation belongs
- to the first group, and \eqn{y=0,1,2,\ldots}{y=0,1,2,...}.
+ to the first group, and \eqn{y>0}.
The parameter \eqn{\phi}{phi} satisfies \eqn{0 < \phi < 1}{0 < phi < 1}.
The mean of \eqn{Y} is
- \eqn{\phi \lambda_1 + (1-\phi) \lambda_2}{phi*lambda1 + (1-phi)*lambda2}
+ \eqn{\phi / \lambda_1 + (1-\phi) / \lambda_2}{phi/lambda1 + (1-phi)/lambda2}
and this is returned as the fitted values.
By default, the three linear/additive predictors are
\eqn{(logit(\phi), \log(\lambda_1), \log(\lambda_2))^T}{(logit(phi),
@@ -78,66 +85,59 @@ mix2poisson(lphi = "logit", llambda = "loge",
}
\value{
An object of class \code{"vglmff"} (see \code{\link{vglmff-class}}).
- The object is used by modelling functions such as \code{\link{vglm}},
+ The object is used by modelling functions such as \code{\link{vglm}}
and \code{\link{vgam}}.
}
% \references{ ~put references to the literature/web site here ~ }
\section{Warning }{
- Numerical problems can occur.
- Half-stepping is not uncommon.
- If failure to converge occurs, try obtaining better initial values,
- e.g., by using \code{iphi} and \code{qmu} etc.
-
- This function uses a quasi-Newton update for the working weight matrices
- (BFGS variant). It builds up approximations to the weight matrices,
- and currently the code is not fully tested.
- In particular, results based on the weight matrices (e.g., from
- \code{vcov} and \code{summary}) may be quite incorrect, especially when
- the arguments \code{weights} is used to input prior weights.
-
- This \pkg{VGAM} family function should be used with caution.
+ This \pkg{VGAM} family function requires care for a successful
+ application.
+ In particular, good initial values are required because of the presence
+ of local solutions. Therefore running this function with several
+ different combinations of arguments such as \code{iphi}, \code{il1},
+ \code{il2}, \code{qmu} is highly recommended. Graphical methods such
+ as \code{\link[graphics]{hist}} can be used as an aid.
}
\author{ T. W. Yee }
\note{
Fitting this model successfully to data can be difficult due to
- numerical problems and ill-conditioned data. It pays to fit the model
- several times with different initial values, and check that the best fit
- looks reasonable. Plotting the results is recommended. This function
- works better as \eqn{\lambda_1}{lambda1} and \eqn{\lambda_2}{lambda2}
- become more different.
-
- Convergence is often slow, especially when the two component
- distributions are not well separated. The control argument \code{maxit}
- should be set to a higher value, e.g., 200, and use \code{trace=TRUE}
- to monitor convergence.
+ local solutions, uniqueness problems and ill-conditioned data. It
+ pays to fit the model several times with different initial values
+ and check that the best fit looks reasonable. Plotting the results is
+ recommended. This function works better as \eqn{\lambda_1}{lambda1}
+ and \eqn{\lambda_2}{lambda2} become more different.
+ The default control argument \code{trace=TRUE} is to encourage
+ monitoring convergence.
}
\seealso{
- \code{\link[stats:Poisson]{rpois}},
- \code{\link{mix2normal1}}.
+ \code{\link[stats:Exponential]{rexp}},
+ \code{\link{exponential}},
+ \code{\link{mix2poisson}}.
}
\examples{
-n = 3000
-mu1 = exp(2.4) # also known as lambda1
-mu2 = exp(3.1)
-phi = 0.3
-y = ifelse(runif(n) < phi, rpois(n, mu1), rpois(n, mu2))
-
-fit = vglm(y ~ 1, mix2poisson, maxit=200) # good idea to have trace=TRUE
+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)
coef(fit, matrix=TRUE)
-Coef(fit) # the estimates
-c(phi, mu1, mu2) # the truth
+
+# Compare the results with the truth
+round(rbind('Estimated'=Coef(fit),
+ 'Truth'=c(phi, lambda1, lambda2)), dig=2)
\dontrun{# Plot the results
-ty = table(y)
-plot(names(ty), ty, type="h", main="Red=estimate, blue=truth")
-abline(v=Coef(fit)[-1], lty=2, col="red")
-abline(v=c(mu1, mu2), lty=2, col="blue")
+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)
}
}
\keyword{models}
diff --git a/man/mix2normal1.Rd b/man/mix2normal1.Rd
index 2134455..c1be543 100644
--- a/man/mix2normal1.Rd
+++ b/man/mix2normal1.Rd
@@ -11,13 +11,12 @@
mix2normal1(lphi="logit", lmu="identity", lsd="loge",
ephi=list(), emu1=list(), emu2=list(), esd1=list(), esd2=list(),
iphi=0.5, imu1=NULL, imu2=NULL, isd1=NULL, isd2=NULL,
- qmu=c(0.2, 0.8), esd=FALSE, zero=1)
+ qmu=c(0.2, 0.8), ESD=TRUE, nsimEIM=100, zero=1)
}
%- maybe also 'usage' for other objects documented here.
\arguments{
\item{lphi}{
Link function for the parameter \eqn{\phi}{phi}.
- See below for more details.
See \code{\link{Links}} for more choices.
}
@@ -34,7 +33,7 @@ mix2normal1(lphi="logit", lmu="identity", lsd="loge",
\item{ephi, emu1, emu2, esd1, esd2}{
List. Extra argument for each of the links.
See \code{earg} in \code{\link{Links}} for general information.
- If \code{esd=TRUE} then \code{esd1} is used and not \code{esd2}.
+ If \code{ESD=TRUE} then \code{esd1} must equal \code{esd2}.
}
\item{iphi}{
@@ -52,6 +51,8 @@ mix2normal1(lphi="logit", lmu="identity", lsd="loge",
Optional initial value for \eqn{\sigma_1}{sd1} and \eqn{\sigma_2}{sd2}.
The default is to compute initial values internally based on
the argument \code{qmu}.
+ Currently these are not great, therefore using these arguments
+ where practical is a good idea.
}
\item{qmu}{
@@ -62,13 +63,17 @@ mix2normal1(lphi="logit", lmu="identity", lsd="loge",
\code{\link[stats]{quantile}}.
}
- \item{esd}{
+ \item{ESD}{
Logical indicating whether the two standard deviations should be
- constrained to be equal. If set \code{TRUE}, the appropriate
+ constrained to be equal. If \code{TRUE} then the appropriate
constraint matrices will be used.
}
-\item{zero}{
+ \item{nsimEIM}{
+ See \code{\link{CommonVGAMffArguments}}.
+
+ }
+ \item{zero}{
An integer specifying which linear/additive predictor is modelled as
intercepts only. If given, the value or values must be from the
set \eqn{\{1,2,\ldots,5\}}{1,2,...,5}.
@@ -76,13 +81,14 @@ mix2normal1(lphi="logit", lmu="identity", lsd="loge",
is a single parameter even when there are explanatory variables.
Set \code{zero=NULL} to model all linear/additive predictors as
functions of the explanatory variables.
+ See \code{\link{CommonVGAMffArguments}} for more information.
}
}
\details{
The probability function can be loosely written as
- \deqn{f(y) = \phi \, N(\mu_1,\sigma_1^2) + (1-\phi) \, N(\mu_2, \sigma_2^2)}{%
- f(y) = phi * N(mu1, sd1^2) + (1-phi) * N(mu2, sd2^2)}
+ \deqn{f(y) = \phi \, N(\mu_1,\sigma_1) + (1-\phi) \, N(\mu_2, \sigma_2)}{%
+ f(y) = phi * N(mu1, sd1) + (1-phi) * N(mu2, sd2)}
where \eqn{\phi}{phi} is the probability an observation belongs
to the first group.
The parameters \eqn{\mu_1}{mu1} and \eqn{\mu_2}{mu2} are the means, and
@@ -94,7 +100,7 @@ mix2normal1(lphi="logit", lmu="identity", lsd="loge",
By default, the five linear/additive predictors are
\eqn{(logit(\phi), \mu_1, \log(\sigma_1), \mu_2, \log(\sigma_2))^T}{(logit(phi),
mu1, log(sd1), mu2, log(sd2))^T}.
- If \code{esd=TRUE} then \eqn{\sigma_1 = \sigma_2}{sd1=sd2} is enforced.
+ If \code{ESD=TRUE} then \eqn{\sigma_1 = \sigma_2}{sd1=sd2} is enforced.
}
\value{
@@ -105,25 +111,35 @@ mix2normal1(lphi="logit", lmu="identity", lsd="loge",
}
\references{
+McLachlan, G. J. and Peel, D. (2000)
+\emph{Finite Mixture Models}.
+New York: Wiley.
+
Everitt, B. S. and Hand, D. J. (1981)
\emph{Finite Mixture Distributions}.
London: Chapman & Hall.
}
\section{Warning }{
- Numerical problems can occur.
- Half-stepping is not uncommon.
- If failure to converge occurs, try obtaining better initial values,
- e.g., by using \code{iphi} and \code{qmu} etc.
-
- This function uses a quasi-Newton update for the working weight matrices
- (BFGS variant). It builds up approximations to the weight matrices,
- and currently the code is not fully tested.
- In particular, results based on the weight matrices (e.g., from
- \code{vcov} and \code{summary}) may be quite incorrect, especially when
- the arguments \code{weights} is used to input prior weights.
-
- This \pkg{VGAM} family function should be used with caution.
+ Numerical problems can occur and
+ half-stepping is not uncommon.
+ If failure to converge occurs, try inputting better initial values,
+ e.g., by using \code{iphi},
+ \code{qmu},
+ \code{imu1},
+ \code{imu2},
+ \code{isd1},
+ \code{isd2},
+ etc.
+
+% This function uses a quasi-Newton update for the working weight matrices
+% (BFGS variant). It builds up approximations to the weight matrices,
+% and currently the code is not fully tested.
+% In particular, results based on the weight matrices (e.g., from
+% \code{vcov} and \code{summary}) may be quite incorrect, especially when
+% the arguments \code{weights} is used to input prior weights.
+
+ This \pkg{VGAM} family function should be used with care.
}
@@ -131,17 +147,17 @@ London: Chapman & Hall.
\note{
Fitting this model successfully to data can be difficult due to
numerical problems and ill-conditioned data. It pays to fit the
- model several times with different initial values, and check that
+ model several times with different initial values and check that
the best fit looks reasonable. Plotting the results is recommended.
This function works better as \eqn{\mu_1}{mu1} and \eqn{\mu_2}{mu2}
become more different.
- Convergence is often slow, especially when the two component
- distributions are not well separated. The control argument \code{maxit}
- should be set to a higher value, e.g., 200, and use \code{trace=TRUE}
- to monitor convergence. If appropriate in the first place, setting
- \code{esd=TRUE} often makes the optimization problem much easier
- in general.
+ Convergence can be slow, especially when the two component
+ distributions are not well separated.
+ The default control argument \code{trace=TRUE} is to encourage
+ monitoring convergence.
+ Having \code{ESD=TRUE} often makes the overall optimization problem
+ easier.
}
@@ -149,24 +165,27 @@ London: Chapman & Hall.
\code{\link{normal1}},
\code{\link[stats:Normal]{Normal}},
\code{\link{mix2poisson}}.
+
}
\examples{
n = 1000
-mu1 = 99 # Mean IQ of geography professors
-mu2 = 150 # Mean IQ of mathematics professors
-sd1 = sd2 = 16
-phi = 0.3
+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))
-# Good idea to have trace=TRUE:
-fit = vglm(y ~ 1, mix2normal1(esd=TRUE), maxit=200)
-coef(fit, matrix=TRUE) # the estimates
-c(phi, mu1, sd1, mu2, sd2) # the truth
+fit = vglm(y ~ 1, mix2normal1(ESD=TRUE))
+
+# 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)
\dontrun{# Plot the results
xx = seq(min(y), max(y), len=200)
-plot(xx, (1-phi)*dnorm(xx, mu2, sd2), type="l", xlab="IQ",
+plot(xx, (1-phi)*dnorm(xx, mu2, sd2), type="l", xlab="y",
main="Red=estimate, blue=truth", col="blue")
phi.est = logit(coef(fit)[1], inverse=TRUE)
sd.est = exp(coef(fit)[3])
diff --git a/man/mix2poisson.Rd b/man/mix2poisson.Rd
index 271d219..473f2f3 100644
--- a/man/mix2poisson.Rd
+++ b/man/mix2poisson.Rd
@@ -11,13 +11,12 @@
mix2poisson(lphi = "logit", llambda = "loge",
ephi=list(), el1=list(), el2=list(),
iphi = 0.5, il1 = NULL, il2 = NULL,
- qmu = c(0.2, 0.8), zero = 1)
+ qmu = c(0.2, 0.8), nsimEIM=100, zero = 1)
}
%- maybe also 'usage' for other objects documented here.
\arguments{
\item{lphi}{
Link function for the parameter \eqn{\phi}{phi}.
- See below for more details.
See \code{\link{Links}} for more choices.
}
@@ -51,6 +50,10 @@ mix2poisson(lphi = "logit", llambda = "loge",
\code{\link[stats]{quantile}}.
}
+ \item{nsimEIM}{
+ See \code{\link{CommonVGAMffArguments}}.
+
+ }
\item{zero}{
An integer specifying which linear/additive predictor is modelled as
intercepts only. If given, the value must be either 1 and/or 2 and/or
@@ -58,6 +61,7 @@ mix2poisson(lphi = "logit", llambda = "loge",
is a single parameter even when there are explanatory variables.
Set \code{zero=NULL} to model all linear/additive predictors as
functions of the explanatory variables.
+ See \code{\link{CommonVGAMffArguments}} for more information.
}
}
@@ -78,67 +82,82 @@ mix2poisson(lphi = "logit", llambda = "loge",
}
\value{
An object of class \code{"vglmff"} (see \code{\link{vglmff-class}}).
- The object is used by modelling functions such as \code{\link{vglm}},
+ The object is used by modelling functions such as \code{\link{vglm}}
and \code{\link{vgam}}.
}
% \references{ ~put references to the literature/web site here ~ }
\section{Warning }{
- Numerical problems can occur.
- Half-stepping is not uncommon.
- If failure to converge occurs, try obtaining better initial values,
- e.g., by using \code{iphi} and \code{qmu} etc.
-
- This function uses a quasi-Newton update for the working weight matrices
- (BFGS variant). It builds up approximations to the weight matrices,
- and currently the code is not fully tested.
- In particular, results based on the weight matrices (e.g., from
- \code{vcov} and \code{summary}) may be quite incorrect, especially when
- the arguments \code{weights} is used to input prior weights.
-
- This \pkg{VGAM} family function should be used with caution.
+ This \pkg{VGAM} family function requires care for a successful
+ application.
+ In particular, good initial values are required because of the presence
+ of local solutions. Therefore running this function with several
+ different combinations of arguments such as \code{iphi}, \code{il1},
+ \code{il2}, \code{qmu} is highly recommended. Graphical methods such
+ as \code{\link[graphics]{hist}} can be used as an aid.
+
+ With grouped data (i.e., using the \code{weights} argument)
+ one has to use a large value of \code{nsimEIM};
+ see the example below.
}
\author{ T. W. Yee }
\note{
- Fitting this model successfully to data can be difficult due to
- numerical problems and ill-conditioned data. It pays to fit the model
- several times with different initial values, and check that the best fit
- looks reasonable. Plotting the results is recommended. This function
+ The response must be integer-valued since \code{\link[stats]{dpois}}
+ is invoked.
+
+ Fitting this model successfully to data can be difficult due to local
+ solutions and ill-conditioned data. It pays to fit the model several
+ times with different initial values, and check that the best fit
+ looks reasonable. Plotting the results is recommended. This function
works better as \eqn{\lambda_1}{lambda1} and \eqn{\lambda_2}{lambda2}
become more different.
-
- Convergence is often slow, especially when the two component
- distributions are not well separated. The control argument \code{maxit}
- should be set to a higher value, e.g., 200, and use \code{trace=TRUE}
- to monitor convergence.
+ The default control argument \code{trace=TRUE} is to encourage
+ monitoring convergence.
}
\seealso{
\code{\link[stats:Poisson]{rpois}},
+ \code{\link{poissonff}},
\code{\link{mix2normal1}}.
}
\examples{
-n = 3000
-mu1 = exp(2.4) # also known as lambda1
-mu2 = exp(3.1)
-phi = 0.3
+# Example 1: simulated data
+n = 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, maxit=200) # good idea to have trace=TRUE
+fit = vglm(y ~ 1, mix2poisson)
coef(fit, matrix=TRUE)
-Coef(fit) # the estimates
-c(phi, mu1, mu2) # the truth
+
+# 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)
plot(names(ty), ty, type="h", main="Red=estimate, blue=truth")
-abline(v=Coef(fit)[-1], lty=2, col="red")
-abline(v=c(mu1, mu2), lty=2, col="blue")
+abline(v=Coef(fit)[-1], lty=2, col="red", 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)
+
+# Usually this does not work well unless nsimEIM is large
+fit = vglm(deaths ~ 1, weight = freq,
+ 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))
+
+coef(fit, matrix=TRUE)
+Coef(fit)
}
\keyword{models}
\keyword{regression}
diff --git a/man/morgenstern.Rd b/man/morgenstern.Rd
index 0d99be4..abd3f7d 100644
--- a/man/morgenstern.Rd
+++ b/man/morgenstern.Rd
@@ -4,7 +4,7 @@
\title{ Morgenstern's Bivariate Distribution Family Function }
\description{
Estimate the association parameter of Morgenstern's bivariate
- distribution using maximum likelihood estimation.
+ distribution by maximum likelihood estimation.
}
\usage{
@@ -84,7 +84,7 @@ Hoboken, N.J.: Wiley-Interscience.
}
\author{ T. W. Yee }
\note{
- The response must be a two-column matrix. Currently, the fitted
+ The response must be a two-column matrix. Currently, the fitted
value is a matrix with two columns and values equal to 1.
This is because each marginal distribution corresponds to a
exponential distribution with unit mean.
diff --git a/man/nbolf.Rd b/man/nbolf.Rd
index 1593799..b02c375 100644
--- a/man/nbolf.Rd
+++ b/man/nbolf.Rd
@@ -65,13 +65,13 @@ nbolf(theta, earg = stop("'earg' must be given"), inverse = FALSE,
}
\value{
- See Yee (2006) for details.
+ See Yee (2007) for details.
}
\references{
- Yee, T. W. (2006)
+ Yee, T. W. (2007)
\emph{Ordinal ordination with normalizing link functions for count data},
- (submitted for publication).
+ (in preparation).
}
\author{ Thomas W. Yee }
diff --git a/man/negbinomial.Rd b/man/negbinomial.Rd
index fa3fc0b..7f9764b 100644
--- a/man/negbinomial.Rd
+++ b/man/negbinomial.Rd
@@ -200,7 +200,9 @@ Fitting the negative binomial distribution to biological data.
\code{\link{poissonff}},
\code{\link{cao}},
\code{\link{cqo}},
+ \code{\link{zinegbinomial}},
\code{\link{posnegbinomial}},
+ \code{\link{invbinomial}},
% \code{\link[MASS]{rnegbin}}.
\code{\link[stats:NegBinomial]{rnbinom}},
\code{\link{nbolf}}.
@@ -214,11 +216,10 @@ coef(fit, matrix=TRUE)
Coef(fit)
\dontrun{
-n = 500 # Example 2: simulated data
-x = runif(n)
+x = runif(n <- 500) # Example 2: simulated data with multivariate response
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, tra=TRUE) # multivariate response
+fit = vglm(cbind(y1,y2) ~ x, negbinomial, trace=TRUE)
coef(fit, matrix=TRUE)
}
}
diff --git a/man/normal1.Rd b/man/normal1.Rd
index 629f475..af7ac28 100644
--- a/man/normal1.Rd
+++ b/man/normal1.Rd
@@ -3,13 +3,12 @@
%- Also NEED an '\alias' for EACH other topic documented here.
\title{ Univariate normal distribution }
\description{
- Maximum likelihood estimation of the two parameters of a
- univariate normal distribution.
+ Maximum likelihood estimation of the two parameters of a univariate
+ normal distribution.
}
\usage{
-normal1(lmean="identity", lsd="loge",
- emean=list(), esd=list(), zero=NULL)
+normal1(lmean="identity", lsd="loge", emean=list(), esd=list(), zero=NULL)
}
%- maybe also 'usage' for other objects documented here.
\arguments{
@@ -40,9 +39,9 @@ normal1(lmean="identity", lsd="loge",
}
\details{
By default, the mean is the first linear/additive predictor and
- the log of the standard deviation is the second linear/additive
- predictor.
+ the log of the standard deviation is the second linear/additive predictor.
The Fisher information matrix is diagonal.
+
}
\value{
An object of class \code{"vglmff"} (see \code{\link{vglmff-class}}).
@@ -54,6 +53,7 @@ normal1(lmean="identity", lsd="loge",
Evans, M., Hastings, N. and Peacock, B. (2000)
\emph{Statistical Distributions},
New York: Wiley-Interscience, Third edition.
+
}
\author{ T. W. Yee }
@@ -66,10 +66,15 @@ New York: Wiley-Interscience, Third edition.
\seealso{
\code{gaussianff},
\code{\link{posnormal1}},
+ \code{\link{mix2normal1}},
\code{\link{tobit}},
\code{\link{cnormal1}},
+ \code{\link{fnormal1}},
+ \code{\link{skewnormal1}},
\code{\link{dcnormal1}},
- \code{\link{studentt}}.
+ \code{\link{studentt}},
+ \code{\link[stats]{dnorm}}.
+
}
\examples{
n = 200
diff --git a/man/notdocumentedyet.Rd b/man/notdocumentedyet.Rd
index 025b381..307712c 100644
--- a/man/notdocumentedyet.Rd
+++ b/man/notdocumentedyet.Rd
@@ -44,7 +44,7 @@
\alias{biplot}
\alias{biplot.qrrvglm}
% \alias{block.diag}
-\alias{borel.tanner}
+% \alias{borel.tanner}
\alias{bs}
% \alias{callcaof}
% \alias{callcqof}
@@ -83,6 +83,7 @@
\alias{deplot.lms.bcg}
\alias{deplot.lms.bcn}
\alias{deplot.lms.yjn}
+\alias{deplot.lms.yjn2}
\alias{deplot.vglm}
\alias{deviance}
\alias{deviance.uqo}
@@ -110,6 +111,8 @@
\alias{eta2theta}
% \alias{extract.arg}
\alias{family.vglm}
+%\alias{felix}
+%\alias{dfelix}
\alias{fff.control}
\alias{fill2}
\alias{fill3}
@@ -136,7 +139,7 @@
% \alias{hypersecant.1}
% \alias{ima}
% \alias{interleave.VGAM}
-\alias{invbinomial}
+% \alias{invbinomial}
\alias{inverse.gaussianff}
\alias{is.Numeric}
\alias{is.bell}
@@ -163,6 +166,9 @@
\alias{m2avglm}
% \alias{matrix.power}
\alias{mbesselI0}
+\alias{mix2exp.control}
+\alias{mix2normal1.control}
+\alias{mix2poisson.control}
\alias{model.matrix.qrrvglm}
% \alias{mux11}
% \alias{mux111}
@@ -247,6 +253,7 @@
\alias{qtplot.lms.bcg}
\alias{qtplot.lms.bcn}
\alias{qtplot.lms.yjn}
+\alias{qtplot.lms.yjn2}
\alias{qtplot.vextremes}
\alias{qtplot.vglm}
\alias{quasiff}
@@ -352,6 +359,8 @@
\alias{vplot.numeric}
\alias{vvplot.factor}
\alias{weights}
+\alias{Wr1}
+\alias{Wr2}
% \alias{wweighted.mean}
\alias{wweights}
% \alias{yformat}
diff --git a/man/ordpoisson.Rd b/man/ordpoisson.Rd
index 4309f4a..9dc4ede 100644
--- a/man/ordpoisson.Rd
+++ b/man/ordpoisson.Rd
@@ -92,9 +92,9 @@ ordpoisson(cutpoints, countdata=FALSE, NOS=NULL,
}
\references{
- Yee, T. W. (2006)
+ Yee, T. W. (2007)
\emph{Ordinal ordination with normalizing link functions for count data},
- (submitted for publication).
+ (in preparation).
}
\author{ Thomas W. Yee }
diff --git a/man/plackUC.Rd b/man/plackUC.Rd
new file mode 100644
index 0000000..7997c74
--- /dev/null
+++ b/man/plackUC.Rd
@@ -0,0 +1,75 @@
+\name{Plackett}
+\alias{Plackett}
+\alias{dplack}
+\alias{pplack}
+\alias{rplack}
+\title{Plackett's Bivariate Distribution}
+\description{
+ Density, distribution function, and random
+ generation for the (one parameter) bivariate Plackett distribution.
+
+}
+\usage{
+dplack(x1, x2, oratio, log=FALSE)
+pplack(q1, q2, oratio)
+rplack(n, oratio)
+}
+\arguments{
+ \item{x1, x2, q1, q2}{vector of quantiles.}
+ \item{n}{number of observations.
+ Must be a positive integer of length 1.}
+ \item{oratio}{the positive odds ratio \eqn{\psi}{psi}.}
+ \item{log}{
+ Logical.
+ If \code{TRUE} then the logarithm is returned.
+
+ }
+}
+\value{
+ \code{dplack} gives the density,
+ \code{pplack} gives the distribution function, and
+ \code{rplack} generates random deviates (a two-column matrix).
+}
+\references{
+
+Mardia, K. V. (1967)
+Some contributions to contingency-type distributions.
+\emph{Biometrika},
+\bold{54}, 235--249.
+
+}
+\author{ T. W. Yee }
+\details{
+ See \code{\link{plackett}}, the \pkg{VGAM}
+ family functions for estimating the
+ parameter by maximum likelihood estimation, for the formula of the
+ cumulative distribution function and other details.
+
+}
+%\note{
+%}
+\seealso{
+ \code{\link{plackett}},
+ \code{\link{frank}}.
+
+}
+\examples{
+\dontrun{
+N = 101
+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))
+par(mfrow=c(1,2))
+hist(r[,1]) # Should be uniform
+hist(r[,2]) # Should be uniform
+}
+}
+\keyword{distribution}
+
+
diff --git a/man/plackett.Rd b/man/plackett.Rd
new file mode 100644
index 0000000..60e85a0
--- /dev/null
+++ b/man/plackett.Rd
@@ -0,0 +1,115 @@
+\name{plackett}
+\alias{plackett}
+%- Also NEED an '\alias' for EACH other topic documented here.
+\title{ Plackett's Bivariate Distribution Family Function }
+\description{
+ Estimate the association parameter of Plackett's bivariate distribution
+ by maximum likelihood estimation.
+
+}
+\usage{
+plackett(link="loge", earg=list(), ioratio=NULL, method.init=1, nsimEIM=200)
+}
+%- maybe also 'usage' for other objects documented here.
+\arguments{
+ \item{link}{
+ Link function applied to the (positive) odds ratio
+ \eqn{\psi}{psi}.
+ See \code{\link{Links}} for more choices.
+
+ }
+ \item{earg}{
+ List. Extra argument for the link.
+ See \code{earg} in \code{\link{Links}} for general information.
+
+ }
+ \item{ioratio}{
+ Numeric. Optional initial value for \eqn{\psi}{psi}.
+ If a convergence failure occurs try assigning a value or a different value.
+
+ }
+ \item{method.init}{
+ An integer with value \code{1} or \code{2} which
+ specifies the initialization method for the parameter.
+ If failure to converge occurs try another value
+ and/or else specify a value for \code{ioratio}.
+
+ }
+ \item{nsimEIM}{
+ See \code{\link{CommonVGAMffArguments}}.
+
+ }
+}
+\details{
+ The defining equation is
+ \deqn{\psi = H \times (1-y_1-y_2+H) / ((y_1-H) \times (y_2-H))}{%
+ psi = H*(1-y1-y2+H) / ((y1-H)*(y2-H))}
+ where
+ \eqn{P(Y_1 \leq y_1, Y_2 \leq y_2) = H_{\psi}(y_1,y_2)}{P(Y1 <= y1, Y2 <= y2)=
+ H(y1,y2)}
+ is the cumulative distribution function.
+ The density function is \eqn{h_{\psi}(y_1,y_2) =}{h(y1,y2) =}
+ \deqn{\psi [1 + (\psi-1)(y_1 + y_2 - 2 y_1 y_2) ] / \left(
+ [1 + (\psi-1)(y_1 + y_2) ]^2 - 4 \psi
+ (\psi-1) y_1 y_2 \right)^{3/2}}{%
+ psi*[1 + (psi-1)*(y1 + y2 - 2*y1*y2) ] / (
+ [1 + (psi-1)*(y1 + y2)]^2 -
+ 4*psi*(psi-1)*y1*y2)^(3/2)}
+ for \eqn{\psi > 0}{psi > 0}.
+ Some writers call \eqn{\psi}{psi} the \emph{cross product ratio}
+ but it is called the \emph{odds ratio} here.
+ The support of the function is the unit square.
+ The marginal distributions here are the standard uniform although
+ it is commonly generalized to other distributions.
+
+ If \eqn{\psi = 1}{psi=1} then
+ \eqn{h_{\psi}(y_1,y_2) = y_1 y_2}{h(y1,y2) = y1*y2},
+ i.e., independence.
+ As the odds ratio tends to infinity one has \eqn{y_1=y_2}{y1=y2}.
+ As the odds ratio tends to 0 one has \eqn{y_2=1-y_1}{y2=1-y1}.
+
+ Fisher scoring is implemented using \code{\link{rplack}}.
+ Convergence is often quite slow.
+
+}
+\value{
+ An object of class \code{"vglmff"} (see \code{\link{vglmff-class}}).
+ The object is used by modelling functions such as \code{\link{vglm}}
+ and \code{\link{vgam}}.
+}
+
+\references{
+
+Plackett, R. L. (1965)
+A class of bivariate distributions.
+\emph{Journal of the American Statistical Association},
+\bold{60}, 516--522.
+
+}
+\author{ T. W. Yee }
+\note{
+ The response must be a two-column matrix. Currently, the fitted
+ value is a 2-column matrix with 0.5 values
+ because the marginal distributions correspond to a standard
+ uniform distribution.
+
+}
+
+\seealso{
+ \code{\link{rplack}},
+ \code{\link{frank}}.
+
+}
+\examples{
+ymat = rplack(n=2000, oratio=exp(2))
+\dontrun{plot(ymat, col="blue")}
+fit = vglm(ymat ~ 1, fam=plackett, trace=TRUE)
+coef(fit, matrix=TRUE)
+Coef(fit)
+vcov(fit)
+fitted(fit)[1:5,]
+summary(fit)
+}
+\keyword{models}
+\keyword{regression}
+
diff --git a/man/pneumo.Rd b/man/pneumo.Rd
index 4d25e10..6eb2f80 100644
--- a/man/pneumo.Rd
+++ b/man/pneumo.Rd
@@ -1,12 +1,13 @@
\name{pneumo}
\alias{pneumo}
-\non_function{}
+\docType{data}
\title{Pneumoconiosis amongst a group of coalminers}
-\usage{data(pneumo)}
\description{
The \code{pneumo} data frame has 8 rows and 4 columns.
Exposure time is explanatory, and there are 3 ordinal response variables.
+
}
+\usage{data(pneumo)}
\format{
This data frame contains the following columns:
\describe{
diff --git a/man/poissonff.Rd b/man/poissonff.Rd
index ff3b6c5..9208ccc 100644
--- a/man/poissonff.Rd
+++ b/man/poissonff.Rd
@@ -114,8 +114,14 @@ poissonff(link = "loge", earg=list(), dispersion = 1,
\seealso{
\code{\link{Links}},
\code{\link{quasipoissonff}},
+ \code{\link{genpoisson}},
\code{\link{zipoisson}},
+ \code{\link{skellam}},
+ \code{\link{mix2poisson}},
+ \code{\link{cenpoisson}},
\code{\link{ordpoisson}},
+ \code{\link{amlpoisson}},
+ \code{\link{invbinomial}},
\code{\link{loge}},
\code{\link{polf}},
\code{\link{rrvglm}},
diff --git a/man/polf.Rd b/man/polf.Rd
index e8d232a..dfd66a6 100644
--- a/man/polf.Rd
+++ b/man/polf.Rd
@@ -62,13 +62,13 @@ polf(theta, earg = stop("'earg' must be given"), inverse = FALSE,
}
\value{
- See Yee (2006) for details.
+ See Yee (2007) for details.
}
\references{
- Yee, T. W. (2006)
+ Yee, T. W. (2007)
\emph{Ordinal ordination with normalizing link functions for count data},
- (submitted for publication).
+ (in preparation).
}
\author{ Thomas W. Yee }
diff --git a/man/polonoUC.Rd b/man/polonoUC.Rd
index 8f03e05..1abcec1 100644
--- a/man/polonoUC.Rd
+++ b/man/polonoUC.Rd
@@ -11,21 +11,36 @@
}
\usage{
-dpolono(x, meanlog=0, sdlog=1, ...)
+dpolono(x, meanlog=0, sdlog=1, bigx=Inf, ...)
rpolono(n, meanlog=0, sdlog=1)
}
\arguments{
\item{x}{vector of quantiles.}
% \item{p}{vector of probabilities.}
\item{n}{number of observations.
- Must be a positive integer of length 1.}
+ Must be a positive integer of length 1.}
\item{meanlog, sdlog }{
- the mean and standard deviation of the normal distribution (on the
- log scale).
+ the mean and standard deviation of the normal distribution
+ (on the log scale).
They match the arguments in
\code{\link[stats:Lognormal]{Lognormal}}.
}
+ \item{bigx}{
+ Numeric.
+ This argument is for handling large values of \code{x} and/or
+ when \code{\link[stats]{integrate}} fails.
+ A first order Taylor series approximation
+ [Equation (7) of Bulmer (1974)]
+ is used at values of \code{x} that are greater or equal to this argument.
+ For \code{bigx=10},
+ he showed that the approximation has a relative error less than
+ 0.001 for values of \code{meanlog} and
+ \code{sdlog} ``likely to be encountered in practice''. The default value
+ means that this approximation is not used. Setting something like
+ \code{bigx=100} may be a good idea.
+
+ }
\item{...}{
Arguments passed into
\code{\link[stats]{integrate}}.
@@ -38,6 +53,15 @@ rpolono(n, meanlog=0, sdlog=1)
% \code{qpolono} gives the quantile function, and
\code{rpolono} generates random deviates.
}
+\references{
+ Bulmer, M. G. (1974)
+ On fitting the Poisson lognormal distribution to species-abundance data.
+ \emph{Biometrics},
+ \bold{30},
+ 101--110.
+
+}
+
\author{ T. W. Yee }
\details{
The Poisson lognormal distribution is similar to the negative
@@ -45,17 +69,21 @@ rpolono(n, meanlog=0, sdlog=1)
mean parameter comes from a right skewed distribution (gamma for the
negative binomial and lognormal for the Poisson lognormal distribution).
-
% See zz code{link{polonozz}}, the \pkg{VGAM} family function
% for estimating the parameters,
% for the formula of the probability density function and other details.
}
\note{
+ By default,
\code{dpolono} involves numerical integration that is performed using
- \code{\link[stats]{integrate}}. Consequently, computations may be very
- slow. Also, numerical problems may occur, and if so, then the use of
- \code{...} may be needed.
+ \code{\link[stats]{integrate}}. Consequently, computations are very
+ slow and numerical problems may occur
+ (if so then the use of \code{...} may be needed).
+ Alternatively, for extreme values of \code{x}, \code{meanlog},
+ \code{sdlog}, etc., the use of \code{bigx} avoids the call to
+ \code{\link[stats]{integrate}}; however the answer may be a little
+ inaccurate.
For the maximum likelihood estimation of the 2 parameters a \pkg{VGAM}
family function called \code{polono}, say, has not been written yet.
@@ -68,18 +96,29 @@ rpolono(n, meanlog=0, sdlog=1)
}
\examples{
-\dontrun{
meanlog = 0.5; sdlog = 0.5
y = 0:19
proby = dpolono(y, m=meanlog, sd=sdlog)
-plot(y, proby, type="h", col="blue", las=1, ylab="P[Y=y]", log="",
+sum(proby) # Should be 1
+\dontrun{
+opar = par(no.readonly = TRUE)
+par(mfrow=c(2,2))
+plot(y, proby, type="h", col="blue", ylab="P[Y=y]", log="",
main=paste("Poisson lognormal(meanlog=",meanlog,", sdlog=",sdlog,")",
sep=""))
+
+# More extreme values; use the approximation and plot on a log scale
+# Notice the kink at bigx.
+y = 0:190
+proby = dpolono(y, m=meanlog, sd=sdlog, bigx=100)
sum(proby) # Should be 1
+plot(y, proby, type="h", col="blue", ylab="P[Y=y]", log="y",
+ main=paste("Poisson lognormal(meanlog=",meanlog,", sdlog=",sdlog,")"))
-y = rpolono(n=1000, m=meanlog, sd=sdlog)
-table(y)
-hist(y, breaks=((-1):max(y))+0.5, prob=TRUE)
+# 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)
}
}
\keyword{distribution}
diff --git a/man/posbinomUC.Rd b/man/posbinomUC.Rd
index 2cb5513..e6a0846 100644
--- a/man/posbinomUC.Rd
+++ b/man/posbinomUC.Rd
@@ -84,12 +84,12 @@ table(qposbinom(runif(1000), size, prob))
round(dposbinom(1:10, size, prob) * 1000) # Should be similar
\dontrun{
-x = 0:size
-plot(x, dposbinom(x, size, prob), type="h", ylab="Probability",
- main=paste("Positive-binomial(", size, ",", prob, ") (blue) vs",
- " Binomial(", size, ",", prob, ") (red and shifted slightly)", sep=""),
- lwd=2, col="blue", las=1)
-lines(x+0.05, dbinom(x, size, prob), type="h", lwd=2, col="red")
+barplot(rbind(dposbinom(x, size, prob),
+ dbinom(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)
}
}
\keyword{distribution}
diff --git a/man/posnormal1.Rd b/man/posnormal1.Rd
index 0be9946..23d364d 100644
--- a/man/posnormal1.Rd
+++ b/man/posnormal1.Rd
@@ -84,6 +84,9 @@ posnormal1(lmean="identity", lsd="loge",
Reasonably good initial values are needed.
Fisher scoring is implemented.
+ The distribution of the reciprocal of a positive normal random variable
+ is known as an alpha distribution.
+
}
\section{Warning }{
diff --git a/man/pospoisUC.Rd b/man/pospoisUC.Rd
index 694c7e7..804f864 100644
--- a/man/pospoisUC.Rd
+++ b/man/pospoisUC.Rd
@@ -81,11 +81,11 @@ round(dpospois(1:10, lambda) * 1000) # Should be similar
\dontrun{
x = 0:7
-plot(x, dpospois(x, lambda), type="h", ylab="Probability",
- main=paste("Positive Poisson(", lambda, ") (blue) vs",
- " Poisson(", lambda, ") (red and shifted slightly)", sep=""),
- lwd=2, col="blue", las=1)
-lines(x+0.05, dpois(x, lambda), type="h", lwd=2, col="red")
+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)
}
}
\keyword{distribution}
diff --git a/man/pospoisson.Rd b/man/pospoisson.Rd
index 74758e3..daae29d 100644
--- a/man/pospoisson.Rd
+++ b/man/pospoisson.Rd
@@ -6,7 +6,8 @@
Fits a positive Poisson distribution.
}
\usage{
-pospoisson(link = "loge", earg=list())
+pospoisson(link = "loge", earg=list(),
+ expected=TRUE, ilambda=NULL, method.init=1)
}
%- maybe also 'usage' for other objects documented here.
\arguments{
@@ -21,6 +22,24 @@ pospoisson(link = "loge", earg=list())
See \code{earg} in \code{\link{Links}} for general information.
}
+ \item{expected}{
+ Logical.
+ Fisher scoring is used if \code{expected = TRUE}, else Newton-Raphson.
+
+ }
+ \item{ilambda}{
+ Optional initial value for \eqn{\lambda}{lambda}.
+ A \code{NULL} means a value is computed internally.
+
+ }
+ \item{method.init}{
+ An integer with value \code{1} or \code{2} which
+ specifies the initialization method for \eqn{\lambda}{lambda}.
+ If failure to converge occurs try another value
+ and/or else specify a value for \code{ilambda}.
+
+ }
+
}
\details{
The positive Poisson distribution is the ordinary Poisson
@@ -78,7 +97,7 @@ fitted(fit)
# Artificial data
x = runif(n <- 1000)
-lambda = exp(2 + 3*x)
+lambda = exp(1 - 2*x)
y = rpospois(n, lambda)
table(y)
fit = vglm(y ~ x, pospoisson, trace=TRUE, crit="c")
diff --git a/man/powl.Rd b/man/powl.Rd
index fcb07c0..52ad832 100644
--- a/man/powl.Rd
+++ b/man/powl.Rd
@@ -88,21 +88,19 @@ powl(theta, earg = list(power=1), inverse = FALSE, deriv = 0,
\examples{
powl("a", earg=list(power=2), short=FALSE, tag=TRUE)
-x = 1:5
-powl(x)
+powl(x <- 1:5)
powl(x, earg=list(power=2))
earg=list(power=2)
max(abs(powl(powl(x, earg=earg), earg=earg, inverse=TRUE) - x)) # Should be 0
-x = (-5):5
-powl(x, earg=list(power=0.5)) # Has NAs
+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)
-fit = vglm(y ~ 1, betaff(link="powl", earg=list(power=0.5), i1=3, i2=7),
- trace=TRUE, cri="coef")
-coef(fit, matrix=TRUE)
+fit = vglm(y ~ 1, beta.ab(lshape1="powl", lshape2="powl",
+ eshape1=list(power=0.5), eshape2=list(power=0.5), i1=3, i2=7))
+t(coef(fit, matrix=TRUE))
Coef(fit) # Useful for intercept-only models
vcov(fit, untrans=TRUE)
}
diff --git a/man/rayleigh.Rd b/man/rayleigh.Rd
index 1c5797d..cb08447 100644
--- a/man/rayleigh.Rd
+++ b/man/rayleigh.Rd
@@ -80,6 +80,7 @@ A related distribution is the Maxwell distribution.
}
\seealso{
\code{\link{Rayleigh}},
+ \code{\link{riceff}},
\code{\link{maxwell}}.
}
\examples{
diff --git a/man/riceUC.Rd b/man/riceUC.Rd
new file mode 100644
index 0000000..3993c48
--- /dev/null
+++ b/man/riceUC.Rd
@@ -0,0 +1,63 @@
+\name{Rice}
+\alias{Rice}
+\alias{drice}
+%\alias{price}
+%\alias{qrice}
+\alias{rrice}
+\title{The Rice Distribution}
+\description{
+ Density
+% distribution function, quantile function
+ and random generation for the
+ Rice distribution.
+
+}
+\usage{
+drice(x, vee, sigma)
+%price(q, vee, sigma)
+%qrice(p, vee, sigma)
+rrice(n, vee, sigma)
+}
+\arguments{
+ \item{x}{vector of quantiles.}
+% \item{p}{vector of probabilities.}
+ \item{n}{number of observations.
+ Must be a positive integer of length 1.}
+ \item{vee, sigma}{ See \code{\link{riceff}}.
+ }
+}
+\value{
+ \code{drice} gives the density,
+% \code{price} gives the distribution function,
+% \code{qrice} gives the quantile function, and
+ \code{rrice} generates random deviates.
+
+}
+\author{ T. W. Yee }
+\details{
+ See \code{\link{riceff}}, the \pkg{VGAM} family function
+ for estimating the two parameters,
+ for the formula of the probability density function and other details.
+
+}
+%\section{Warning }{
+%
+%}
+\seealso{
+ \code{\link{riceff}}.
+
+}
+\examples{
+\dontrun{
+x = seq(0.01, 7, len=201)
+plot(x, drice(x, vee=0, sigma=1), type="n", las=1,, ylab="",
+ main="Density of Rice distribution for various values of v")
+sigma = 1; vee = c(0,0.5,1,2,4)
+for(ii in 1:length(vee)) lines(x, drice(x, vee[ii], sigma), col=ii)
+legend(x=5, y=0.6, legend=as.character(vee),
+ col=1:length(vee), lty=1)
+}
+}
+\keyword{distribution}
+
+
diff --git a/man/riceff.Rd b/man/riceff.Rd
new file mode 100644
index 0000000..177a823
--- /dev/null
+++ b/man/riceff.Rd
@@ -0,0 +1,99 @@
+\name{riceff}
+\alias{riceff}
+%- Also NEED an '\alias' for EACH other topic documented here.
+\title{Rice Distribution Family Function}
+\description{
+ Estimates the two parameters of a Rice distribution
+ by maximum likelihood estimation.
+
+}
+\usage{
+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{
+ \item{lvee, evee}{
+ Link function and extra argument for the \eqn{v} parameter.
+ See \code{\link{Links}} for more choices and for general information.
+
+ }
+ \item{lsigma, esigma}{
+ Link function and extra argument for the \eqn{\sigma}{sigma} parameter.
+ See \code{\link{Links}} for more choices and for general information.
+
+ }
+ \item{ivee, isigma}{
+ Optional initial values for the parameters.
+ See \code{\link{CommonVGAMffArguments}} for more information.
+ If convergence failure occurs (this \pkg{VGAM} family function seems
+ to require good initial values) try using these arguments.
+
+ }
+ \item{nsimEIM, zero}{
+ See \code{\link{CommonVGAMffArguments}} for more information.
+
+ }
+}
+\details{
+ The Rice distribution has density function
+ \deqn{f(y;v,\sigma) =
+ \frac{ y }{\sigma^2} \, \exp(-(y^2+v^2) / (2\sigma^2)) \, I_0(y v / \sigma^2)
+ }{%
+ f(y;v,sigma) =
+ (y/sigma^2) * exp(-(y^2+v^2) / (2*sigma^2)) * I_0(y*v/sigma^2)}
+ where \eqn{y>0},
+ \eqn{v > 0},
+ \eqn{\sigma > 0} and \eqn{I_0} is the modified Bessel function of the
+ first kind with order zero.
+ When \eqn{v=0} the Rice distribution reduces to a Rayleigh distribution.
+ The mean is
+ \eqn{\sigma \sqrt{\pi/2} \exp(z/2) ((1-z) I_0(-z/2)-z I_1(-z/2))}{sigma*sqrt(pi/2)*exp(z/2)*((1-z)*I_0(-z/2)-z*I_1(-z/2))}
+ (returned as the fitted values) where \eqn{z=-v^2/(2 \sigma^2)}{z=-v^2/(2*sigma^2)}.
+ Simulated Fisher scoring is implemented.
+
+}
+\value{
+ An object of class \code{"vglmff"} (see \code{\link{vglmff-class}}).
+ The object is used by modelling functions such as \code{\link{vglm}}
+ and \code{\link{vgam}}.
+
+}
+\references{
+
+Rice, S. O. (1945)
+Mathematical Analysis of Random Noise.
+\emph{Bell System Technical Journal},
+\bold{24}, 46--156.
+
+}
+\author{ T. W. Yee }
+\note{
+ Convergence problems may occur for data where \eqn{v=0}; if so, use
+ \code{\link{rayleigh}} or possibly use an \code{\link{identity}} link.
+
+ When \eqn{v} is large (greater than 3, say) then the mean is approximately
+ \eqn{v} and the standard deviation is approximately \eqn{\sigma}{sigma}.
+
+}
+
+\seealso{
+ \code{\link{drice}},
+ \code{\link{rayleigh}},
+ \code{\link[base]{besselI}}.
+
+}
+\examples{
+vee = exp(2); sigma = exp(1);
+y = rrice(n <- 1000, vee, sigma)
+fit = vglm(y ~ 1, riceff, trace=TRUE, crit="c")
+c(mean(y), fitted(fit)[1])
+coef(fit, matrix=TRUE)
+Coef(fit)
+summary(fit)
+}
+\keyword{models}
+\keyword{regression}
+
diff --git a/man/rrvglm-class.Rd b/man/rrvglm-class.Rd
index 4dd7506..b1deb1c 100644
--- a/man/rrvglm-class.Rd
+++ b/man/rrvglm-class.Rd
@@ -87,8 +87,9 @@ Objects can be created by calls to \code{\link{rrvglm}}.
\item{\code{fitted.values}:}{
Object of class
\code{"matrix"}, from class \code{ "vlm"}.
- The fitted values. This may be missing or consist entirely
- of \code{NA}s, e.g., the Cauchy model.
+ The fitted values. This is usually the mean but may be
+ quantiles, or the location parameter, e.g., in the Cauchy model.
+
}
\item{\code{misc}:}{
Object of class \code{"list"},
diff --git a/man/rrvglm.Rd b/man/rrvglm.Rd
index 43e9b58..6efe39e 100644
--- a/man/rrvglm.Rd
+++ b/man/rrvglm.Rd
@@ -27,8 +27,11 @@ rrvglm(formula, family, data = list(), weights = NULL, subset = NULL,
}
\item{family}{
- a function of class \code{"vglmff"} describing
- what statistical model is to be fitted.
+ a function of class \code{"vglmff"} (see \code{\link{vglmff-class}})
+ describing what statistical model is to be fitted. This is called a
+ ``\pkg{VGAM} family function''. See \code{\link{CommonVGAMffArguments}}
+ for general information about many types of arguments found in this
+ type of function.
}
\item{data}{
@@ -202,6 +205,10 @@ 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.
+
}
\author{ Thomas W. Yee }
diff --git a/man/ruge.Rd b/man/ruge.Rd
index 642087d..7df9d2e 100644
--- a/man/ruge.Rd
+++ b/man/ruge.Rd
@@ -1,12 +1,12 @@
\name{ruge}
\alias{ruge}
-\non_function{}
+\docType{data}
\title{Rutherford-Geiger Polonium Data}
-\usage{data(ruge)}
\description{
Decay counts of polonium recorded by Rutherford and Geiger (1910).
}
+\usage{data(ruge)}
\format{
This data frame contains the following columns:
\describe{
diff --git a/man/skellam.Rd b/man/skellam.Rd
new file mode 100644
index 0000000..72c191c
--- /dev/null
+++ b/man/skellam.Rd
@@ -0,0 +1,105 @@
+\name{skellam}
+\alias{skellam}
+%- Also NEED an '\alias' for EACH other topic documented here.
+\title{Skellam Distribution Family Function}
+\description{
+ Estimates the two parameters of a Skellam distribution
+ by maximum likelihood estimation.
+
+}
+\usage{
+skellam(lmu1="loge", lmu2="loge",
+ emu1=list(), emu2=list(),
+ imu1=NULL, imu2=NULL,
+ nsimEIM=100, parallel=FALSE, zero=NULL)
+}
+%- maybe also 'usage' for other objects documented here.
+\arguments{
+ \item{lmu1, emu1}{
+ Link function and extra argument for the \eqn{\mu1}{mu1} parameter.
+ See \code{\link{Links}} for more choices and for general information.
+
+ }
+ \item{lmu2, emu2}{
+ Link function and extra argument for the \eqn{\mu1}{mu1} parameter.
+ See \code{\link{Links}} for more choices and for general information.
+
+ }
+ \item{imu1, imu2}{
+ Optional initial values for the parameters.
+ See \code{\link{CommonVGAMffArguments}} for more information.
+ If convergence failure occurs (this \pkg{VGAM} family function seems
+ to require good initial values) try using these arguments.
+
+ }
+ \item{nsimEIM, parallel, zero}{
+ See \code{\link{CommonVGAMffArguments}} for more information.
+ In particular, setting \code{parallel=TRUE} will constrain the
+ two means to be equal.
+
+ }
+}
+\details{
+ The Skellam distribution models the difference between two
+ independent Poisson distributions.
+ It has density function
+ \deqn{f(y;\mu_1,\mu_2) =
+ \left( \frac{ \mu_1 }{\mu_2} \right)^{y/2} \,
+ \exp(-\mu_1-\mu_2 ) \, I_y( 2 \sqrt{ \mu_1 \mu_2})
+ }{%
+f(y;mu1,mu2) =
+ ( \mu1 / mu_2 )^(y/2) *
+ exp(-mu1-mu2 ) * I_y( 2 * sqrt(mu1*mu2))
+ }
+ where \eqn{y} is an integer,
+ \eqn{\mu_1 > 0}{mu1 > 0},
+ \eqn{\mu_2 > 0}{mu2 > 0}.
+ Here, \eqn{I_v} is the modified Bessel function of the
+ first kind with order \eqn{v}.
+
+ The mean is \eqn{\mu_1 - \mu_2}{mu1 - mu2} (returned as the fitted values)
+ and the variance is \eqn{\mu_1 + \mu_2}{mu1 + mu2}.
+ Simulated Fisher scoring is implemented.
+
+}
+\value{
+ An object of class \code{"vglmff"} (see \code{\link{vglmff-class}}).
+ The object is used by modelling functions such as \code{\link{vglm}}
+ and \code{\link{vgam}}.
+
+}
+\references{
+Skellam, J. G. (1946)
+The frequency distribution of the difference between
+two Poisson variates belonging to different populations.
+\emph{Journal of the Royal Statistical Society, Series A},
+\bold{109}, 296.
+
+}
+\author{ T. W. Yee }
+\note{
+ Numerical problems may occur for data if \eqn{\mu_1}{mu1} and/or
+ \eqn{\mu_2}{mu2} are large.
+
+}
+
+\seealso{
+ \code{\link{dskellam}},
+ \code{\link{poissonff}}.
+
+}
+\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")
+coef(fit1, matrix=TRUE)
+coef(fit2, matrix=TRUE)
+summary(fit1)
+# Likelihood ratio test for equal means:
+1-pchisq(logLik(fit1)-logLik(fit2), df=fit2 at df.residual-fit1@df.residual)
+}
+\keyword{models}
+\keyword{regression}
+
diff --git a/man/skellamUC.Rd b/man/skellamUC.Rd
new file mode 100644
index 0000000..4220b2c
--- /dev/null
+++ b/man/skellamUC.Rd
@@ -0,0 +1,64 @@
+\name{Skellam}
+\alias{Skellam}
+\alias{dskellam}
+%\alias{pskellam}
+%\alias{qskellam}
+\alias{rskellam}
+\title{The Skellam Distribution}
+\description{
+ Density
+% distribution function, quantile function
+ and random generation for the
+ Skellam distribution.
+
+}
+\usage{
+dskellam(x, mu1, mu2, log=FALSE)
+%pskellam(q, mu1, mu2)
+%qskellam(p, mu1, mu2)
+rskellam(n, mu1, mu2)
+}
+\arguments{
+ \item{x}{vector of quantiles.}
+% \item{p}{vector of probabilities.}
+ \item{n}{number of observations.
+ Must be a positive integer of length 1.}
+ \item{mu1, mu2}{ See \code{\link{skellam}}}.
+ \item{log}{ Logical; if TRUE, the logarithm is returned. }
+}
+\value{
+ \code{dskellam} gives the density, and
+% \code{pskellam} gives the distribution function,
+% \code{qskellam} gives the quantile function, and
+ \code{rskellam} generates random deviates.
+
+}
+\author{ T. W. Yee }
+\details{
+ See \code{\link{skellam}}, the \pkg{VGAM} family function
+ for estimating the parameters,
+ for the formula of the probability density function and other details.
+
+}
+\section{Warning }{
+ Numerical problems may occur for data if \eqn{\mu_1}{mu1} and/or
+ \eqn{\mu_2}{mu2} are large.
+ The normal approximation for this case has not been implemented yet.
+
+}
+\seealso{
+ \code{\link{skellam}}.
+
+}
+\examples{
+\dontrun{
+mu1 = 1; mu2 = 2
+x = (-7):7
+plot(x, dskellam(x, mu1, mu2), type="h", las=1, col="blue",
+ main=paste("Density of Skellam distribution with mu1=", mu1,
+ " and mu2=", mu2, sep=""))
+}
+}
+\keyword{distribution}
+
+
diff --git a/man/skewnormal1.Rd b/man/skewnormal1.Rd
index 56614a7..797e5d8 100644
--- a/man/skewnormal1.Rd
+++ b/man/skewnormal1.Rd
@@ -8,7 +8,7 @@
}
\usage{
-skewnormal1(lshape = "identity", earg = list(), ishape = NULL)
+skewnormal1(lshape = "identity", earg = list(), ishape = NULL, nsimEIM=NULL)
}
%- maybe also 'usage' for other objects documented here.
\arguments{
@@ -28,6 +28,10 @@ skewnormal1(lshape = "identity", earg = list(), ishape = NULL)
See the note below.
}
+ \item{nsimEIM}{
+ See \code{\link{CommonVGAMffArguments}}.
+
+ }
}
\details{
The univariate skew-normal distribution has a density
@@ -51,7 +55,8 @@ skewnormal1(lshape = "identity", earg = list(), ishape = NULL)
\eqn{\mu=\alpha \sqrt{2/(\pi (1+\alpha^2))}}{mu=alpha*sqrt(2/(pi*(1+alpha^2)))}
and these are returned as the fitted values.
The variance of the distribution is \eqn{1-\mu^2}{1-mu^2}.
- The Newton-Raphson algorithm is used.
+ The Newton-Raphson algorithm is used unless the \code{nsimEIM}
+ argument is used.
}
\value{
@@ -89,7 +94,9 @@ distribution.
%}
\seealso{
\code{\link{snorm}},
- \code{\link{normal1}}.
+ \code{\link{normal1}},
+ \code{\link{fnormal1}}.
+
}
\examples{
diff --git a/man/slash.Rd b/man/slash.Rd
new file mode 100644
index 0000000..939b046
--- /dev/null
+++ b/man/slash.Rd
@@ -0,0 +1,113 @@
+\name{slash}
+\alias{slash}
+%- Also NEED an '\alias' for EACH other topic documented here.
+\title{ Slash Distribution Family Function }
+\description{
+ Estimates the two parameters of the
+ slash distribution by maximum likelihood estimation.
+}
+\usage{
+slash (lmu="identity", lsigma="loge", emu=list(), esigma=list(),
+ imu=NULL, isigma=NULL, iprobs = c(0.1, 0.9), nsimEIM=250,
+ zero=NULL, smallno = .Machine$double.eps*1000)
+}
+%- maybe also 'usage' for other objects documented here.
+\arguments{
+ \item{lmu, lsigma}{
+ Parameter link functions applied to the \eqn{\mu}{mu}
+ and \eqn{\sigma}{sigma} parameters, respectively.
+ See \code{\link{Links}} for more choices.
+
+ }
+ \item{emu, esigma}{
+ List. Extra argument for each of the link functions.
+ See \code{earg} in \code{\link{Links}} for general information.
+
+ }
+ \item{imu, isigma}{
+ Initial values.
+ A \code{NULL} means an initial value is chosen internally.
+ See \code{\link{CommonVGAMffArguments}} for more information.
+
+ }
+ \item{iprobs}{
+ Used to compute the initial values for \code{mu}.
+ This argument is fed into the \code{probs} argument of
+ \code{\link[stats]{quantile}}, and then a grid between these two points
+ is used to evaluate the log-likelihood.
+ This argument must be of length two and have values between 0 and 1.
+
+ }
+ \item{nsimEIM, zero}{
+ See \code{\link{CommonVGAMffArguments}} for more information.
+
+ }
+ \item{smallno}{
+ Small positive number, used to test for the singularity.
+
+ }
+}
+\details{
+ The standard slash distribution is the distribution of the ratio of
+ a standard normal variable to an independent standard uniform(0,1) variable.
+ It is mainly of use in simulation studies.
+ One of its properties is that it has heavy tails, similar to those of
+ the Cauchy.
+
+ The general slash distribution can be obtained by replacing
+ the univariate normal variable by a general normal
+ \eqn{N(\mu,\sigma)}{N(mu,sigma)} random variable.
+ It has a density that can be written as
+ \deqn{f(y) = \left\{
+\begin{array}{cl}
+ 1/(2 \sigma \sqrt(2 \pi)) & if y=\mu, \\
+ 1-\exp(-(((y-\mu)/\sigma)^2)/2))/(\sqrt(2 pi) \sigma ((y-\mu)/\sigma)^2) & if y \ne \mu.
+\end{array} \right . }{%
+f(y) = 1/(2*sigma*sqrt(2*pi)) if y=mu
+ = 1-exp(-(((x-mu)/sigma)^2)/2))/(sqrt(2*pi)*sigma*((x-mu)/sigma)^2) if y!=mu}
+ where \eqn{\mu}{mu} and \eqn{\sigma}{sigma} are
+ the mean and standard deviation of
+ the univariate normal distribution respectively.
+
+}
+\value{
+ An object of class \code{"vglmff"} (see \code{\link{vglmff-class}}).
+ The object is used by modelling functions such as \code{\link{vglm}},
+ and \code{\link{vgam}}.
+
+}
+\references{
+ Johnson, N. L. and Kotz, S. and Balakrishnan, N. (1994)
+ \emph{Continuous Univariate Distributions},
+ 2nd edition, Volume 1, New York: Wiley.
+
+ Kafadar, K. (1982)
+ A Biweight Approach to the One-Sample Problem
+ \emph{Journal of the American Statistical Association},
+ \bold{77}, 416--424.
+
+}
+
+\author{ T. W. Yee and C. S. Chee }
+\note{
+ Fisher scoring using simulation is used.
+ Convergence is often quite slow.
+ Numerical problems may occur.
+
+}
+
+
+\seealso{
+ \code{\link{rslash}}.
+
+}
+\examples{
+y = rslash(n=1000, mu=4, sigma=exp(2))
+fit = vglm(y ~ 1, slash, trace=TRUE)
+coef(fit, matrix=TRUE)
+Coef(fit)
+summary(fit)
+}
+\keyword{models}
+\keyword{regression}
+
diff --git a/man/slashUC.Rd b/man/slashUC.Rd
new file mode 100644
index 0000000..019dc34
--- /dev/null
+++ b/man/slashUC.Rd
@@ -0,0 +1,72 @@
+\name{Slash}
+\alias{Slash}
+\alias{dslash}
+\alias{pslash}
+\alias{rslash}
+%- Also NEED an '\alias' for EACH other topic documented here.
+\title{ Slash Distribution }
+\description{
+ Density function, distribution function, and
+ random generation for the slash distribution.
+
+}
+\usage{
+dslash(x, mu=0, sigma=1, log=FALSE, smallno=.Machine$double.eps*1000)
+pslash(q, mu=0, sigma=1)
+rslash(n, mu=0, sigma=1)
+}
+%- maybe also 'usage' for other objects documented here.
+\arguments{
+ \item{x, q}{vector of quantiles.}
+ \item{n}{number of observations. Must be a single positive integer. }
+ \item{mu, sigma}{the mean and standard deviation of
+ the univariate normal distribution.
+
+ }
+ \item{log}{
+ Logical.
+ If \code{TRUE} then the logarithm of the density is returned.
+
+ }
+ \item{smallno}{
+ See \code{\link{slash}}.
+
+ }
+}
+\details{
+ See \code{\link{slash}}, the \pkg{VGAM} family function
+ for estimating the two parameters by maximum likelihood estimation,
+ for the formula of the probability density function and other details.
+
+}
+\value{
+ \code{dslash} gives the density, and
+ \code{pslash} gives the distribution function,
+ \code{rslash} generates random deviates.
+
+}
+%\references{ }
+\author{ Thomas W. Yee and C. S. Chee}
+\note{
+ \code{pslash} is very slow.
+
+}
+
+\seealso{
+ \code{\link{slash}}.
+
+}
+\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,
+ col=c("blue","black","red"), lwd=2)
+
+plot(x, pslash(q=x), col="blue", type="l", ylim=0:1)
+}
+}
+\keyword{distribution}
diff --git a/man/studentt.Rd b/man/studentt.Rd
index f6e94e0..9a390fb 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())
+studentt(link.df = "loglog", earg=list(), idf=NULL, nsimEIM=100)
}
%- maybe also 'usage' for other objects documented here.
\arguments{
@@ -21,6 +21,17 @@ studentt(link.df = "loglog", earg=list())
See \code{earg} in \code{\link{Links}} for general information.
}
+ \item{idf}{
+ Optional initial value.
+ If given, its value must be greater than 1.
+ The default is to compute an initial value internally.
+
+ }
+
+ \item{nsimEIM}{
+ See \code{\link{CommonVGAMffArguments}}.
+
+ }
}
\details{
The density function is
@@ -37,6 +48,13 @@ studentt(link.df = "loglog", earg=list())
The degrees of freedom is treated as a parameter to be estimated,
and as real and not integer.
+ Simulation is used to estimate the EIM.
+ Consequently the results will be reproducible only if
+ a function such as \code{\link[base:Random]{set.seed}} is used.
+ Increasing the value of \code{nsimEIM} will give more accurate results.
+ In general convergence will be slow, especially when there are
+ covariates.
+
}
\value{
An object of class \code{"vglmff"} (see \code{\link{vglmff-class}}).
@@ -57,6 +75,10 @@ The probable error of a mean.
\author{ T. W. Yee }
\note{
+ Practical experience has shown reasonably good initial values are
+ required. If convergence failure occurs try using \code{idf}.
+ Local solutions are also possible.
+
A standard normal distribution corresponds to a \emph{t} distribution
with infinite degrees of freedom. Consequently, if the data is close
to normal, there may be convergence problems.
@@ -67,12 +89,11 @@ The probable error of a mean.
\code{\link{loglog}},
\code{\link[stats]{TDist}}.
-
}
\examples{
n = 500
-y = rt(n, df=exp(exp(1)))
-fit = vglm(y ~ 1, studentt)
+y = rt(n, df=exp(exp(0.5)))
+fit = vglm(y ~ 1, studentt, trace=TRUE)
coef(fit, matrix=TRUE)
Coef(fit)
}
diff --git a/man/undocumented-methods.Rd b/man/undocumented-methods.Rd
index 80fea7d..6138e4b 100644
--- a/man/undocumented-methods.Rd
+++ b/man/undocumented-methods.Rd
@@ -52,6 +52,7 @@
\alias{fitted,vsmooth.spline-method}
\alias{guplot,numeric-method}
\alias{guplot,vlm-method}
+%\alias{model.frame,ANY-method}
\alias{model.frame,vlm-method}
\alias{plot,cao,ANY-method}
\alias{plot,vlm,ANY-method}
@@ -85,6 +86,7 @@
\alias{Max,uqo-method}
\alias{meplot,numeric-method}
\alias{meplot,vlm-method}
+%\alias{model.matrix,ANY-method}
\alias{model.matrix,qrrvglm-method}
\alias{model.matrix,vlm-method}
\alias{Opt,qrrvglm-method}
diff --git a/man/usagrain.Rd b/man/usagrain.Rd
index 53e53d3..0b254b2 100644
--- a/man/usagrain.Rd
+++ b/man/usagrain.Rd
@@ -1,11 +1,12 @@
\name{usagrain}
\alias{usagrain}
-\non_function{}
+\docType{data}
\title{USA grain prices}
-\usage{data(usagrain)}
\description{
A 4-column matrix.
+
}
+\usage{data(usagrain)}
\format{
The columns are:
\describe{
diff --git a/man/vgam-class.Rd b/man/vgam-class.Rd
index 63cc683..86be796 100644
--- a/man/vgam-class.Rd
+++ b/man/vgam-class.Rd
@@ -80,10 +80,12 @@ The scaling parameter.
from class \code{ "vlm"}.
The effects.
}
- \item{\code{fitted.values}:}{Object of class
-\code{"matrix"}, from class \code{ "vlm"}.
-The fitted values. This may be missing or consist entirely
-of \code{NA}s, e.g., the Cauchy model.
+ \item{\code{fitted.values}:}{
+ Object of class
+ \code{"matrix"}, from class \code{ "vlm"}.
+ The fitted values. This is usually the mean but may be
+ quantiles, or the location parameter, e.g., in the Cauchy model.
+
}
\item{\code{misc}:}{Object of class \code{"list"},
from class \code{ "vlm"}.
diff --git a/man/vgam.Rd b/man/vgam.Rd
index 169a02c..41ea376 100644
--- a/man/vgam.Rd
+++ b/man/vgam.Rd
@@ -32,10 +32,11 @@ vgam(formula, family, data = list(), weights = NULL, subset = NULL,
}
\item{family}{
- a function of class \code{"vglmff"}
- (see \code{\link{vglmff-class}}) describing
- what statistical model is to be fitted.
- These are called ``\pkg{VGAM} family functions''.
+ a function of class \code{"vglmff"} (see \code{\link{vglmff-class}})
+ describing what statistical model is to be fitted. This is called a
+ ``\pkg{VGAM} family function''. See \code{\link{CommonVGAMffArguments}}
+ for general information about many types of arguments found in this
+ type of function.
}
\item{data}{
@@ -209,7 +210,10 @@ Vector generalized additive models.
\emph{Journal of the Royal Statistical Society, Series B, Methodological},
\bold{58}, 481--493.
-\url{http://www.stat.auckland.ac.nz/~yee}
+ Documentation accompanying the \pkg{VGAM} package at
+ \url{http://www.stat.auckland.ac.nz/~yee}
+ contains further information and examples.
+
}
\author{ Thomas W. Yee }
diff --git a/man/vglm-class.Rd b/man/vglm-class.Rd
index 9193b5a..3d13f37 100644
--- a/man/vglm-class.Rd
+++ b/man/vglm-class.Rd
@@ -71,8 +71,9 @@ The effects.
}
\item{\code{fitted.values}:}{Object of class
\code{"matrix"}, from class \code{ "vlm"}.
-The fitted values. This may be missing or consist entirely
-of \code{NA}s, e.g., the Cauchy model.
+The fitted values.
+%This may be missing or consist entirely
+%of \code{NA}s, e.g., the Cauchy model.
}
\item{\code{misc}:}{Object of class \code{"list"},
from class \code{ "vlm"}.
diff --git a/man/vglm.Rd b/man/vglm.Rd
index 3e7a8f4..ae8333b 100644
--- a/man/vglm.Rd
+++ b/man/vglm.Rd
@@ -28,9 +28,11 @@ vglm(formula, family, data = list(), weights = NULL, subset = NULL,
}
\item{family}{
- a function of class \code{"vglmff"} describing
- what statistical model is to be fitted.
- These are called ``\pkg{VGAM} family functions''.
+ a function of class \code{"vglmff"} (see \code{\link{vglmff-class}})
+ describing what statistical model is to be fitted. This is called a
+ ``\pkg{VGAM} family function''. See \code{\link{CommonVGAMffArguments}}
+ for general information about many types of arguments found in this
+ type of function.
}
\item{data}{
@@ -198,9 +200,11 @@ vglm(formula, family, data = list(), weights = NULL, subset = NULL,
\item{df.total}{the total degrees of freedom.}
\item{dispersion}{the scaling parameter.}
\item{effects}{the effects.}
- \item{fitted.values}{the fitted values, as a matrix.
- This may be missing or consist entirely
- of \code{NA}s, e.g., the Cauchy model.
+ \item{fitted.values}{
+ the fitted values, as a matrix.
+ This is usually the mean but may be quantiles, or the location
+ parameter, e.g., in the Cauchy model.
+
}
\item{misc}{a list to hold miscellaneous parameters.}
\item{model}{the model frame.}
@@ -242,9 +246,11 @@ Vector generalized additive models.
\emph{Journal of the Royal Statistical Society, Series B, Methodological},
\bold{58}, 481--493.
-The \pkg{VGAM} library can be downloaded
-starting from \url{http://www.stat.auckland.ac.nz/~yee}.
-Other \pkg{VGAM} resources and documentation can be found there.
+ Documentation accompanying the \pkg{VGAM} package at
+ \url{http://www.stat.auckland.ac.nz/~yee}
+ contains further information and examples.
+
+
}
diff --git a/man/vonmises.Rd b/man/vonmises.Rd
index f1bdacf..305545e 100644
--- a/man/vonmises.Rd
+++ b/man/vonmises.Rd
@@ -114,7 +114,8 @@ New York: Wiley-Interscience, Third edition.
}
\seealso{
- \code{\link[base]{Bessel}}.
+ \code{\link[base]{Bessel}},
+ \code{\link{cardioid}}.
\pkg{CircStats} and \pkg{circular} currently have a lot more
R functions for circular data than the \pkg{VGAM} package.
diff --git a/man/waitakere.Rd b/man/waitakere.Rd
index 7750ae2..19af06f 100644
--- a/man/waitakere.Rd
+++ b/man/waitakere.Rd
@@ -1,14 +1,14 @@
\name{waitakere}
\alias{waitakere}
-\non_function{}
+\docType{data}
\title{Waitakere Ranges Data}
-\usage{data(waitakere)}
\description{
The \code{waitakere} data frame has 579 rows and 18 columns.
Altitude is explanatory, and there are binary responses
(presence/absence = 1/0 respectively) for 17 plant species.
}
+\usage{data(waitakere)}
\format{
This data frame contains the following columns:
\describe{
diff --git a/man/yulesimon.Rd b/man/yulesimon.Rd
new file mode 100644
index 0000000..39b7827
--- /dev/null
+++ b/man/yulesimon.Rd
@@ -0,0 +1,95 @@
+\name{yulesimon}
+\alias{yulesimon}
+%- Also NEED an '\alias' for EACH other topic documented here.
+\title{ Yule-Simon Family Function }
+\description{
+ Estimating the parameter of the Yule-Simon distribution.
+
+}
+\usage{
+yulesimon(link="loge", earg=list(), irho=NULL, nsimEIM=200)
+}
+%- maybe also 'usage' for other objects documented here.
+\arguments{
+ \item{link, earg}{
+ Link function and extra argument for the \eqn{\rho}{rho} parameter.
+ See \code{\link{Links}} for more choices and for general information.
+
+ }
+ \item{irho}{
+ Optional initial value for the (positive) parameter.
+ See \code{\link{CommonVGAMffArguments}} for more information.
+ The default is to obtain an initial value internally. Use this argument
+ if the default fails.
+
+ }
+ \item{nsimEIM}{
+ See \code{\link{CommonVGAMffArguments}} for more information.
+
+ }
+}
+\details{
+ The probability function is
+ \deqn{f(y;\rho) = rho*beta(y,rho+1),}{%
+ f(y;rho) = rho*beta(y,rho+1),}
+ where the parameter \eqn{\rho>0}{rho>0}
+ and \eqn{y=1,2,\ldots}{y=1,2,...}.
+ The function \code{\link{dyules}} computes this probability function.
+ The mean of \eqn{Y}, which is returned as fitted values, is
+ \eqn{\rho/(\rho-1)}{rho/(rho-1)}
+ provided \eqn{\rho > 1}{rho > 1}.
+ The variance of \eqn{Y} is
+ \eqn{\rho^2/((\rho-1)^2 (\rho-2))}{rho^2/((rho-1)^2 (rho-2))}
+ provided \eqn{\rho > 2}{rho > 2}.
+
+}
+\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{
+
+ Simon, H. A. (1955)
+ On a class of skew distribution functions.
+ \emph{Biometrika},
+ \bold{42},
+ 425--440.
+
+}
+\author{ T. W. Yee }
+%\note{
+%}
+
+\seealso{
+ \code{\link{ryules}}.
+
+}
+\examples{
+x = runif(n <- 1000)
+y = ryules(n, rho=exp(1.5-x))
+table(y)
+fit = vglm(y ~ x, yulesimon, trace=TRUE)
+coef(fit, matrix=TRUE)
+summary(fit)
+}
+\keyword{models}
+\keyword{regression}
+
+
+%# Generate some yulesimon random variates
+%set.seed(123)
+%nn = 400
+%x = 1:20
+%alpha = 1.1 # The parameter
+%probs = dyulesimon(x, alpha)
+%\dontrun{
+%plot(x, probs, type="h", log="y")}
+%cs = cumsum(probs)
+%tab = table(cut(runif(nn), brea = c(0,cs,1)))
+%index = (1:length(tab))[tab>0]
+%y = rep(index, times=tab[index])
+
+
+
diff --git a/man/yulesimonUC.Rd b/man/yulesimonUC.Rd
new file mode 100644
index 0000000..a418bb2
--- /dev/null
+++ b/man/yulesimonUC.Rd
@@ -0,0 +1,70 @@
+\name{Yules}
+\alias{Yules}
+\alias{dyules}
+\alias{pyules}
+%\alias{qyules}
+\alias{ryules}
+\title{ Yule-Simon Distribution }
+\description{
+ Density, distribution function, quantile function and random generation
+ for the Yule-Simon distribution.
+
+}
+\usage{
+dyules(x, rho, log=FALSE)
+pyules(q, rho)
+%qyules(p, rho)
+ryules(n, rho)
+}
+%- maybe also 'usage' for other objects documented here.
+\arguments{
+ \item{x, q}{
+ Vector of quantiles. For the density, it should be a vector with
+ positive integer values in order for the probabilities to be positive.
+
+ }
+% \item{p}{vector of probabilities.}
+ \item{n}{number of observations. A single positive integer.}
+ \item{rho}{
+ See \code{\link{yulesimon}}.
+
+ }
+ \item{log}{logical; if TRUE, the logarithm is returned. }
+}
+\details{
+ See \code{\link{yulesimon}}, the \pkg{VGAM} family function
+ for estimating the parameter,
+ for the formula of the probability density function and other details.
+
+}
+\value{
+ \code{dyules} gives the density,
+ \code{pyules} gives the distribution function, and
+% \code{qyules} gives the quantile function, and
+ \code{ryules} generates random deviates.
+
+}
+%\references{
+%
+%}
+\author{ T. W. Yee }
+%\note{
+%}
+
+\seealso{
+ \code{\link{yulesimon}}.
+
+}
+\examples{
+dyules(1:20, 2.1)
+ryules(20, 2.1)
+
+round(1000 * dyules(1:8, 2))
+table(ryules(1000, 2))
+
+\dontrun{
+x = 0:6
+plot(x, dyules(x, rho=2.2), type="h", las=1, col="blue")
+}
+}
+\keyword{distribution}
diff --git a/man/zanegbinomial.Rd b/man/zanegbinomial.Rd
index 4298ae7..ca154b7 100644
--- a/man/zanegbinomial.Rd
+++ b/man/zanegbinomial.Rd
@@ -135,8 +135,10 @@ for counts with extra zeros.
\seealso{
\code{\link{posnegbinomial}},
+ \code{\link{negbinomial}},
\code{\link{binomialff}},
\code{\link{rposnegbin}},
+ \code{\link{zinegbinomial}},
\code{\link{zipoisson}}.
}
diff --git a/man/zetaff.Rd b/man/zetaff.Rd
index a1bedca..19b6606 100644
--- a/man/zetaff.Rd
+++ b/man/zetaff.Rd
@@ -62,15 +62,17 @@ ranging from values near 0 to values about 10 or more.
%Oxford: Clarendon Press.
\references{
-pp.465--471, Chapter 11 of
-Johnson N. L., Kotz S., and Kemp A. W. (1993)
-\emph{Univariate Discrete Distributions},
-2nd ed.
-New York: Wiley.
+
+pp.527-- of Chapter 11 of
+ Johnson N. L., Kemp, A. W. and Kotz S. (2005)
+ \emph{Univariate Discrete Distributions},
+ 3rd edition,
+ Hoboken, New Jersey: Wiley.
Knight, K. (2000)
\emph{Mathematical Statistics}.
Boca Raton: Chapman & Hall/CRC Press.
+
}
\author{ T. W. Yee }
\note{ The \code{\link{zeta}} function may be used to
diff --git a/man/zibinomUC.Rd b/man/zibinomUC.Rd
index da81e42..ad78365 100644
--- a/man/zibinomUC.Rd
+++ b/man/zibinomUC.Rd
@@ -61,9 +61,7 @@ rzibinom(n, size, prob, phi = 0)
\code{\link[stats:Binomial]{dbinom}}.
}
\examples{
-prob = 0.2
-size = 10
-phi = 0.5
+prob = 0.2; size = 10; phi = 0.5
(i = dzibinom(0:size, size, prob, phi=phi))
cumsum(i) - pzibinom(0:size, size, prob, phi=phi) # Should be 0s
table(rzibinom(100, size, prob, phi=phi))
@@ -73,11 +71,12 @@ round(dzibinom(0:10, size, prob, phi=phi) * 100) # Should be similar
\dontrun{
x = 0:size
-plot(x, dzibinom(x, size, prob, phi=phi), type="h", ylab="Probability",
- main=paste("ZIB(", size, ", ", prob, ", phi=", phi, ") (blue) vs",
- " Binomial(", size, ", ", prob, ") (red and shifted slightly)", sep=""),
- lwd=2, col="blue", las=1)
-lines(x+0.05, dbinom(x, size, prob), type="h", lwd=2, col="red")
+barplot(rbind(dzibinom(x, size, prob, phi=phi),
+ dbinom(x, size, prob)),
+ 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)
}
}
\keyword{distribution}
diff --git a/man/zinbUC.Rd b/man/zinbUC.Rd
new file mode 100644
index 0000000..818448f
--- /dev/null
+++ b/man/zinbUC.Rd
@@ -0,0 +1,92 @@
+\name{Zinb}
+\alias{Zinb}
+\alias{dzinb}
+\alias{pzinb}
+\alias{qzinb}
+\alias{rzinb}
+%- Also NEED an '\alias' for EACH other topic documented here.
+\title{ Zero-Inflated Negative Binomial Distribution }
+\description{
+ Density, distribution function, quantile function and random generation
+ for the zero-inflated negative binomial distribution with parameter \code{phi}.
+
+}
+\usage{
+dzinb(x, phi, size, prob, munb, log=FALSE)
+pzinb(q, phi, size, prob, munb)
+qzinb(p, phi, size, prob, munb)
+rzinb(n, phi, size, prob, munb)
+}
+%- maybe also 'usage' for other objects documented here.
+\arguments{
+ \item{x, q}{vector of quantiles.}
+ \item{p}{vector of probabilities.}
+ \item{n}{number of observations. Must be a single positive integer. }
+ \item{size, prob, munb, log}{
+ Arguments matching \code{\link[stats:NegBinomial]{dnbinom}}.
+ The argument \code{munb} corresponds to \code{mu} in
+ \code{\link[stats:NegBinomial]{dnbinom}} and has been renamed
+ to emphasize the fact that it is the mean of the negative binomial
+ \emph{component}.
+
+ }
+ \item{phi}{
+ Probability of zero (ignoring the negative binomial distribution), called
+ \eqn{\phi}{phi}.
+
+ }
+}
+\details{
+ The probability function of \eqn{Y} is 0 with probability
+ \eqn{\phi}{phi}, and a negative binomial distribution with
+ probability \eqn{1-\phi}{1-phi}. Thus
+ \deqn{P(Y=0) =\phi + (1-\phi) P(W=0)}{%
+ P(Y=0) = phi + (1-phi) * P(W=0)}
+ where \eqn{W} is distributed as a negative binomial distribution
+ (see \code{\link[stats:NegBinomial]{rnbinom}}.)
+ See \code{\link{negbinomial}}, a \pkg{VGAM} family function,
+ for the formula of the probability density function and other details
+ of the negative binomial distribution.
+
+}
+\value{
+ \code{dzinb} gives the density,
+ \code{pzinb} gives the distribution function,
+ \code{qzinb} gives the quantile function, and
+ \code{rzinb} generates random deviates.
+}
+%\references{ }
+\author{ Thomas W. Yee }
+\note{
+ The argument \code{phi} is recycled to the required length, and
+ must have values which lie in the interval [0,1].
+
+}
+
+\seealso{
+ \code{\link{zinegbinomial}},
+ \code{\link[stats:NegBinomial]{rnbinom}},
+ \code{\link{rzipois}}.
+
+}
+\examples{
+munb = 3; phi = 0.2; k = 10
+x = 0:10
+(i = dzinb(x, phi=phi, mu=munb, size=k))
+cumsum(i) - pzinb(x, phi=phi, mu=munb, size=k) # Should be 0s
+table(rzinb(100, phi=phi, mu=munb, size=k))
+
+table(qzinb(runif(1000), phi=phi, mu=munb, size=k))
+round(dzinb(x, phi=phi, mu=munb, size=k) * 1000) # Should be similar
+
+\dontrun{
+barplot(rbind(dzinb(x, phi=phi, mu=munb, size=k),
+ dnbinom(x, mu=munb, size=k)),
+ beside = TRUE, col = c("blue","green"),
+ main=paste("ZINB(mu=", munb, ", k=", k, ", phi=", phi,
+ ") (blue) vs negative binomial(mu=", munb,
+ ", k=", k, ") (green)", sep=""),
+ names.arg = as.character(x))
+}
+}
+\keyword{distribution}
diff --git a/man/zinegbinomial.Rd b/man/zinegbinomial.Rd
new file mode 100644
index 0000000..6383889
--- /dev/null
+++ b/man/zinegbinomial.Rd
@@ -0,0 +1,146 @@
+\name{zinegbinomial}
+\alias{zinegbinomial}
+%- Also NEED an '\alias' for EACH other topic documented here.
+\title{ Zero-Inflated Negative Binomial Distribution Family Function }
+\description{
+ Fits a zero-inflated negative binomial distribution by
+ full maximum likelihood estimation.
+
+}
+\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)
+}
+%- maybe also 'usage' for other objects documented here.
+\arguments{
+ \item{lphi, lmunb, lk}{
+ Link functions for the parameters \eqn{\phi}{phi},
+ the mean and \eqn{k}; see \code{\link{negbinomial}} for details,
+ and \code{\link{Links}} for more choices.
+
+ }
+ \item{ephi, emunb, ek}{
+ List. Extra arguments for the respective links.
+ See \code{earg} in \code{\link{Links}} for general information.
+
+ }
+
+ \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.
+
+ }
+ \item{method.init}{
+ An integer with value \code{1} or \code{2} or \code{3} which
+ specifies the initialization method for the mean parameter.
+ If failure to converge occurs try another value
+ and/or else specify a value for \code{shrinkage.init}.
+
+ }
+ \item{shrinkage.init}{
+ How much shrinkage is used when initializing the mean.
+ The value must be between 0 and 1 inclusive, and
+ a value of 0 means the individual response values are used,
+ and a value of 1 means the median or mean is used.
+ This argument is used in conjunction with \code{method.init}.
+
+ }
+ \item{zero}{
+ Integers specifying which linear/additive predictor is modelled
+ as intercepts only. If given, their absolute values must be
+ either 1 or 2 or 3, and the default is only the \eqn{k} parameters
+ (one for each response).
+ See \code{\link{CommonVGAMffArguments}} for more information.
+
+ }
+ \item{nsimEIM}{
+ See \code{\link{CommonVGAMffArguments}} for more information.
+
+ }
+}
+\details{
+ This function uses simulation and Fisher scoring, and is based on
+ \deqn{P(Y=0) = \phi + (1-\phi) (k/(k+\mu))^k,}{%
+ P(Y=0) = \phi + (1-\phi) * (k/(k+\mu))^k,}
+ and for \eqn{y=1,2,\ldots},
+ \deqn{P(Y=y) = (1-\phi) \, dnbinom(y, \mu, k).}{%
+ P(Y=y) = (1-\phi) * dnbinom(y, \mu, k).}
+ The parameter \eqn{\phi}{phi} satisfies \eqn{0 < \phi < 1}{0 < phi < 1}.
+ The mean of \eqn{Y} is \eqn{(1-\phi) \mu}{(1-phi)*munb}
+ (returned as the fitted values). By default, the three linear/additive
+ predictors are \eqn{(logit(\phi), \log(\mu), \log(k))^T}{(logit(phi),
+ log(munb), log(k))^T}.
+ See \code{\link{negbinomial}}, another \pkg{VGAM} family function,
+ for the formula of the probability density function and other details
+ of the negative binomial distribution.
+
+ Independent multivariate responses are handled.
+ If so then arguments \code{iphi} and \code{ik} may be vectors with
+ length equal to the number of responses.
+
+}
+\value{
+ An object of class \code{"vglmff"} (see \code{\link{vglmff-class}}).
+ The object is used by modelling functions such as \code{\link{vglm}},
+ and \code{\link{vgam}}.
+
+}
+%\references{
+%
+%}
+\author{ T. W. Yee }
+\note{
+ For intercept-models, the \code{misc} slot has a component called
+ \code{p0} which is the estimate of \eqn{P(Y=0)}. Note that \eqn{P(Y=0)}
+ is not the parameter \eqn{\phi}{phi}.
+
+ If \eqn{k} is large then the use of \pkg{VGAM} family function
+ \code{\link{zipoisson}} is probably preferable.
+ This follows because the Poisson is the limiting distribution of a
+ negative binomial as \eqn{k} tends to infinity.
+
+ The zero-\emph{deflated} negative binomial distribution cannot
+ be handled with this family function. It can be handled
+ with the zero-altered negative binomial distribution; see
+ \code{\link{zanegbinomial}}.
+
+}
+
+\section{Warning }{
+ Numerical problems can occur.
+ Half-stepping is not uncommon.
+ If failure to converge occurs, try using combinations of
+ \code{method.init},
+ \code{shrinkage.init},
+ \code{iphi},
+ \code{ik}, and/or
+ \code{zero} if there are explanatory variables.
+
+}
+
+\seealso{
+ \code{\link{Zinb}},
+ \code{\link{negbinomial}},
+ \code{\link[stats:negative binomial]{rpois}}.
+
+}
+\examples{
+x = runif(n <- 1000)
+phi = logit(-0.5+1*x, inverse=TRUE)
+munb = exp(3+x)
+k = exp(0+2*x)
+y1 = rzinb(n, phi, mu=munb, size=k)
+y2 = rzinb(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)
+coef(fit, matrix=TRUE)
+summary(fit)
+cbind(fitted(fit), (1-phi) * munb)[1:5,]
+vcov(fit)
+}
+\keyword{models}
+\keyword{regression}
+
diff --git a/man/zipf.Rd b/man/zipf.Rd
index bde1e13..038e0f6 100644
--- a/man/zipf.Rd
+++ b/man/zipf.Rd
@@ -63,11 +63,11 @@ zipf(N=NULL, link="loge", earg=list(), init.s=NULL)
}
\references{
-pp.465--471, Chapter 11 of
-Johnson N. L., Kotz S., and Kemp A. W. (1993)
-\emph{Univariate Discrete Distributions},
-2nd ed.
-New York: Wiley.
+pp.526-- of Chapter 11 of
+ Johnson N. L., Kemp, A. W. and Kotz S. (2005)
+ \emph{Univariate Discrete Distributions},
+ 3rd edition,
+ Hoboken, New Jersey: Wiley.
}
\author{ T. W. Yee }
@@ -92,3 +92,11 @@ fitted(fit, mat=FALSE)
}
\keyword{models}
\keyword{regression}
+
+
+%pp.465--471, Chapter 11 of
+%Johnson N. L., Kotz S., and Kemp A. W. (1993)
+%\emph{Univariate Discrete Distributions},
+%2nd ed.
+%New York: Wiley.
+
diff --git a/man/zipoisUC.Rd b/man/zipoisUC.Rd
index ab53d38..d05ef3b 100644
--- a/man/zipoisUC.Rd
+++ b/man/zipoisUC.Rd
@@ -54,11 +54,13 @@ rzipois(n, lambda, phi = 0)
\seealso{
\code{\link[stats:Poisson]{dpois}},
- \code{\link{zipoisson}}.
+ \code{\link{zipoisson}},
+ \code{\link{rzinb}}.
+
}
\examples{
-lambda = 4
-phi = 0.8
+lambda = 3
+phi = 0.2
(i = dzipois(0:7, lambda, phi))
cumsum(i) - pzipois(0:7, lambda, phi) # Should be 0s
table(rzipois(100, lambda, phi))
@@ -68,11 +70,11 @@ round(dzipois(0:10, lambda, phi) * 100) # Should be similar
\dontrun{
x = 0:10
-plot(x, dzipois(x, lambda, phi), type="h", ylab="Probability",
- main=paste("ZIP(", lambda, ", phi=", phi, ") (blue) vs",
- " Poisson(", lambda, ") (red and shifted slightly)", sep=""),
- lwd=2, col="blue", las=1)
-lines(x+0.05, dpois(x, lambda), type="h", lwd=2, col="red")
+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))
}
}
\keyword{distribution}
diff --git a/man/zipoisson.Rd b/man/zipoisson.Rd
index 21966e8..6f5b5f5 100644
--- a/man/zipoisson.Rd
+++ b/man/zipoisson.Rd
@@ -3,7 +3,7 @@
%- Also NEED an '\alias' for EACH other topic documented here.
\title{ Zero-Inflated Poisson Distribution Family Function }
\description{
- Fits a zero-inflated Poisson distribution using full maximum likelihood
+ Fits a zero-inflated Poisson distribution by full maximum likelihood
estimation.
}
@@ -138,8 +138,8 @@ 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)
coef(fit, matrix=TRUE)
-cbind(actual=w, fitted=
- dzipois(y, lambda=Coef(fit)[2], phi=Coef(fit)[1]) * sum(w))
+cbind(actual=w, fitted= round(
+ dzipois(y, lambda=Coef(fit)[2], phi=Coef(fit)[1]) * sum(w), dig=2))
# Another example: data from Angers and Biswas (2003)
diff --git a/src/testf90.f90 b/src/testf90.f90
new file mode 100644
index 0000000..48aa4b9
--- /dev/null
+++ b/src/testf90.f90
@@ -0,0 +1,30 @@
+! Test F90 subroutines; cannot be translated by ratfor
+! 20080225
+! Author: T. W. Yee
+
+!module VGAMf90 ! =============================================
+
+subroutine VGAM_F90_fill9(vec, veclen, ansvec)
+implicit none
+! 20080225
+
+integer :: veclen
+double precision :: vec(veclen), ansvec(veclen)
+double precision, allocatable :: workspace1(:)
+
+! Local variables
+integer :: iii
+
+allocate(workspace1(veclen))
+do iii = 1, veclen
+ workspace1(iii) = iii
+ ansvec(iii) = vec(iii) + workspace1(iii)
+end do
+deallocate(workspace1)
+
+end subroutine VGAM_F90_fill9
+
+
+!end module VGAMf90 ! =========================================
+
+
--
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