[r-cran-vgam] 03/63: Import Upstream version 0.7-2
Andreas Tille
tille at debian.org
Tue Jan 24 13:54:20 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 21b01955b5936e0cdd11ce589b33f1b668884edd
Author: Andreas Tille <tille at debian.org>
Date: Tue Jan 24 14:16:43 2017 +0100
Import Upstream version 0.7-2
---
DESCRIPTION | 6 +-
NAMESPACE | 25 +-
NEWS | 33 +
R/cao.fit.q | 55 +-
R/family.binomial.q | 285 ++--
R/family.bivariate.q | 362 ++++-
R/family.categorical.q | 418 +++++-
R/family.censored.q | 44 +-
R/family.extremes.q | 55 +-
R/family.genetic.q | 356 +++--
R/family.glmgam.q | 237 ++--
R/family.loglin.q | 3 +
R/family.mixture.q | 159 ++-
R/family.nonlinear.q | 45 +-
R/family.normal.q | 94 +-
R/family.positive.q | 120 +-
R/family.qreg.q | 201 +--
R/family.rcqo.q | 14 +-
R/family.rrr.q | 12 +-
R/family.survival.q | 77 +-
R/family.ts.q | 39 +-
R/family.univariate.q | 3262 ++++++++++++++++++++++++++-----------------
R/family.zeroinf.q | 254 ++--
R/links.q | 367 +++--
R/plot.vglm.q | 19 +-
R/predict.vlm.q | 7 +-
R/summary.vgam.q | 14 +-
R/summary.vglm.q | 3 +
data/ruge.R | 5 +
man/AA.Aa.aa.Rd | 9 +-
man/AB.Ab.aB.ab.Rd | 7 +-
man/AB.Ab.aB.ab2.Rd | 9 +-
man/ABO.Rd | 9 +-
man/Coef.qrrvglm-class.Rd | 8 +-
man/Coef.qrrvglm.Rd | 13 +-
man/G1G2G3.Rd | 11 +-
man/Inv.gaussian.Rd | 27 +-
man/Links.Rd | 39 +-
man/MNSs.Rd | 7 +-
man/RayleighUC.Rd | 2 +
man/VGAM-package.Rd | 444 ------
man/acat.Rd | 7 +-
man/benini.Rd | 11 +-
man/betaII.Rd | 6 +
man/betabin.ab.Rd | 8 +-
man/betabinomial.Rd | 8 +-
man/betaff.Rd | 25 +-
man/betageometric.Rd | 6 +
man/betaprime.Rd | 7 +-
man/binom2.or.Rd | 29 +-
man/binom2.rho.Rd | 8 +-
man/binomialff.Rd | 15 +-
man/bisa.Rd | 14 +-
man/cauchy1.Rd | 7 +-
man/chisq.Rd | 12 +-
man/cratio.Rd | 8 +-
man/cumulative.Rd | 15 +-
man/dagum.Rd | 6 +
man/dcnormal1.Rd | 8 +-
man/dirichlet.Rd | 7 +-
man/dirmul.old.Rd | 8 +-
man/dirmultinomial.Rd | 8 +-
man/erlang.Rd | 7 +-
man/expexp.Rd | 6 +
man/expexp1.Rd | 26 +-
man/exponential.Rd | 12 +-
man/fff.Rd | 24 +-
man/fgm.Rd | 100 ++
man/fisk.Rd | 6 +
man/frank.Rd | 18 +-
man/frankUC.Rd | 5 +-
man/fsqrt.Rd | 167 +++
man/gamma1.Rd | 7 +-
man/gamma2.Rd | 6 +
man/gamma2.ab.Rd | 6 +
man/garma.Rd | 31 +-
man/genbetaII.Rd | 6 +
man/genpoisson.Rd | 6 +
man/geometric.Rd | 7 +-
man/gev.Rd | 4 +-
man/ggamma.Rd | 6 +
man/golf.Rd | 10 +-
man/gumbelIbiv.Rd | 96 ++
man/{hyper.Rd => hyperg.Rd} | 21 +-
man/hypersecant.Rd | 95 ++
man/hzeta.Rd | 11 +-
man/iam.Rd | 82 +-
man/identity.Rd | 4 +-
man/inv.gaussianff.Rd | 24 +-
man/invlomax.Rd | 6 +
man/invparalogistic.Rd | 6 +
man/leipnik.Rd | 16 +-
man/levy.Rd | 8 +-
man/lgammaff.Rd | 8 +-
man/lino.Rd | 10 +-
man/lms.bcg.Rd | 24 +-
man/lms.bcn.Rd | 22 +-
man/lms.yjn.Rd | 6 +
man/logff.Rd | 7 +-
man/logistic.Rd | 9 +-
man/loglinb2.Rd | 8 +-
man/loglinb3.Rd | 13 +-
man/lognormal.Rd | 14 +-
man/lomax.Rd | 6 +
man/maxwell.Rd | 7 +-
man/micmen.Rd | 6 +
man/mix2normal1.Rd | 9 +
man/mix2poisson.Rd | 8 +
man/morgenstern.Rd | 112 ++
man/multinomial.Rd | 5 +
man/nakagami.Rd | 8 +-
man/nbolf.Rd | 10 +-
man/negbinomial.Rd | 6 +
man/normal1.Rd | 8 +-
man/notdocumentedyet.Rd | 15 +-
man/ordpoisson.Rd | 158 +++
man/paralogistic.Rd | 6 +
man/pareto1.Rd | 9 +-
man/paretoIV.Rd | 8 +
man/poissonff.Rd | 11 +-
man/polf.Rd | 11 +-
man/posbinomUC.Rd | 2 +-
man/posbinomial.Rd | 7 +-
man/posnegbinomial.Rd | 8 +-
man/posnormal1.Rd | 6 +
man/pospoisUC.Rd | 2 +-
man/pospoisson.Rd | 7 +-
man/powl.Rd | 112 ++
man/prentice74.Rd | 6 +
man/rayleigh.Rd | 9 +-
man/rcqo.Rd | 9 +-
man/reciprocal.Rd | 4 +-
man/rig.Rd | 8 +-
man/ruge.Rd | 42 +
man/s.Rd | 2 +
man/simplex.Rd | 9 +-
man/sinmad.Rd | 6 +
man/skewnormal1.Rd | 7 +-
man/sratio.Rd | 8 +-
man/studentt.Rd | 11 +-
man/tikuv.Rd | 9 +-
man/tobit.Rd | 16 +-
man/uqo.Rd | 2 +-
man/venice.Rd | 11 +-
man/vonmises.Rd | 36 +-
man/wald.Rd | 7 +-
man/zanegbinomial.Rd | 6 +
man/zapoisson.Rd | 8 +-
man/zetaff.Rd | 7 +-
man/zibinomUC.Rd | 2 +-
man/zibinomial.Rd | 26 +-
man/zipf.Rd | 7 +-
man/zipoisUC.Rd | 2 +-
man/zipoisson.Rd | 22 +-
154 files changed, 6007 insertions(+), 3151 deletions(-)
diff --git a/DESCRIPTION b/DESCRIPTION
index 0cd64e2..d4dbf32 100755
--- a/DESCRIPTION
+++ b/DESCRIPTION
@@ -1,6 +1,6 @@
Package: VGAM
-Version: 0.7-1
-Date: 2006-10-24
+Version: 0.7-2
+Date: 2006-12-20
Title: Vector Generalized Linear and Additive Models
Author: Thomas W. Yee <t.yee at auckland.ac.nz>
Maintainer: Thomas Yee <t.yee at auckland.ac.nz>
@@ -15,4 +15,4 @@ License: GPL version 2
URL: http://www.stat.auckland.ac.nz/~yee/VGAM
LazyLoad: yes
LazyData: yes
-Packaged: Tue Oct 24 17:49:40 2006; yee
+Packaged: Wed Dec 20 13:59:01 2006; yee
diff --git a/NAMESPACE b/NAMESPACE
index a714643..35c1c38 100644
--- a/NAMESPACE
+++ b/NAMESPACE
@@ -22,6 +22,7 @@ export(
d2theta.deta2, Deviance.categorical.data.vgam,
lm2qrrvlm.model.matrix,
m2avglm,
+dotFortran, dotC,
dimm)
@@ -46,6 +47,7 @@ frechet2, frechet3, dfrechet, pfrechet, qfrechet, rfrechet,
frank, dfrank, pfrank, rfrank,
benini, dbenini, pbenini, qbenini, rbenini,
maxwell, dmaxwell, pmaxwell, qmaxwell, rmaxwell,
+morgenstern, fgm, gumbelIbiv,
erf, erfc, lerch,
tpareto1, dtpareto, qtpareto, rtpareto, ptpareto,
pareto1, dpareto, qpareto, rpareto, ppareto,
@@ -58,7 +60,7 @@ dgumbel, pgumbel, qgumbel, rgumbel,
cnormal1, dcnormal1,
recnormal1, recexp1,
crayleigh, rayleigh, drayleigh, prayleigh, qrayleigh, rrayleigh,
-dinv.gaussian, pinv.gaussian, wald, expexp1, expexp)
+dinv.gaussian, pinv.gaussian, rinv.gaussian, wald, expexp1, expexp)
export(A1A2A3, a2m, AAaa.nohw,
@@ -86,7 +88,8 @@ dtheta.deta)
export(cloglog,cauchit,elogit,fisherz,logc,loge,logit,logoff,nreciprocal,
probit,reciprocal,rhobit,
- golf,polf,nbolf,Cut)
+ golf,polf,nbolf,nbolf2,Cut)
+export(ordpoisson)
export(m2adefault,
@@ -94,8 +97,8 @@ erlang,
family.vglm,
fitted.values.uqo, fitted.vlm, fittedvsmooth.spline, fsqrt,
garma, gaussianff,
-hyper.secant,
-hyper,
+hypersecant, hypersecant.1,
+hyperg,
invbinomial, InverseBrat, inverse.gaussianff, inv.gaussianff,
is.Numeric,
mccullagh89, leipnik, levy,
@@ -132,7 +135,6 @@ qtplot.lms.bcn, qtplot.lms.yjn, qtplot.vextremes, qtplot.vglm,
rlplot,
rlplot.egev, rlplot.gev,
rlplot.vextremes, rlplot.vglm,
-quasiff,
rlplot, rlplot.vglm, rrar.control,
rrvglm.control.Gaussian)
@@ -182,6 +184,7 @@ export(dgpd, pgpd, qgpd, rgpd, gpd)
export(dgev, pgev, qgev, rgev, gev, egev)
export(dlaplace, plaplace, qlaplace, rlaplace)
export(fff, fff.control,
+ mbesselI0,
vonmises)
@@ -260,11 +263,13 @@ dzibinom, pzibinom, qzibinom, rzibinom, zibinomial)
-exportClasses("vglmff", "vlm", "vglm", "vgam", "summary.vgam",
-"summary.vglm","summary.vlm", "rrvglm", "qrrvglm", "grc",
-"vlmsmall", "uqo", "cao", "Coef.rrvglm",
-"Coef.uqo", "Coef.qrrvglm", "summary.qrrvglm",
-"vcov.qrrvglm", "summary.rrvglm",
+exportClasses("vglmff", "vlm", "vglm", "vgam",
+"rrvglm", "qrrvglm", "grc",
+"vlmsmall", "uqo", "cao",
+"summary.vgam", "summary.vglm","summary.vlm",
+"summary.qrrvglm", "summary.cao", "summary.rrvglm",
+"Coef.rrvglm", "Coef.uqo", "Coef.qrrvglm", "Coef.cao",
+"vcov.qrrvglm",
"vsmooth.spline.fit", "vsmooth.spline")
diff --git a/NEWS b/NEWS
index 2b9dad3..5736bd8 100755
--- a/NEWS
+++ b/NEWS
@@ -6,6 +6,39 @@
+ CHANGES IN VGAM VERSION 0.7-2
+
+NEW FEATURES
+
+ o Almost all VGAM family functions now have an earg-type argument
+ to support each link function. This allows parameters specific
+ to each link to be passed in,
+ e.g., VGAMfamilyfunction(link="logoff", earg=list(offset=1))
+ o rinv.gaussian() is new.
+ o New VGAM family functions: morgenstern(), fgm(), gumbelIbiv(),
+ ordpoisson().
+ o New documentation: powl(), fsqrt().
+
+BUG FIXES
+
+ o zanegbinomial()@last had wrong names in misc$link.
+ o summary(vgam.object) failed to print the anova table.
+ o summary(cao.object) failed.
+
+
+CHANGES
+
+ o binom2.or() has argument names changed from "lp" to "lmu" etc.
+ This is partly to make it in keeping with other VGAM family
+ functions for binary responses.
+ o Other VGAM family functions with argument names changed: frank().
+ o lms.bcn(), lms.bcg(), lms.yjn() arguments have changed order.
+ o hyper() renamed to hyperg().
+ o plotvgam() uses ylim if it is inputted.
+
+
+
+
CHANGES IN VGAM VERSION 0.7-1
NEW FEATURES
diff --git a/R/cao.fit.q b/R/cao.fit.q
index 4a6736a..7a45e45 100644
--- a/R/cao.fit.q
+++ b/R/cao.fit.q
@@ -472,7 +472,6 @@ if(exists("flush.console")) flush.console()
temp.smooth.frame = vector("list", p1+Rank) # A temporary makeshift frame
names(temp.smooth.frame) = c(names(control$colx1.index), mynames5)
- temp.smooth.frame[[1]] = rep(1, len=n) # Ideally should pass in x1mat
for(uu in 1:(p1+Rank)) {
temp.smooth.frame[[uu]] = nu1mat[,uu]
}
@@ -482,7 +481,7 @@ if(exists("flush.console")) flush.console()
attr(temp.smooth.frame[,uu+p1], "df") = 4 # this value unused
}
- pstar. = p1star. + p2star. # Mdot + Rank
+ pstar. = p1star. + p2star. # = Mdot + Rank
nstar = if(Nice21) ifelse(modelno==3 || modelno==5,n*2,n) else n*M
lenbeta = pstar. * ifelse(Nice21, NOS, 1) # Holds the linear coeffs
@@ -508,7 +507,7 @@ if(exists("flush.console")) flush.console()
nwhich = names(which) = mynames5
origBlist = Blist. = create.cms(Rank=Rank, M=M., MSratio=MSratio,
- which=which,p1=p1) # For 1 species
+ which=which, p1=p1) # For 1 species only
ncolBlist. <- unlist(lapply(Blist. , ncol))
smooth.frame = s.vam(x=nu1mat, z=NULL, wz=NULL, s=NULL,
which=which,
@@ -523,10 +522,8 @@ if(exists("flush.console")) flush.console()
all.knots=control$all.knots, nk=NULL,
sf.only=TRUE)
- ldk <- 4 * max(ncolBlist.[nwhich]) # was M; # Prior to 11/7/02
ldk <- 3 * max(ncolBlist.[nwhich]) + 1 # 11/7/02
-
dimw. = M. # Smoothing one spp. at a time
dimu. = M.
wz. = matrix(0, n, dimw. )
@@ -537,7 +534,6 @@ if(exists("flush.console")) flush.console()
trivc = rep(2 - M. , len=queue) # All of queue smooths are basic smooths
ncbvec <- ncolBlist.[nwhich]
ncolb <- max(ncbvec)
- pmax.mwk <- rep( dimw. , length(trivc))
pmax.mwk <- pmax(ncbvec*(ncbvec+1)/2, dimw. )
size.twk <- max((4+4*smooth.frame$nef)*ncbvec + dimu. * smooth.frame$nef)
size.twk <- max(size.twk, M*smooth.frame$n)
@@ -637,7 +633,7 @@ if(exists("flush.console")) flush.console()
ind7 = (smooth.frame$bindex[ii]):(smooth.frame$bindex[ii+1]-1)
ans = ans1$bcoeff[ind9+ind7]
ans = matrix(ans, ncol=ncolBlist[nwhich[ii]])
- Bspline[[ii]] = new("vsmooth.spline.fit",
+ Bspline[[ii]] = new(Class="vsmooth.spline.fit",
"Bcoefficients" = ans,
"xmax" = smooth.frame$xmax[ii],
"xmin" = smooth.frame$xmin[ii],
@@ -879,7 +875,7 @@ if(exists("flush.console")) flush.console()
ind9 = ind9[length(ind9)] + (bindex[i]):(bindex[i+1]-1)
ans = ans1$bcoeff[ind9]
ans = matrix(ans, ncol=ncolBlist[nwhich[i]])
- Bspline[[i]] = new("vsmooth.spline.fit",
+ Bspline[[i]] = new(Class="vsmooth.spline.fit",
"Bcoefficients" = ans,
"xmax" = smooth.frame$xmax[i],
"xmin" = smooth.frame$xmin[i],
@@ -916,6 +912,27 @@ if(exists("flush.console")) flush.console()
+
+setClass(Class="Coef.cao", representation(
+ "Bspline" = "list",
+ "C" = "matrix",
+ "Constrained" = "logical",
+ "df1.nl" = "numeric",
+ "df2.nl" = "numeric",
+ "dispersion" = "numeric",
+ "eta2" = "matrix",
+ "lv" = "matrix",
+ "lvOrder" = "matrix",
+ "M" = "numeric",
+ "Maximum" = "numeric",
+ "NOS" = "numeric",
+ "Optimum" = "matrix",
+ "OptimumOrder" = "matrix",
+ "Rank" = "numeric",
+ "spar1" = "numeric",
+ "spar2" = "numeric"))
+
+
Coef.cao = function(object,
epsOptimum = 0.00001, # determines how accurately Optimum is estimated
gridlen = 40, # Number of points on the grid (one level at a time)
@@ -1112,26 +1129,6 @@ Coef.cao = function(object,
}
-setClass("Coef.cao", representation(
- "Bspline" = "list",
- "C" = "matrix",
- "Constrained" = "logical",
- "df1.nl" = "numeric",
- "df2.nl" = "numeric",
- "dispersion" = "numeric",
- "eta2" = "matrix",
- "lv" = "matrix",
- "lvOrder" = "matrix",
- "M" = "numeric",
- "Maximum" = "numeric",
- "NOS" = "numeric",
- "Optimum" = "matrix",
- "OptimumOrder" = "matrix",
- "Rank" = "numeric",
- "spar1" = "numeric",
- "spar2" = "numeric"))
-
-
printCoef.cao = function(object, digits = max(2, options()$digits-2), ...) {
Rank = object at Rank
NOS = object at NOS
@@ -1734,7 +1731,7 @@ setMethod("lv", "Coef.cao", function(object, ...) lv.Coef.cao(object, ...))
-setClass("summary.cao", representation("Coef.cao",
+setClass(Class="summary.cao", representation("Coef.cao",
"misc" = "list",
"call" = "call"))
diff --git a/R/family.binomial.q b/R/family.binomial.q
index 084288d..353520b 100644
--- a/R/family.binomial.q
+++ b/R/family.binomial.q
@@ -57,7 +57,9 @@ process.binomial2.data.vgam <- expression({
-betabinomial <- function(lmu="logit", lrho="logit", irho=0.5, zero=2)
+betabinomial <- function(lmu="logit", lrho="logit",
+ emu=list(), erho=list(),
+ irho=0.5, zero=2)
{
if(mode(lmu) != "character" && mode(lmu) != "name")
lmu = as.character(substitute(lmu))
@@ -65,12 +67,14 @@ betabinomial <- function(lmu="logit", lrho="logit", irho=0.5, zero=2)
lrho = as.character(substitute(lrho))
if(length(irho) && (!is.Numeric(irho, positive=TRUE) || max(irho) >= 1))
stop("bad input for argument \"irho\"")
+ if(!is.list(emu )) emu = list()
+ if(!is.list(erho)) erho = list()
new("vglmff",
blurb=c("Beta-binomial model\n",
"Links: ",
- namesof("mu", lmu), ", ",
- namesof("rho", lrho), "\n",
+ namesof("mu", lmu, earg= emu), ", ",
+ namesof("rho", lrho, earg= erho), "\n",
"Variance: mu*(1-mu)*(1+(w-1)*rho)/w"),
constraints=eval(substitute(expression({
constraints <- cm.zero.vgam(constraints, x, .zero, M)
@@ -80,8 +84,8 @@ betabinomial <- function(lmu="logit", lrho="logit", irho=0.5, zero=2)
ycounts = y * w # Convert proportions to counts
if(max(abs(ycounts-round(ycounts))) > 1.0e-6)
stop("the response (as counts) does not appear to be integer-valued")
- predictors.names = c(namesof("mu", .lmu, tag=FALSE),
- namesof("rho", .lrho, tag=FALSE))
+ predictors.names = c(namesof("mu", .lmu, earg= .emu, tag=FALSE),
+ namesof("rho", .lrho, earg= .erho, tag=FALSE))
if(!length(etastart)) {
if(is.Numeric( .irho )) {
init.rho = rep( .irho, length=n)
@@ -103,23 +107,28 @@ betabinomial <- function(lmu="logit", lrho="logit", irho=0.5, zero=2)
init.rho = rep(try.this, len=n)
}
- etastart = cbind(theta2eta(mustart, .lmu),
- theta2eta(init.rho, .lrho))
+ etastart = cbind(theta2eta(mustart, .lmu, earg= .emu),
+ theta2eta(init.rho, .lrho, earg= .erho))
}
- }), list( .lmu=lmu, .lrho=lrho, .irho=irho ))),
+ }), list( .lmu=lmu, .lrho=lrho,
+ .emu=emu, .erho=erho,
+ .irho=irho ))),
inverse=eval(substitute(function(eta, extra=NULL)
- eta2theta(eta[,1], .lmu),
- list( .lmu=lmu ))),
+ eta2theta(eta[,1], .lmu, earg= .emu),
+ list( .lmu=lmu, .emu=emu ))),
last=eval(substitute(expression({
misc$link <- c(mu = .lmu, rho = .lrho)
+ misc$earg <- list(mu = .emu, rho = .erho)
misc$zero <- .zero
misc$expected <- TRUE
- }), list( .lmu=lmu, .lrho=lrho, .zero=zero ))),
+ }), list( .lmu=lmu, .lrho=lrho,
+ .emu=emu, .erho=erho,
+ .zero=zero ))),
loglikelihood=eval(substitute(
function(mu,y,w,residuals=FALSE, eta, extra=NULL) {
ycounts = y * w # Convert proportions to counts
- mymu = eta2theta(eta[,1], .lmu)
- rho = eta2theta(eta[,2], .lrho)
+ mymu = eta2theta(eta[,1], .lmu, earg= .emu)
+ rho = eta2theta(eta[,2], .lrho, earg= .erho)
shape1 = mymu * (1 - rho) / rho
shape2 = (1-mymu) * (1 - rho) / rho
nvec = w
@@ -130,21 +139,23 @@ betabinomial <- function(lmu="logit", lrho="logit", irho=0.5, zero=2)
lgamma(shape1+shape2+nvec) -
(lgamma(shape1) + lgamma(shape2) - lgamma(shape1+shape2)))
}
- }, list( .lmu=lmu, .lrho=lrho ))),
+ }, list( .lmu=lmu,
+ .emu=emu, .erho=erho,
+ .lrho=lrho ))),
vfamily=c("betabinomial"),
deriv=eval(substitute(expression({
nvec = w # extra$nvec # for summary()
ycounts = y * w # Convert proportions to counts
- mymu = eta2theta(eta[,1], .lmu)
- rho = eta2theta(eta[,2], .lrho)
+ mymu = eta2theta(eta[,1], .lmu, earg= .emu)
+ rho = eta2theta(eta[,2], .lrho, earg= .erho)
shape1 = mymu * (1 - rho) / rho
shape2 = (1-mymu) * (1 - rho) / rho
dshape1.dmu = (1 - rho) / rho
dshape2.dmu = -(1 - rho) / rho
dshape1.drho = -mymu / rho^2
dshape2.drho = -(1 - mymu) / rho^2
- dmu.deta = dtheta.deta(mymu, .lmu)
- drho.deta = dtheta.deta(rho, .lrho)
+ dmu.deta = dtheta.deta(mymu, .lmu, earg= .emu)
+ drho.deta = dtheta.deta(rho, .lrho, earg= .erho)
dl.dmu = dshape1.dmu * (digamma(shape1+ycounts) -
digamma(shape2+nvec-ycounts) -
digamma(shape1) + digamma(shape2))
@@ -155,7 +166,9 @@ betabinomial <- function(lmu="logit", lrho="logit", irho=0.5, zero=2)
(1-mymu)*digamma(shape2) + digamma(shape1+shape2))
temp5 = cbind(dl.dmu * dmu.deta, dl.drho * drho.deta)
temp5
- }), list( .lmu=lmu, .lrho=lrho ))),
+ }), list( .lmu=lmu,
+ .emu=emu, .erho=erho,
+ .lrho=lrho ))),
weight=eval(substitute(expression({
wz = matrix(as.numeric(NA), n, dimm(M)) #3=dimm(2)
wz11 = -(expected.betabin.ab(nvec, shape1, shape2, TRUE) -
@@ -175,7 +188,9 @@ betabinomial <- function(lmu="logit", lrho="logit", irho=0.5, zero=2)
(dshape1.dmu*(wz11*dshape1.drho + wz21*dshape2.drho) +
dshape2.dmu*(wz21*dshape1.drho + wz22*dshape2.drho))
wz
- }), list( .lmu=lmu, .lrho=lrho ))))
+ }), list( .lmu=lmu,
+ .emu=emu, .erho=erho,
+ .lrho=lrho ))))
}
@@ -184,26 +199,33 @@ betabinomial <- function(lmu="logit", lrho="logit", irho=0.5, zero=2)
-binom2.or <- function(lp="logit", lp1=lp, lp2=lp, lor="loge",
+binom2.or <- function(lmu="logit", lmu1=lmu, lmu2=lmu, lor="loge",
+ emu=list(), emu1=emu, emu2=emu, eor=list(),
zero=3, exchangeable=FALSE, tol=0.001)
{
- if(mode(lp1) != "character" && mode(lp1) != "name")
- lp1 <- as.character(substitute(lp1))
- if(mode(lp2) != "character" && mode(lp2) != "name")
- lp2 <- as.character(substitute(lp2))
+ if(mode(lmu) != "character" && mode(lmu) != "name")
+ lmu <- as.character(substitute(lmu))
+ if(mode(lmu1) != "character" && mode(lmu1) != "name")
+ lmu1 <- as.character(substitute(lmu1))
+ if(mode(lmu2) != "character" && mode(lmu2) != "name")
+ lmu2 <- as.character(substitute(lmu2))
if(mode(lor) != "character" && mode(lor) != "name")
lor <- as.character(substitute(lor))
- if(is.logical(exchangeable) && exchangeable && (lp1 != lp2))
+ if(is.logical(exchangeable) && exchangeable && ((lmu1 != lmu2) ||
+ !all.equal(emu1, emu2)))
stop("exchangeable=TRUE but marginal links are not equal")
if(!is.Numeric(tol, positive=TRUE, allow=1))
stop("bad input for argument \"tol\"")
+ if(!is.list(emu1)) emu1 = list()
+ if(!is.list(emu2)) emu2 = list()
+ if(!is.list(eor)) eor = list()
new("vglmff",
blurb=c("Palmgren model\n",
"Links: ",
- namesof("mu1", lp1), ", ",
- namesof("mu2", lp2), "; ",
- namesof("OR", lor)),
+ namesof("mu1", lmu1, earg=emu1), ", ",
+ namesof("mu2", lmu2, earg=emu2), "; ",
+ namesof("OR", lor, earg=eor)),
constraints=eval(substitute(expression({
constraints <- cm.vgam(matrix(c(1,1,0,0,0,1),3,2), x,
.exchangeable, constraints,
@@ -213,13 +235,16 @@ binom2.or <- function(lp="logit", lp1=lp, lp2=lp, lor="loge",
deviance=Deviance.categorical.data.vgam,
initialize=eval(substitute(expression({
eval(process.binomial2.data.vgam)
- predictors.names <- c(namesof("mu1", .lp1, short=TRUE),
- namesof("mu2", .lp2, short=TRUE),
- namesof("OR", .lor, short=TRUE))
- }), list( .lp1=lp1, .lp2=lp2, .lor=lor ))),
+ predictors.names <- c(namesof("mu1", .lmu1, earg= .emu1, short=TRUE),
+ namesof("mu2", .lmu2, earg= .emu2, short=TRUE),
+ namesof("OR", .lor, earg= .eor, short=TRUE))
+ }), list( .lmu1=lmu1, .lmu2=lmu2,
+ .emu1=emu1, .emu2=emu2, .eor=eor,
+ .lor=lor ))),
inverse=eval(substitute(function(eta, extra=NULL) {
- pm <- cbind(eta2theta(eta[,1], .lp1), eta2theta(eta[,2], .lp2))
- or <- eta2theta(eta[,3], .lor)
+ pm <- cbind(eta2theta(eta[,1], .lmu1, earg= .emu1),
+ eta2theta(eta[,2], .lmu2, earg= .emu2))
+ or <- eta2theta(eta[,3], .lor, earg= .eor)
a <- 1 + (pm[,1]+pm[,2])*(or-1)
b <- -4 * or * (or-1) * pm[,1] * pm[,2]
temp <- sqrt(a^2+b)
@@ -227,18 +252,25 @@ binom2.or <- function(lp="logit", lp1=lp, lp2=lp, lor="loge",
pj2 <- pm[,2] - pj4
pj3 <- pm[,1] - pj4
cbind("00" = 1-pj4-pj2-pj3, "01" = pj2, "10" = pj3, "11" = pj4)
- }, list( .tol=tol, .lp1=lp1, .lp2=lp2, .lor=lor ))),
+ }, list( .tol=tol, .lmu1=lmu1, .lmu2=lmu2,
+ .emu1=emu1, .emu2=emu2, .eor=eor,
+ .lor=lor ))),
last=eval(substitute(expression({
- misc$link <- c("mu1"= .lp1, "mu2"= .lp2, "OR"= .lor)
+ misc$link <- c("mu1"= .lmu1, "mu2"= .lmu2, "OR"= .lor)
+ misc$earg <- list(mu1 = .emu1, mu2 = .emu2, OR = .eor)
misc$tol <- .tol
- }), list( .tol=tol, .lp1=lp1, .lp2=lp2, .lor=lor ))),
+ }), list( .tol=tol, .lmu1=lmu1, .lmu2=lmu2,
+ .emu1=emu1, .emu2=emu2, .eor=eor,
+ .lor=lor ))),
link=eval(substitute(function(mu, extra=NULL) {
pm <- cbind(mu[,3]+mu[,4], mu[,2]+mu[,4])
or <- mu[,4]*mu[,1]/(mu[,2]*mu[,3])
- cbind(theta2eta(pm[,1], .lp1),
- theta2eta(pm[,2], .lp2),
- theta2eta(or, .lor))
- }, list( .lp1=lp1, .lp2=lp2, .lor=lor ))),
+ cbind(theta2eta(pm[,1], .lmu1, earg= .emu1),
+ theta2eta(pm[,2], .lmu2, earg= .emu2),
+ theta2eta(or, .lor, earg= .eor))
+ }, list( .lmu1=lmu1, .lmu2=lmu2,
+ .emu1=emu1, .emu2=emu2, .eor=eor,
+ .lor=lor ))),
loglikelihood= function(mu, y, w, residuals = FALSE, eta, extra=NULL)
if(residuals) stop("loglikelihood residuals not implemented yet") else
sum(w * y * log(mu)),
@@ -264,10 +296,12 @@ binom2.or <- function(lp="logit", lp1=lp, lp2=lp, lor="loge",
coeff * pm[,1] * (1-pm[,1]) * pm[,2] * (1-pm[,2]),
(1/(or-1)) * coeff * ( (pm[,1]+pm[,2])*(1-a/temp)/2 +
(2*or-1)*pm[,1]*pm[,2]/temp - (a-temp)/(2*(or-1)) ))
- w * cbind(d1 * dtheta.deta(pm[,1], .lp1),
- d2 * dtheta.deta(pm[,2], .lp2),
- d3 * dtheta.deta(or, .lor))
- }), list( .tol=tol, .lp1=lp1, .lp2=lp2, .lor=lor ))),
+ w * cbind(d1 * dtheta.deta(pm[,1], .lmu1, earg= .emu1),
+ d2 * dtheta.deta(pm[,2], .lmu2, earg= .emu2),
+ d3 * dtheta.deta(or, .lor, earg= .eor))
+ }), list( .tol=tol, .lmu1=lmu1, .lmu2=lmu2,
+ .emu1=emu1, .emu2=emu2, .eor=eor,
+ .lor=lor ))),
weight=eval(substitute(expression({
Vab <- 1/(1/mu[,1] + 1/mu[,2] + 1/mu[,3] + 1/mu[,4])
deltapi <- mu[,3]*mu[,2] - mu[,4]*mu[,1]
@@ -275,14 +309,19 @@ binom2.or <- function(lp="logit", lp1=lp, lp2=lp, lor="loge",
pq <- pm[,1:2]*(1-pm[,1:2])
wz <- matrix(0, n, 4)
- wz[,iam(1,1,M)] <- dtheta.deta(pm[,1], .lp1)^2 * pq[,2] * Vab / delta
- wz[,iam(2,2,M)] <- dtheta.deta(pm[,2], .lp2)^2 * pq[,1] * Vab / delta
- wz[,iam(3,3,M)] <- Vab * (dtheta.deta(or, .lor) /
- dtheta.deta(or, "loge"))^2
- wz[,iam(1,2,M)] <- Vab * deltapi * dtheta.deta(pm[,1], .lp1) *
- dtheta.deta(pm[,2], .lp2) / delta
+ wz[,iam(1,1,M)] <- dtheta.deta(pm[,1], .lmu1, earg= .emu1)^2 *
+ pq[,2] * Vab / delta
+ wz[,iam(2,2,M)] <- dtheta.deta(pm[,2], .lmu2, earg= .emu2)^2 *
+ pq[,1] * Vab / delta
+ wz[,iam(3,3,M)] <- Vab *
+ (dtheta.deta(or, .lor, earg= .eor) / dtheta.deta(or, "loge"))^2
+ wz[,iam(1,2,M)] <- Vab * deltapi *
+ dtheta.deta(pm[,1], .lmu1, earg= .emu1) *
+ dtheta.deta(pm[,2], .lmu2, earg= .emu2) / delta
w * wz
- }), list( .lp1=lp1, .lp2=lp2, .lor=lor ))))
+ }), list( .lmu1=lmu1, .lmu2=lmu2,
+ .emu1=emu1, .emu2=emu2, .eor=eor,
+ .lor=lor ))))
}
@@ -290,17 +329,19 @@ binom2.or <- function(lp="logit", lp1=lp, lp2=lp, lor="loge",
-binom2.rho <- function(lrho="rhobit", init.rho=0.4, zero=3, exchangeable=FALSE)
+binom2.rho <- function(lrho="rhobit", erho=list(),
+ init.rho=0.4, zero=3, exchangeable=FALSE)
{
if(mode(lrho) != "character" && mode(lrho) != "name")
lrho <- as.character(substitute(lrho))
+ if(!is.list(erho)) erho = list()
new("vglmff",
blurb=c("Bivariate probit model\n",
"Links: ",
"probit(mu1), probit(mu2); ",
- namesof("rho", lrho)),
+ namesof("rho", lrho, earg= erho)),
constraints=eval(substitute(expression({
constraints <- cm.vgam(matrix(c(1,1,0,0,0,1),3,2), x,
.exchangeable, constraints, intercept.apply=TRUE)
@@ -309,37 +350,40 @@ binom2.rho <- function(lrho="rhobit", init.rho=0.4, zero=3, exchangeable=FALSE)
deviance=Deviance.categorical.data.vgam,
initialize=eval(substitute(expression({
eval(process.binomial2.data.vgam)
- predictors.names <- c("probit(mu1)", "probit(mu2)",
- namesof("rho", .lrho, short=TRUE))
+ predictors.names <- c(
+ namesof("mu1", "probit", earg= list(), short=TRUE),
+ namesof("mu2", "probit", earg= list(), short=TRUE),
+ namesof("rho", .lrho, earg= .erho, short=TRUE))
if(is.null(etastart))
- etastart <- cbind(theta2eta(mu[,3]+mu[,4], "probit"),
- theta2eta(mu[,2]+mu[,4], "probit"),
- theta2eta(.init.rho, .lrho))
- }), list( .lrho=lrho, .init.rho=init.rho ))),
+ etastart <- cbind(theta2eta(mu[,3]+mu[,4], "probit", earg= list()),
+ theta2eta(mu[,2]+mu[,4], "probit", earg= list()),
+ theta2eta(.init.rho, .lrho, earg= .erho))
+ }), list( .lrho=lrho, .erho=erho, .init.rho=init.rho ))),
inverse=eval(substitute(function(eta, extra=NULL) {
pm <- cbind(pnorm(eta[,1]),pnorm(eta[,2]))
- rho <- eta2theta(eta[,3], .lrho)
+ rho <- eta2theta(eta[,3], .lrho, earg= .erho)
p11 <- pnorm2(eta[,1], eta[,2], rho)
p01 <- pm[,2]-p11
p10 <- pm[,1]-p11
p00 <- 1-p01-p10-p11
cbind("00"=p00, "01"=p01, "10"=p10, "11"=p11)
- }, list( .lrho=lrho ))),
+ }, list( .lrho=lrho, .erho=erho ))),
last=eval(substitute(expression({
misc$link <- c(mu1 = "probit", mu2 = "probit", rho = .lrho)
- }), list( .lrho=lrho ))),
+ misc$earg <- list(mu1 = list(), mu2 = list(), rho = .erho)
+ }), list( .lrho=lrho, .erho=erho ))),
link=eval(substitute(function(mu, extra=NULL) {
if(is.null(extra))
stop("rho must be passed into $link through \"extra\"")
pm <- cbind(mu[,3]+mu[,4], mu[,2]+mu[,4])
- cbind("probit(mu1)"=qnorm(pm[,1]),
+ cbind("probit(mu1)"=qnorm(pm[,1]),
"probit(mu2)"=qnorm(pm[,2]),
- "link(rho)"=theta2eta(extra, .lrho))
- }, list( .lrho=lrho ))),
+ "link(rho)"=theta2eta(extra, .lrho, earg= .erho))
+ }, list( .lrho=lrho, .erho=erho ))),
vfamily=c("binom2.rho", "binom2"),
deriv=eval(substitute(expression({
pm <- cbind(pnorm(eta[,1]),pnorm(eta[,2]))
- rho <- eta2theta(eta[,3], .lrho)
+ rho <- eta2theta(eta[,3], .lrho, earg= .erho)
p11 <- pnorm2(eta[,1], eta[,2], rho)
p01 <- pm[,2]-p11
p10 <- pm[,1]-p11
@@ -356,9 +400,9 @@ binom2.rho <- function(lrho="rhobit", init.rho=0.4, zero=3, exchangeable=FALSE)
d1 = phi1*(PhiB*(y[,4]/p11-y[,2]/p01) + (1-PhiB)*(y[,3]/p10-y[,1]/p00))
d2 = phi2*(PhiA*(y[,4]/p11-y[,3]/p10) + (1-PhiA)*(y[,2]/p01-y[,1]/p00))
dl.drho <- (y[,4]/p11-y[,3]/p10-y[,2]/p01+y[,1]/p00)* ff
- drho.deta <- dtheta.deta(rho, .lrho)
+ drho.deta <- dtheta.deta(rho, .lrho, earg= .erho)
w * cbind(d1, d2, dl.drho * drho.deta)
- }), list( .lrho=lrho ))),
+ }), list( .lrho=lrho, .erho=erho ))),
weight=eval(substitute(expression({
wz <- matrix(as.numeric(NA), n, dimm(M)) # 6=dimm(M)
wz[,iam(1,1,M)] = phi1^2*(PhiB^2*(1/p11+1/p01)+(1-PhiB)^2*(1/p10+1/p00))
@@ -372,7 +416,7 @@ binom2.rho <- function(lrho="rhobit", init.rho=0.4, zero=3, exchangeable=FALSE)
d2l.drho2 <- ff^2 * (1/p11+1/p01+1/p10+1/p00)
wz[,iam(3,3,M)] <- d2l.drho2 * drho.deta^2
wz * w
- }), list( .lrho=lrho ))))
+ }), list( .lrho=lrho, .erho=erho ))))
}
@@ -407,11 +451,12 @@ my.dbinom <- function(x,
-size.binomial <- function(prob=0.5, link="loge")
+size.binomial <- function(prob=0.5, link="loge", earg=list())
{
if(any(prob<=0 || prob>=1))
stop("some values of prob out of range")
if(!missing(link)) link <- as.character(substitute(link))
+ if(!is.list(earg)) earg = list()
new("vglmff",
blurb=c("Binomial with n unknown, prob known (prob=",prob,")\n",
@@ -574,19 +619,21 @@ expected.betabin.ab = function(nvec, shape1, shape2, first) {
-betabin.ab = function(link.shape12="loge", i1=1, i2=NULL, zero=NULL)
+betabin.ab = function(link.shape12="loge", earg = list(),
+ i1=1, i2=NULL, zero=NULL)
{
if(mode(link.shape12) != "character" && mode(link.shape12) != "name")
link.shape12 = as.character(substitute(link.shape12))
if(!is.Numeric(i1, positive=TRUE)) stop("bad input for argument \"i1\"")
if(length(i2) && !is.Numeric(i2, pos=TRUE))
stop("bad input for argument \"i2\"")
+ if(!is.list(earg)) earg = list()
new("vglmff",
blurb=c("Beta-binomial model\n",
"Links: ",
- namesof("shape1", link.shape12), ", ",
- namesof("shape2", link.shape12), "\n",
+ namesof("shape1", link.shape12, earg= earg), ", ",
+ namesof("shape2", link.shape12, earg= earg), "\n",
"Variance: mu*(1-mu)[1+(w-1)*rho]/w where mu=alpha/(alpha+beta)"),
constraints=eval(substitute(expression({
constraints <- cm.zero.vgam(constraints, x, .zero, M)
@@ -594,8 +641,8 @@ betabin.ab = function(link.shape12="loge", i1=1, i2=NULL, zero=NULL)
initialize=eval(substitute(expression({
# Compute initial values for mustart -------
eval(binomialff()@initialize) # Note: n,w,y,mustart is changed
- predictors.names = c(namesof("shape1", .link.shape12, tag=FALSE),
- namesof("shape2", .link.shape12, short=FALSE))
+ predictors.names = c(namesof("shape1", .link.shape12, earg= .earg, tag=FALSE),
+ namesof("shape2", .link.shape12, earg= .earg, short=FALSE))
if(!length(etastart)) {
shape1 = rep( .i1, len=n)
@@ -604,27 +651,28 @@ betabin.ab = function(link.shape12="loge", i1=1, i2=NULL, zero=NULL)
if(max(abs(ycounts-round(ycounts))) > 1.0e-6)
stop("ycounts not integer")
ycounts = round(ycounts) # Make sure it is an integer
- etastart = cbind(theta2eta(shape1, .link.shape12),
- theta2eta(shape2, .link.shape12))
+ etastart = cbind(theta2eta(shape1, .link.shape12, earg= .earg),
+ theta2eta(shape2, .link.shape12, earg= .earg))
}
- }), list( .link.shape12=link.shape12, .i1=i1 , .i2=i2 ))),
+ }), list( .link.shape12=link.shape12, .earg=earg, .i1=i1 , .i2=i2 ))),
inverse=eval(substitute(function(eta, extra=NULL) {
- shape1 = eta2theta(eta[,1], .link.shape12)
- shape2 = eta2theta(eta[,2], .link.shape12)
+ shape1 = eta2theta(eta[,1], .link.shape12, earg= .earg)
+ shape2 = eta2theta(eta[,2], .link.shape12, earg= .earg)
shape1 / (shape1 + shape2)
- }, list( .link.shape12=link.shape12 ))),
+ }, list( .link.shape12=link.shape12, .earg=earg ))),
last=eval(substitute(expression({
misc$link = c("shape1" = .link.shape12, "shape2" = .link.shape12)
- shape1 = eta2theta(eta[,1], .link.shape12)
- shape2 = eta2theta(eta[,2], .link.shape12)
+ misc$earg <- list(shape1 = .earg, shape2 = .earg)
+ shape1 = eta2theta(eta[,1], .link.shape12, earg= .earg)
+ shape2 = eta2theta(eta[,2], .link.shape12, earg= .earg)
misc$rho = 1 / (shape1 + shape2 + 1)
misc$expected = TRUE
- }), list( .link.shape12=link.shape12 ))),
+ }), list( .link.shape12=link.shape12, .earg=earg ))),
loglikelihood=eval(substitute(
function(mu,y,w,residuals=FALSE,eta, extra=NULL) {
ycounts = y * w # Convert proportions to counts
- shape1 = eta2theta(eta[,1], .link.shape12)
- shape2 = eta2theta(eta[,2], .link.shape12)
+ shape1 = eta2theta(eta[,1], .link.shape12, earg= .earg)
+ shape2 = eta2theta(eta[,2], .link.shape12, earg= .earg)
nvec = w
if(residuals) stop("loglikelihood residuals not implemented yet") else {
if(is.R()) sum(lbeta(shape1+ycounts, shape2+nvec-ycounts) -
@@ -633,22 +681,22 @@ betabin.ab = function(link.shape12="loge", i1=1, i2=NULL, zero=NULL)
lgamma(shape1+shape2+nvec) -
(lgamma(shape1) + lgamma(shape2) - lgamma(shape1+shape2)))
}
- }, list( .link.shape12=link.shape12 ))),
+ }, list( .link.shape12=link.shape12, .earg=earg ))),
vfamily=c("betabin.ab"),
deriv=eval(substitute(expression({
nvec = w # extra$nvec # for summary()
ycounts = y * w # Convert proportions to counts
- shape1 = eta2theta(eta[,1], .link.shape12)
- shape2 = eta2theta(eta[,2], .link.shape12)
- dshape1.deta = dtheta.deta(shape1, .link.shape12)
- dshape2.deta = dtheta.deta(shape2, .link.shape12)
+ shape1 = eta2theta(eta[,1], .link.shape12, earg= .earg)
+ shape2 = eta2theta(eta[,2], .link.shape12, earg= .earg)
+ dshape1.deta = dtheta.deta(shape1, .link.shape12, earg= .earg)
+ dshape2.deta = dtheta.deta(shape2, .link.shape12, earg= .earg)
dl.dshape1 = digamma(shape1+ycounts) - digamma(shape1+shape2+nvec) -
digamma(shape1) + digamma(shape1+shape2)
dl.dshape2 = digamma(nvec+shape2-ycounts) -
digamma(shape1+shape2+nvec) -
digamma(shape2) + digamma(shape1+shape2)
cbind(dl.dshape1 * dshape1.deta, dl.dshape2 * dshape2.deta)
- }), list( .link.shape12=link.shape12 ))),
+ }), list( .link.shape12=link.shape12, .earg=earg ))),
weight=eval(substitute(expression({
wz = matrix(as.numeric(NA), n, dimm(M)) #3=dimm(2)
wz[,iam(1,1,M)] = -(expected.betabin.ab(nvec, shape1, shape2, TRUE) -
@@ -663,12 +711,13 @@ betabin.ab = function(link.shape12="loge", i1=1, i2=NULL, zero=NULL)
trigamma(shape1+shape2+nvec)) *
dshape1.deta * dshape2.deta
wz
- }), list( .link.shape12=link.shape12 ))))
+ }), list( .link.shape12=link.shape12, .earg=earg ))))
}
betageometric = function(lprob="logit", lshape="loge",
+ eprob=list(), eshape=list(),
iprob = NULL, ishape = 0.1,
moreSummation=c(2,100), tolerance=1.0e-10, zero=NULL)
{
@@ -682,34 +731,40 @@ betageometric = function(lprob="logit", lshape="loge",
stop("bad input for argument \"moreSummation\"")
if(!is.Numeric(tolerance, positive=TRUE, allow=1) || 1.0-tolerance >= 1.0)
stop("bad input for argument \"tolerance\"")
+ if(!is.list(eprob)) eprob = list()
+ if(!is.list(eshape)) eshape = list()
new("vglmff",
blurb=c("Beta-geometric distribution\n",
- "Links: ", namesof("prob", lprob), ", ",
- namesof("shape", lshape)),
+ "Links: ", namesof("prob", lprob, earg= eprob), ", ",
+ namesof("shape", lshape, earg= eshape)),
constraints=eval(substitute(expression({
constraints <- cm.zero.vgam(constraints, x, .zero, M)
}), list( .zero=zero ))),
initialize=eval(substitute(expression({
eval(geometric()@initialize)
- predictors.names = c(namesof("prob", .lprob, tag=FALSE),
- namesof("shape", .lshape, short=FALSE))
+ predictors.names = c(namesof("prob", .lprob, earg= .eprob, tag=FALSE),
+ namesof("shape", .lshape, earg= .eshape, short=FALSE))
if(length( .iprob))
prob.init = rep( .iprob, len=n)
if(!length(etastart) || ncol(cbind(etastart)) != 2) {
shape.init = rep( .ishape, len=n)
- etastart = cbind(theta2eta(prob.init, .lprob),
- theta2eta(shape.init, .lshape))
+ etastart = cbind(theta2eta(prob.init, .lprob, earg= .eprob),
+ theta2eta(shape.init, .lshape, earg= .eshape))
}
- }), list( .iprob=iprob, .ishape=ishape, .lprob=lprob, .lshape=lshape ))),
+ }), list( .iprob=iprob, .ishape=ishape, .lprob=lprob,
+ .eprob=eprob, .eshape=eshape,
+ .lshape=lshape ))),
inverse=eval(substitute(function(eta, extra=NULL) {
- prob = eta2theta(eta[,1], .lprob)
- shape = eta2theta(eta[,2], .lshape)
+ prob = eta2theta(eta[,1], .lprob, earg= .eprob)
+ shape = eta2theta(eta[,2], .lshape, earg= .eshape)
mymu = (1-prob) / (prob - shape)
ifelse(mymu >= 0, mymu, NA)
- }, list( .lprob=lprob, .lshape=lshape ))),
+ }, list( .lprob=lprob, .lshape=lshape,
+ .eprob=eprob, .eshape=eshape ))),
last=eval(substitute(expression({
misc$link = c("prob" = .lprob, "shape" = .lshape)
+ misc$earg <- list(prob = .eprob, shape = .eshape)
if(intercept.only) {
misc$shape1 = shape1[1] # These quantities computed in @deriv
misc$shape2 = shape2[1]
@@ -719,11 +774,12 @@ betageometric = function(lprob="logit", lshape="loge",
misc$zero = .zero
misc$moreSummation = .moreSummation
}), list( .lprob=lprob, .lshape=lshape, .tolerance=tolerance,
+ .eprob=eprob, .eshape=eshape,
.moreSummation=moreSummation, .zero=zero ))),
loglikelihood=eval(substitute(
function(mu,y,w,residuals=FALSE,eta, extra=NULL) {
- prob = eta2theta(eta[,1], .lprob)
- shape = eta2theta(eta[,2], .lshape)
+ prob = eta2theta(eta[,1], .lprob, earg= .eprob)
+ shape = eta2theta(eta[,2], .lshape, earg= .eshape)
ans = log(prob)
maxy = max(y)
if(residuals) stop("loglikelihood residuals not implemented yet") else {
@@ -735,14 +791,15 @@ betageometric = function(lprob="logit", lshape="loge",
ans = ans - log(1+(y+1-1)*shape)
sum(w * ans)
}
- }, list( .lprob=lprob, .lshape=lshape ))),
+ }, list( .lprob=lprob, .lshape=lshape,
+ .eprob=eprob, .eshape=eshape ))),
vfamily=c("betageometric"),
deriv=eval(substitute(expression({
- prob = eta2theta(eta[,1], .lprob)
- shape = eta2theta(eta[,2], .lshape)
+ prob = eta2theta(eta[,1], .lprob, earg= .eprob)
+ shape = eta2theta(eta[,2], .lshape, earg= .eshape)
shape1 = prob / shape; shape2 = (1-prob) / shape;
- dprob.deta = dtheta.deta(prob, .lprob)
- dshape.deta = dtheta.deta(shape, .lshape)
+ dprob.deta = dtheta.deta(prob, .lprob, earg= .eprob)
+ dshape.deta = dtheta.deta(shape, .lshape, earg= .eshape)
dl.dprob = 1 / prob
dl.dshape = 0 * y
maxy = max(y)
@@ -756,7 +813,8 @@ betageometric = function(lprob="logit", lshape="loge",
}
dl.dshape = dl.dshape - (y+1 -1)/(1+(y+1 -1)*shape)
w * cbind(dl.dprob * dprob.deta, dl.dshape * dshape.deta)
- }), list( .lprob=lprob, .lshape=lshape ))),
+ }), list( .lprob=lprob, .lshape=lshape,
+ .eprob=eprob, .eshape=eshape ))),
weight=eval(substitute(expression({
wz = matrix(0, n, dimm(M)) #3=dimm(2)
wz[,iam(1,1,M)] = 1 / prob^2
@@ -783,6 +841,7 @@ betageometric = function(lprob="logit", lshape="loge",
wz[,iam(2,1,M)] = wz[,iam(2,1,M)] * dprob.deta * dshape.deta
w * wz
}), list( .lprob=lprob, .lshape=lshape, .moreSummation=moreSummation,
+ .eprob=eprob, .eshape=eshape,
.tolerance=tolerance ))))
}
diff --git a/R/family.bivariate.q b/R/family.bivariate.q
index 2d8af1d..7ff1016 100644
--- a/R/family.bivariate.q
+++ b/R/family.bivariate.q
@@ -471,81 +471,83 @@ dfrank = function(x1, x2, alpha) {
-frank = function(lcorp="loge", icorp=2) {
- if(mode(lcorp) != "character" && mode(lcorp) != "name")
- lcorp = as.character(substitute(lcorp))
- if(!is.Numeric(icorp, positive = TRUE))
- stop("\"icorp\" must be positive")
+frank = function(lapar="loge", eapar=list(), iapar=2) {
+ 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()
new("vglmff",
blurb=c("Frank's Bivariate Distribution\n",
"Links: ",
- namesof("corp", lcorp)),
+ namesof("apar", lapar, earg= eapar )),
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 between 0 and 1")
- predictors.names = c(namesof("corp", .lcorp, short=TRUE))
+ predictors.names = c(namesof("apar", .lapar, earg= .eapar, short=TRUE))
if(!length(etastart)) {
- corp.init = rep(.icorp, len=n)
- etastart = cbind(theta2eta(corp.init, .lcorp))
+ apar.init = rep(.iapar, len=n)
+ etastart = cbind(theta2eta(apar.init, .lapar, earg= .eapar ))
}
- }), list(.lcorp=lcorp, .icorp=icorp))),
+ }), list( .lapar=lapar, .eapar=eapar, .iapar=iapar))),
inverse=eval(substitute(function(eta, extra=NULL) {
- corp = eta2theta(eta, .lcorp)
+ apar = eta2theta(eta, .lapar, earg= .eapar )
cbind(rep(0.5, len=length(eta)), rep(0.5, len=length(eta)))
- }, list(.lcorp=lcorp))),
+ }, list(.lapar=lapar, .eapar=eapar ))),
last=eval(substitute(expression({
- misc$link = c("corp"= .lcorp)
+ misc$link = c("apar"= .lapar)
+ misc$earg = list("apar"= .eapar )
misc$pooled.weight = pooled.weight
- }), list(.lcorp=lcorp))),
+ }), list(.lapar=lapar, .eapar=eapar ))),
loglikelihood= eval(substitute(
function(mu, y, w, residuals = FALSE, eta, extra=NULL) {
- corp = eta2theta(eta, .lcorp)
+ apar = eta2theta(eta, .lapar, earg= .eapar )
if(residuals) stop("loglikelihood residuals not implemented yet") else {
- denom = corp-1 + (corp^y[,1] -1) * (corp^y[,2] -1)
+ denom = apar-1 + (apar^y[,1] -1) * (apar^y[,2] -1)
denom = abs(denom) # Needed; Genest (1987) uses this too, eqn (4.1)
- sum(w * (log((corp-1) * log(corp)) + (y[,1]+y[,2])*log(corp) -
+ sum(w * (log((apar-1) * log(apar)) + (y[,1]+y[,2])*log(apar) -
2 * log(denom)))
}
- }, list(.lcorp=lcorp))),
+ }, list(.lapar=lapar, .eapar=eapar ))),
vfamily=c("frank"),
deriv=eval(substitute(expression({
- corp = eta2theta(eta, .lcorp)
- denom = corp-1 + (corp^y[,1] -1) * (corp^y[,2] -1)
- tmp700 = 2*corp^(y[,1]+y[,2]) - corp^y[,1] - corp^y[,2]
- numerator = 1 + y[,1] * corp^(y[,1]-1) * (corp^y[,2] -1) +
- y[,2] * corp^(y[,2]-1) * (corp^y[,1] -1)
- Dl.dcorp = 1/(corp-1) + 1/(corp*log(corp)) + (y[,1]+y[,2])/corp -
+ apar = eta2theta(eta, .lapar, earg= .eapar )
+ 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
- dcorp.deta = dtheta.deta(corp, .lcorp)
+ dapar.deta = dtheta.deta(apar, .lapar, earg= .eapar )
- w * Dl.dcorp * dcorp.deta
- }), list(.lcorp=lcorp))),
+ w * Dl.dapar * dapar.deta
+ }), list(.lapar=lapar, .eapar=eapar ))),
weight=eval(substitute(expression({
- nump = corp^(y[,1]+y[,2]-2) * (2 * y[,1] * y[,2] +
+ 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) * corp^(y[,1]-2) -
- y[,2]*(y[,2]-1) * corp^(y[,2]-2)
- D2l.dcorp2 = 1/(corp-1)^2 + (1+log(corp))/(corp*log(corp))^2 +
- (y[,1]+y[,2])/corp^2 + 2 *
+ y[,1]*(y[,1]-1) * apar^(y[,1]-2) -
+ y[,2]*(y[,2]-1) * apar^(y[,2]-2)
+ D2l.dapar2 = 1/(apar-1)^2 + (1+log(apar))/(apar*log(apar))^2 +
+ (y[,1]+y[,2])/apar^2 + 2 *
(nump / denom - (numerator/denom)^2)
- d2corp.deta2 = d2theta.deta2(corp, .lcorp)
- wz = w * (dcorp.deta^2 * D2l.dcorp2 - Dl.dcorp * d2corp.deta2)
+ 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)
- for(i in 1:ncol(wz))
- wz[,i] = sum(wz[,i]) / sumw
+ 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(.lcorp=lcorp))))
+ }), list( .lapar=lapar, .eapar=eapar ))))
}
@@ -611,5 +613,291 @@ gammahyp = function(ltheta="loge", itheta=NULL, expected=FALSE) {
+morgenstern = function(lapar="rhobit", earg=list(), iapar=NULL, tola0=0.01,
+ method.init=1) {
+ if(mode(lapar) != "character" && mode(lapar) != "name")
+ lapar = as.character(substitute(lapar))
+ if(!is.list(earg)) earg = list()
+ if(length(iapar) && (!is.Numeric(iapar, allow=1) || abs(iapar) >= 1))
+ stop("'iapar' must be a single number between -1 and 1")
+ if(!is.Numeric(tola0, allow=1, posit=TRUE))
+ stop("'tola0' must be a single positive number")
+ if(length(iapar) && abs(iapar) <= tola0)
+ stop("'iapar' must not be between -tola0 and tola0")
+ if(!is.Numeric(method.init, allow=1, integ=TRUE, positi=TRUE) ||
+ method.init > 2.5)
+ stop("argument \"method.init\" must be 1 or 2")
+
+ new("vglmff",
+ blurb=c("Morgenstern's Bivariate Exponential Distribution\n",
+ "Links: ",
+ namesof("apar", lapar, 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))
+ stop("the response must have non-negative values only")
+ predictors.names = c(namesof("apar", .lapar, earg= .earg , short=TRUE))
+ if(!length(etastart)) {
+ ainit = if(length(.iapar)) rep(.iapar, len=n) else {
+ mean1 = if( .method.init == 1) median(y[,1]) else mean(y[,1])
+ mean2 = if( .method.init == 1) median(y[,2]) else mean(y[,2])
+ 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)))
+ }
+ 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(1, len=length(alpha)),
+ rep(1, len=length(alpha)))
+ }, 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 ))),
+ loglikelihood= eval(substitute(
+ function(mu, y, w, residuals = FALSE, eta, extra=NULL) {
+ alpha = eta2theta(eta, .lapar, earg= .earg )
+ alpha[abs(alpha) < .tola0 ] = .tola0
+ if(residuals) stop("loglikelihood residuals not implemented yet") else {
+ denom = (1 + alpha - 2*alpha*(exp(-y[,1]) + exp(-y[,2])) +
+ 4*alpha*exp(-y[,1] - y[,2]))
+ sum(w * (-y[,1] - y[,2] + log(denom)))
+ }
+ }, list( .lapar=lapar, .earg=earg, .tola0=tola0 ))),
+ vfamily=c("morgenstern"),
+ deriv=eval(substitute(expression({
+ alpha = eta2theta(eta, .lapar, earg= .earg )
+ alpha[abs(alpha) < .tola0 ] = .tola0
+ numerator = 1 - 2*(exp(-y[,1]) + exp(-y[,2])) + 4*exp(-y[,1] - y[,2])
+ denom = (1 + alpha - 2*alpha*(exp(-y[,1]) + exp(-y[,2])) +
+ 4 *alpha*exp(-y[,1] - y[,2]))
+ dl.dalpha = numerator / denom
+ dalpha.deta = dtheta.deta(alpha, .lapar, earg= .earg )
+ w * cbind(dl.dalpha * dalpha.deta)
+ }), list( .lapar=lapar, .earg=earg, .tola0=tola0 ))),
+ 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 ))))
+}
+
+
+
+
+dfgm = function(x1, x2, alpha) {
+ if(!is.Numeric(alpha)) stop("bad input for \"alpha\"")
+ if(any(alpha < -1 | alpha > 1)) stop("\"alpha\" values out of range")
+ 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
+}
+
+
+
+fgm = function(lapar="identity", earg=list(), iapar=NULL,
+ method.init=1) { # , tola0=0.01
+ 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")
+
+ new("vglmff",
+ blurb=c("Farlie-Gumbel-Morgenstern Distribution\n",
+ "Links: ",
+ namesof("apar", lapar, 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("apar", .lapar, earg= .earg, short=TRUE)
+ if(!length(etastart)) {
+ ainit = if(length( .iapar )) rep( .iapar, len=n) else {
+ mean1 = if( .method.init == 1) median(y[,1]) else mean(y[,1])
+ mean2 = if( .method.init == 1) median(y[,2]) else mean(y[,2])
+ Finit = 0.01 + mean(y[,1] <= mean1 & y[,2] <= mean2)
+ (Finit / (mean1 * mean2) - 1) / ((1-mean1) * (1-mean2))
+ }
+ 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)))
+ }, 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 ))),
+ 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
+ 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]))
+ }
+ }, list( .lapar=lapar, .earg=earg ))),
+ vfamily=c("fgm"),
+ deriv=eval(substitute(expression({
+ alpha = eta2theta(eta, .lapar, earg= .earg )
+ numerator = (1 - 2 * y[,1]) * (1 - 2 * y[,2])
+ denom = 1 + alpha * numerator
+ mytolerance = .Machine$double.eps
+ bad <- (denom <= mytolerance) # Range violation
+ if(any(bad)) {
+ cat("There are some range violations in @deriv\n")
+ if(exists("flush.console")) flush.console()
+ 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 ))),
+ 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 ))))
+}
+
+
+
+gumbelIbiv = function(lapar="identity", earg=list(), iapar=NULL, method.init=1) {
+ 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")
+
+ new("vglmff",
+ blurb=c("Gumbel's Type I Bivariate Distribution\n",
+ "Links: ",
+ namesof("apar", lapar, 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))
+ stop("the response must have non-negative values only")
+ predictors.names = c(namesof("apar", .lapar, earg= .earg , short=TRUE))
+ if(!length(etastart)) {
+ ainit = if(length( .iapar )) rep( .iapar, len=n) else {
+ mean1 = if( .method.init == 1) median(y[,1]) else mean(y[,1])
+ mean2 = if( .method.init == 1) median(y[,2]) else mean(y[,2])
+ Finit = 0.01 + mean(y[,1] <= mean1 & y[,2] <= mean2)
+ (log(Finit-1+exp(-mean1)+exp(-mean2))+mean1+mean2)/(mean1*mean2)
+ }
+ 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(1, len=length(alpha)),
+ rep(1, len=length(alpha)))
+ }, list( .lapar=lapar ))),
+ 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 ))),
+ 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 = (alpha*y[,1] - 1) * (alpha*y[,2] - 1) + alpha
+ mytolerance = .Machine$double.xmin
+ bad <- (denom <= mytolerance) # Range violation
+ if(any(bad)) {
+ cat("There are some range violations in @deriv\n")
+ if(exists("flush.console")) flush.console()
+ }
+ sum(bad) * (-1.0e10) +
+ sum(w[!bad] * (-y[!bad,1] - y[!bad,2] +
+ alpha[!bad]*y[!bad,1]*y[!bad,2] + log(denom[!bad])))
+ }
+ }, list( .lapar=lapar, .earg=earg ))),
+ vfamily=c("gumbelIbiv"),
+ deriv=eval(substitute(expression({
+ alpha = eta2theta(eta, .lapar, earg= .earg )
+ numerator = (alpha*y[,1] - 1)*y[,2] + (alpha*y[,2] - 1)*y[,1] + 1
+ denom = (alpha*y[,1] - 1) * (alpha*y[,2] - 1) + alpha
+ denom = abs(denom)
+ dl.dalpha = numerator / denom + y[,1]*y[,2]
+ dalpha.deta = dtheta.deta(alpha, .lapar, earg= .earg )
+ w * cbind(dl.dalpha * dalpha.deta)
+ }), list( .lapar=lapar, .earg=earg ))),
+ weight=eval(substitute(expression({
+ d2l.dalpha2 = (numerator/denom)^2 - 2*y[,1]*y[,2] / denom
+ 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 ))))
+}
+
diff --git a/R/family.categorical.q b/R/family.categorical.q
index 5e2c4bd..99b6836 100644
--- a/R/family.categorical.q
+++ b/R/family.categorical.q
@@ -99,15 +99,18 @@ Deviance.categorical.data.vgam <-
-sratio = function(link="logit", parallel=FALSE, reverse=FALSE, zero=NULL)
+sratio = function(link="logit", earg=list(),
+ parallel=FALSE, reverse=FALSE, zero=NULL)
{
if(mode(link) != "character" && mode(link) != "name")
link = as.character(substitute(link))
+ if(!is.list(earg)) earg = list()
new("vglmff",
blurb=c("Stopping Ratio model\n\n",
"Links: ",
- namesof(if(reverse) "P[Y=j+1|Y<=j+1]" else "P[Y=j|Y>=j]", link),
+ namesof(if(reverse) "P[Y=j+1|Y<=j+1]" else "P[Y=j|Y>=j]",
+ link, earg=earg),
"\n",
"Variance: mu[,j]*(1-mu[,j]); -mu[,j]*mu[,k]"),
constraints=eval(substitute(expression({
@@ -122,43 +125,48 @@ sratio = function(link="logit", parallel=FALSE, reverse=FALSE, zero=NULL)
mynames = if( .reverse)
paste("P[Y=",2:(M+1),"|Y<=",2:(M+1),"]", sep="") else
paste("P[Y=",1:M,"|Y>=",1:M,"]", sep="")
- predictors.names = namesof(mynames, .link, short=TRUE)
+ predictors.names = namesof(mynames, .link, short=TRUE, earg= .earg)
y.names = paste("mu", 1:(M+1), sep="")
extra = if( .reverse ) tapplymat1(y, "cumsum") else
tapplymat1(y[,ncol(y):1], "cumsum")[,ncol(y):1]
- }), list( .link=link, .reverse=reverse ))),
+ }), list( .earg=earg, .link=link, .reverse=reverse ))),
inverse=eval(substitute( function(eta, extra=NULL) {
if(!is.matrix(eta))
eta = as.matrix(eta)
if( .reverse ) {
M = ncol(eta)
- djr = eta2theta(eta, .link)
+ djr = eta2theta(eta, .link, earg= .earg )
temp = tapplymat1(1-djr[,M:1], "cumprod")[,M:1]
cbind(1,djr) * cbind(temp,1)
} else {
- dj = eta2theta(eta, .link)
+ dj = eta2theta(eta, .link, earg= .earg )
temp = tapplymat1(1-dj, "cumprod")
cbind(dj,1) * cbind(1, temp)
}
- }, list( .link=link, .reverse=reverse) )),
+ }, list( .earg=earg, .link=link, .reverse=reverse) )),
last=eval(substitute(expression({
misc$link = rep( .link, length=M)
names(misc$link) = mynames
+
+ misc$earg = vector("list", M)
+ names(misc$earg) = names(misc$link)
+ for(ii in 1:M) misc$earg[[ii]] = .earg
+
misc$parameters = mynames
misc$reverse = .reverse
extra = list() # kill what was used
- }), list( .link=link, .reverse=reverse ))),
+ }), list( .earg=earg, .link=link, .reverse=reverse ))),
link=eval(substitute( function(mu, extra=NULL) {
cump = tapplymat1(mu, "cumsum")
if( .reverse ) {
djr = mu[,-1] / cump[,-1]
- theta2eta(djr, .link)
+ theta2eta(djr, .link, earg= .earg )
} else {
M = ncol(mu) - 1
dj = if(M==1) mu[,1] else mu[,1:M]/(1-cbind(0,cump[,1:(M-1)]))
- theta2eta(dj, .link)
+ theta2eta(dj, .link, earg= .earg )
}
- }, list( .link=link, .reverse=reverse) )),
+ }, list( .earg=earg, .link=link, .reverse=reverse) )),
loglikelihood= function(mu, y, w, residuals = FALSE, eta, extra=NULL)
if(residuals) stop("loglikelihood residuals not implemented yet") else
sum(w * y * log(mu)),
@@ -169,43 +177,46 @@ sratio = function(link="logit", parallel=FALSE, reverse=FALSE, zero=NULL)
tapplymat1(y[,ncol(y):1], "cumsum")[,ncol(y):1]
}
if( .reverse ) {
- djr = eta2theta(eta, .link)
+ djr = eta2theta(eta, .link, earg= .earg )
Mp1 = ncol(extra)
w * (y[,-1]/djr - extra[,-Mp1]/(1-djr)) *
- dtheta.deta(djr, .link)
+ dtheta.deta(djr, .link, earg= .earg )
} else {
- dj = eta2theta(eta, .link)
+ dj = eta2theta(eta, .link, earg= .earg )
w * (y[,-ncol(y)]/dj - extra[,-1]/(1-dj)) *
- dtheta.deta(dj, .link)
+ dtheta.deta(dj, .link, earg= .earg )
}
- }), list( .link=link, .reverse=reverse) )),
+ }), list( .earg=earg, .link=link, .reverse=reverse) )),
weight= eval(substitute(expression({
if( .reverse ) {
cump = tapplymat1(mu, "cumsum")
- ddjr.deta = dtheta.deta(djr, .link)
+ ddjr.deta = dtheta.deta(djr, .link, earg= .earg )
wz = w * ddjr.deta^2 * (mu[,-1]/djr^2 + cump[,1:M]/(1-djr)^2)
} else {
ccump = tapplymat1(mu[,ncol(mu):1], "cumsum")[,ncol(mu):1]
- ddj.deta = dtheta.deta(dj, .link)
+ ddj.deta = dtheta.deta(dj, .link, earg= .earg )
wz = w * ddj.deta^2 * (mu[,1:M]/dj^2 + ccump[,-1]/(1-dj)^2)
}
wz
- }), list( .link=link, .reverse=reverse ))))
+ }), list( .earg=earg, .link=link, .reverse=reverse ))))
}
-cratio = function(link="logit", parallel=FALSE, reverse=FALSE, zero=NULL)
+cratio = function(link="logit", earg=list(),
+ parallel=FALSE, reverse=FALSE, zero=NULL)
{
if(mode(link) != "character" && mode(link) != "name")
link = as.character(substitute(link))
+ if(!is.list(earg)) earg = list()
new("vglmff",
blurb=c("Continuation Ratio model\n\n",
"Links: ",
- namesof(if(reverse) "P[Y<j+1|Y<=j+1]" else "P[Y>j|Y>=j]", link),
+ namesof(if(reverse) "P[Y<j+1|Y<=j+1]" else "P[Y>j|Y>=j]",
+ link, earg=earg),
"\n",
"Variance: mu[,j]*(1-mu[,j]); -mu[,j]*mu[,k]"),
constraints=eval(substitute(expression({
@@ -220,43 +231,46 @@ cratio = function(link="logit", parallel=FALSE, reverse=FALSE, zero=NULL)
mynames = if( .reverse )
paste("P[Y<",2:(M+1),"|Y<=",2:(M+1),"]", sep="") else
paste("P[Y>",1:M,"|Y>=",1:M,"]", sep="")
- predictors.names = namesof(mynames, .link, short=TRUE)
+ predictors.names = namesof(mynames, .link, short=TRUE, earg= .earg)
y.names = paste("mu", 1:(M+1), sep="")
extra = if( .reverse ) tapplymat1(y, "cumsum") else
tapplymat1(y[,ncol(y):1], "cumsum")[,ncol(y):1]
- }), list( .link=link, .reverse=reverse ))),
+ }), list( .earg=earg, .link=link, .reverse=reverse ))),
inverse=eval(substitute( function(eta, extra=NULL) {
if(!is.matrix(eta))
eta = as.matrix(eta)
if( .reverse ) {
M = ncol(eta)
- djrs = eta2theta(eta, .link)
+ djrs = eta2theta(eta, .link, earg= .earg )
temp = tapplymat1(djrs[,M:1], "cumprod")[,M:1]
cbind(1,1-djrs) * cbind(temp,1)
} else {
- djs = eta2theta(eta, .link)
+ djs = eta2theta(eta, .link, earg= .earg )
temp = tapplymat1(djs, "cumprod")
cbind(1-djs,1) * cbind(1, temp)
}
- }, list( .link=link, .reverse=reverse) )),
+ }, list( .earg=earg, .link=link, .reverse=reverse) )),
last=eval(substitute(expression({
misc$link = rep( .link, length=M)
names(misc$link) = mynames
+ misc$earg = vector("list", M)
+ names(misc$earg) = names(misc$link)
+ for(ii in 1:M) misc$earg[[ii]] = .earg
misc$parameters = mynames
misc$reverse = .reverse
extra = list() # kill what was used
- }), list( .link=link, .reverse=reverse ))),
+ }), list( .earg=earg, .link=link, .reverse=reverse ))),
link=eval(substitute( function(mu, extra=NULL) {
cump = tapplymat1(mu, "cumsum")
if( .reverse ) {
djrs = 1 - mu[,-1] / cump[,-1]
- theta2eta(djrs, .link)
+ theta2eta(djrs, .link, earg= .earg )
} else {
M = ncol(mu) - 1
djs = if(M==1) 1-mu[,1] else 1-mu[,1:M]/(1-cbind(0,cump[,1:(M-1)]))
- theta2eta(djs, .link)
+ theta2eta(djs, .link, earg= .earg )
}
- }, list( .link=link, .reverse=reverse) )),
+ }, list( .earg=earg, .link=link, .reverse=reverse) )),
loglikelihood= function(mu, y, w, residuals = FALSE, eta, extra=NULL)
if(residuals) stop("loglikelihood residuals not implemented yet") else
sum(w * y * log(mu)),
@@ -267,29 +281,29 @@ cratio = function(link="logit", parallel=FALSE, reverse=FALSE, zero=NULL)
tapplymat1(y[,ncol(y):1], "cumsum")[,ncol(y):1]
}
if( .reverse ) {
- djrs = eta2theta(eta, .link)
+ djrs = eta2theta(eta, .link, earg= .earg )
Mp1 = ncol(extra)
-w * (y[,-1]/(1-djrs) - extra[,-Mp1]/djrs) *
- dtheta.deta(djrs, .link)
+ dtheta.deta(djrs, .link, earg= .earg )
} else {
- djs = eta2theta(eta, .link)
+ djs = eta2theta(eta, .link, earg= .earg )
-w * (y[,-ncol(y)]/(1-djs) - extra[,-1]/djs) *
- dtheta.deta(djs, .link)
+ dtheta.deta(djs, .link, earg= .earg )
}
- }), list( .link=link, .reverse=reverse) )),
+ }), list( .earg=earg, .link=link, .reverse=reverse) )),
weight= eval(substitute(expression({
if( .reverse ) {
cump = tapplymat1(mu, "cumsum")
- ddjrs.deta = dtheta.deta(djrs, .link)
+ ddjrs.deta = dtheta.deta(djrs, .link, earg= .earg )
wz = w * ddjrs.deta^2 * (mu[,-1]/(1-djrs)^2 + cump[,1:M]/djrs^2)
} else {
ccump = tapplymat1(mu[,ncol(mu):1], "cumsum")[,ncol(mu):1]
- ddjs.deta = dtheta.deta(djs, .link)
+ ddjs.deta = dtheta.deta(djs, .link, earg= .earg )
wz = w * ddjs.deta^2 * (mu[,1:M]/(1-djs)^2 + ccump[,-1]/djs^2)
}
wz
- }), list( .link=link, .reverse=reverse ))))
+ }), list( .earg=earg, .link=link, .reverse=reverse ))))
}
@@ -370,6 +384,9 @@ multinomial = function(zero=NULL, parallel=FALSE, nointercept=NULL)
ans
},
last=expression({
+ misc$link = "mlogit"
+ misc$earg = list(mlogit = list()) # vector("list", M)
+
dy = dimnames(y)
if(!is.null(dy[[2]]))
dimnames(fit$fitted.values) = dy
@@ -406,8 +423,9 @@ multinomial = function(zero=NULL, parallel=FALSE, nointercept=NULL)
-cumulative = function(link="logit", parallel=FALSE, reverse=FALSE,
- earg = list(), mv=FALSE,
+cumulative = function(link="logit", earg = list(),
+ parallel=FALSE, reverse=FALSE,
+ mv=FALSE,
intercept.apply = FALSE)
{
if(mode(link) != "character" && mode(link) != "name")
@@ -425,11 +443,13 @@ cumulative = function(link="logit", parallel=FALSE, reverse=FALSE,
namesof(if(reverse) "P[Y>=j+1]" else "P[Y<=j]", link, earg=earg)),
constraints=eval(substitute(expression({
if( .mv ) {
- Llevels = extra$Llevels
- NOS = extra$NOS
- Hk.matrix = kronecker(diag(NOS), matrix(1,Llevels-1,1))
- constraints = cm.vgam(Hk.matrix, x, .parallel, constraints,
- intercept.apply = .intercept.apply)
+ if( !length(constraints) ) {
+ Llevels = extra$Llevels
+ NOS = extra$NOS
+ Hk.matrix = kronecker(diag(NOS), matrix(1,Llevels-1,1))
+ constraints = cm.vgam(Hk.matrix, x, .parallel, constraints,
+ intercept.apply = .intercept.apply)
+ }
} else {
constraints = cm.vgam(matrix(1,M,1), x, .parallel, constraints,
intercept.apply = .intercept.apply)
@@ -456,7 +476,7 @@ cumulative = function(link="logit", parallel=FALSE, reverse=FALSE,
eta=eta, extra=extra)
}
answer
- }, list( .link=link, .mv = mv ) )),
+ }, list( .earg=earg, .link=link, .mv = mv ) )),
initialize=eval(substitute(expression({
extra$mv = .mv
if( .mv ) {
@@ -490,7 +510,7 @@ cumulative = function(link="logit", parallel=FALSE, reverse=FALSE,
extra$NOS = NOS
extra$Llevels = Llevels
} else {
- delete.zero.colns = TRUE
+ delete.zero.colns = TRUE # Cannot have F 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
@@ -533,14 +553,21 @@ cumulative = function(link="logit", parallel=FALSE, reverse=FALSE,
answer
}, list( .link=link, .reverse=reverse, .earg= earg, .mv = mv ))),
last=eval(substitute(expression({
- misc$link = rep( .link, length=M)
- names(misc$link) = mynames
+ if( .mv ) {
+ misc$link = .link
+ misc$earg = list( .earg )
+ } else {
+ misc$link = rep( .link, length=M)
+ names(misc$link) = mynames
+ misc$earg = vector("list", M)
+ names(misc$earg) = names(misc$link)
+ for(ii in 1:M) misc$earg[[ii]] = .earg
+ }
+
misc$parameters = mynames
misc$reverse = .reverse
misc$parallel = .parallel
misc$mv = .mv
- misc$earg = vector("list", M)
- for(iii in 1:M) misc$earg[[iii]] = .earg
}), list( .link=link, .reverse=reverse, .parallel=parallel,
.mv = mv, .earg= earg ))),
link=eval(substitute( function(mu, extra=NULL) {
@@ -571,6 +598,7 @@ cumulative = function(link="logit", parallel=FALSE, reverse=FALSE,
sum(w * y * log(mu)),
vfamily=c("cumulative", "vcategorical"),
deriv=eval(substitute(expression({
+ mu.use = pmax(mu, .Machine$double.eps * 1.0e-0)
deriv.answer =
if( .mv ) {
NOS = extra$NOS
@@ -582,15 +610,15 @@ cumulative = function(link="logit", parallel=FALSE, reverse=FALSE,
cump = eta2theta(eta[,cindex,drop=FALSE], .link, earg= .earg)
dcump.deta[,cindex] = dtheta.deta(cump, .link, earg= .earg)
answer.matrix[,cindex] =
- (y[,aindex,drop=FALSE]/mu[,aindex,drop=FALSE] -
- y[,1+aindex,drop=FALSE]/mu[,1+aindex,drop=FALSE])
+ (y[,aindex,drop=FALSE]/mu.use[,aindex,drop=FALSE] -
+ y[,1+aindex,drop=FALSE]/mu.use[,1+aindex,drop=FALSE])
}
(if( .reverse) -w else w) * dcump.deta * answer.matrix
} else {
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[,1:M] - y[,-1]/mu[,-1])
+ (y[,1:M]/mu.use[,1:M] - y[,-1]/mu.use[,-1])
}
deriv.answer
}), list( .link=link, .reverse=reverse, .earg= earg, .mv=mv ))),
@@ -603,7 +631,7 @@ cumulative = function(link="logit", parallel=FALSE, reverse=FALSE,
cindex = (iii-1)*(Llevels-1) + 1:(Llevels-1)
aindex = (iii-1)*(Llevels) + 1:(Llevels-1)
wz[,cindex] = w * dcump.deta[,cindex,drop=FALSE]^2 *
- (1/mu[,aindex,drop=FALSE] + 1/mu[,1+aindex,drop=FALSE])
+ (1/mu.use[,aindex,drop=FALSE] + 1/mu.use[,1+aindex,drop=FALSE])
}
if(Llevels-1 > 1) {
iii = 1
@@ -627,26 +655,29 @@ cumulative = function(link="logit", parallel=FALSE, reverse=FALSE,
}
} else {
- wz = w * dcump.deta[,1:M]^2 * (1/mu[,1:M] + 1/mu[,-1])
+ wz = w * dcump.deta[,1:M]^2 * (1/mu.use[,1:M] + 1/mu.use[,-1])
if(M > 1)
wz = cbind(wz, -w * dcump.deta[,1:(M-1)] *
- dcump.deta[,2:M] / mu[,2:M])
+ dcump.deta[,2:M] / mu.use[,2:M])
}
wz
- }), list( .link=link, .mv=mv ))))
+ }), list( .earg=earg, .link=link, .mv=mv ))))
}
-acat = function(link="loge", parallel=FALSE, reverse=FALSE, zero=NULL)
+acat = function(link="loge", earg = list(),
+ parallel=FALSE, reverse=FALSE, zero=NULL)
{
if(mode(link) != "character" && mode(link) != "name")
link = as.character(substitute(link))
+ if(!is.list(earg)) earg = list()
new("vglmff",
blurb=c("Adjacent-categories model\n\n",
"Links: ",
- namesof(if(reverse) "P[Y=j]/P[Y=j+1]" else "P[Y=j+1]/P[Y=j]", link),
+ namesof(if(reverse) "P[Y=j]/P[Y=j+1]" else "P[Y=j+1]/P[Y=j]",
+ link, earg=earg),
"\n",
"Variance: mu[,j]*(1-mu[,j]); -mu[,j]*mu[,k]"),
constraints=eval(substitute(expression({
@@ -662,42 +693,48 @@ acat = function(link="loge", parallel=FALSE, reverse=FALSE, zero=NULL)
mynames = if( .reverse )
paste("P[Y=",1:M,"]/P[Y=",2:(M+1),"]", sep="") else
paste("P[Y=",2:(M+1),"]/P[Y=",1:M,"]", sep="")
- predictors.names = namesof(mynames, .link, short=TRUE)
+ predictors.names = namesof(mynames, .link, short=TRUE, earg= .earg)
y.names = paste("mu", 1:(M+1), sep="")
- }), list( .link=link, .reverse=reverse ))),
+ }), 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)
if( .reverse ) {
- zetar = eta2theta(eta, .link)
+ zetar = eta2theta(eta, .link, earg= .earg )
temp = tapplymat1(zetar[,M:1], "cumprod")[,M:1,drop=FALSE]
cbind(temp,1) / drop(1 + temp %*% rep(1,ncol(temp)))
} else {
- zeta = eta2theta(eta, .link)
+ zeta = eta2theta(eta, .link, earg= .earg )
temp = tapplymat1(zeta, "cumprod")
cbind(1,temp) / drop(1 + temp %*% rep(1,ncol(temp)))
}
- }, list( .link=link, .reverse=reverse) )),
+ }, list( .earg=earg, .link=link, .reverse=reverse) )),
last=eval(substitute(expression({
misc$link = rep( .link, length=M)
names(misc$link) = mynames
+
+ misc$earg = vector("list", M)
+ names(misc$earg) = names(misc$link)
+ for(ii in 1:M) misc$earg[[ii]] = .earg
+
misc$parameters = mynames
misc$reverse = .reverse
- }), list( .link=link, .reverse=reverse ))),
+ }), list( .earg=earg, .link=link, .reverse=reverse ))),
link=eval(substitute( function(mu, extra=NULL) {
M = ncol(mu) - 1
- theta2eta(if( .reverse ) mu[,1:M]/mu[,-1] else mu[,-1]/mu[,1:M], .link)
- }, list( .link=link, .reverse=reverse) )),
+ theta2eta(if( .reverse ) mu[,1:M]/mu[,-1] else mu[,-1]/mu[,1:M],
+ .link, earg= .earg )
+ }, list( .earg=earg, .link=link, .reverse=reverse) )),
loglikelihood= function(mu, y, w, residuals = FALSE, eta, extra=NULL)
if(residuals) stop("loglikelihood residuals not implemented yet") else
sum(w * y * log(mu)),
vfamily=c("acat", "vcategorical"),
deriv=eval(substitute(expression({
- zeta = eta2theta(eta, .link) # May be zetar
+ zeta = eta2theta(eta, .link, earg= .earg ) # May be zetar
d1 = acat.deriv(zeta, M=M, n=n, reverse=.reverse)
score = attr(d1, "gradient") / d1
- dzeta.deta = dtheta.deta(zeta, .link)
+ dzeta.deta = dtheta.deta(zeta, .link, earg= .earg )
if( .reverse ) {
cumy = tapplymat1(y, "cumsum")
w * dzeta.deta * (cumy[,1:M]/zeta - score)
@@ -705,7 +742,7 @@ acat = function(link="loge", parallel=FALSE, reverse=FALSE, zero=NULL)
ccumy = tapplymat1(y[,ncol(y):1], "cumsum")[,ncol(y):1]
w * dzeta.deta * (ccumy[,-1]/zeta - score)
}
- }), list( .link=link, .reverse=reverse) )),
+ }), list( .earg=earg, .link=link, .reverse=reverse) )),
weight= eval(substitute(expression({
wz = matrix(as.numeric(NA), n, dimm(M))
@@ -724,7 +761,7 @@ acat = function(link="loge", parallel=FALSE, reverse=FALSE, zero=NULL)
wz[,1:M] = (ccump[,-1]/zeta^2 - score^2) * dzeta.deta^2
}
w * wz
- }), list( .link=link, .reverse=reverse ))))
+ }), list( .earg=earg, .link=link, .reverse=reverse ))))
}
acat.deriv = function(zeta, reverse, M, n)
@@ -779,7 +816,7 @@ brat = function(refgp="last",
M = (1:length(try.index))[(try.index+1)*(try.index) == ncol(y)]
if(!is.finite(M)) stop("can't determine M")
init.alpha = matrix( rep( .init.alpha, len=M), n, M, byrow=TRUE)
- etastart = matrix(theta2eta(init.alpha, "loge"), n, M, byrow=TRUE)
+ etastart = matrix(theta2eta(init.alpha, "loge", earg=list()), n, M, byrow=TRUE)
refgp = .refgp
if(!intercept.only)
warning("this function only works with intercept only models")
@@ -792,7 +829,8 @@ brat = function(refgp="last",
probs = NULL
eta = as.matrix(eta) # in case M=1
for(ii in 1:nrow(eta)) {
- alpha = .brat.alpha(eta2theta(eta[ii,], "loge"), .refvalue, .refgp)
+ alpha = .brat.alpha(eta2theta(eta[ii,], "loge", earg=list()),
+ .refvalue, .refgp)
alpha1 = alpha[extra$ybrat.indices[,"rindex"]]
alpha2 = alpha[extra$ybrat.indices[,"cindex"]]
probs = rbind(probs, alpha1/(alpha1+alpha2))
@@ -815,7 +853,8 @@ brat = function(refgp="last",
uindex = if( .refgp =="last") 1:M else (1:(M+1))[-( .refgp ) ]
eta = as.matrix(eta) # in case M=1
for(ii in 1:nrow(eta)) {
- alpha = .brat.alpha(eta2theta(eta[ii,], "loge"), .refvalue, .refgp)
+ alpha = .brat.alpha(eta2theta(eta[ii,], "loge", earg=list()),
+ .refvalue, .refgp)
ymat = InverseBrat(y[ii,], NCo=M+1, diag=0)
answer = rep(0, len=M)
for(aa in 1:(M+1)) {
@@ -831,7 +870,8 @@ brat = function(refgp="last",
weight= eval(substitute(expression({
wz = matrix(0, n, dimm(M))
for(ii in 1:nrow(eta)) {
- alpha = .brat.alpha(eta2theta(eta[ii,], "loge"), .refvalue, .refgp)
+ alpha = .brat.alpha(eta2theta(eta[ii,], "loge", earg=list()),
+ .refvalue, .refgp)
ymat = InverseBrat(y[ii,], NCo=M+1, diag=0)
for(aa in 1:(M+1)) {
wz[ii,1:M] = wz[ii,1:M] + (1-(aa==uindex)) *
@@ -1105,3 +1145,229 @@ InverseBrat = function(yvec, NCo=
+
+tapplymat1 <- function(mat, function.arg=c("cumsum", "diff", "cumprod"))
+{
+
+
+ if(!missing(function.arg))
+ function.arg <- as.character(substitute(function.arg))
+ function.arg <- match.arg(function.arg, c("cumsum", "diff", "cumprod"))[1]
+
+ type <- switch(function.arg,
+ cumsum=1,
+ diff=2,
+ cumprod=3,
+ stop("function.arg not matched"))
+
+ if(!is.matrix(mat))
+ mat <- as.matrix(mat)
+ nr <- nrow(mat)
+ nc <- ncol(mat)
+ fred <- dotC(name="tapplymat1", mat=as.double(mat),
+ as.integer(nr), as.integer(nc), as.integer(type))
+
+ dim(fred$mat) <- c(nr, nc)
+ dimnames(fred$mat) <- dimnames(mat)
+ switch(function.arg,
+ cumsum=fred$mat,
+ diff=fred$mat[,-1,drop=FALSE],
+ cumprod=fred$mat)
+}
+
+
+
+
+ordpoisson = function(cutpoints,
+ countdata=FALSE, NOS=NULL, Levels=NULL,
+ init.mu = NULL, parallel=FALSE, zero=NULL,
+ link="loge", earg = list()) {
+ if(mode(link) != "character" && mode(link) != "name")
+ link = as.character(substitute(link))
+ if(!is.list(earg)) earg = list()
+ fcutpoints = cutpoints[is.finite(cutpoints)]
+ if(!is.Numeric(fcutpoints, integ=TRUE) || any(fcutpoints < 0))
+ stop("\"cutpoints\" must have non-negative integer or Inf values only")
+ if(is.finite(cutpoints[length(cutpoints)]))
+ cutpoints = c(cutpoints, Inf)
+
+ if(!is.logical(countdata) || length(countdata)!=1)
+ stop("\"countdata\" must be a single logical")
+ if(countdata) {
+ if(!is.Numeric(NOS, integ=TRUE, posit=TRUE))
+ stop("\"NOS\" must have integer values only")
+ if(!is.Numeric(Levels, integ=TRUE, posit=TRUE) || any(Levels < 2))
+ stop("\"Levels\" must have integer values (>= 2) only")
+ Levels = rep(Levels, length=NOS)
+ }
+
+ new("vglmff",
+ blurb=c(paste("Ordinal Poisson model\n\n"),
+ "Link: ", namesof("mu", link, earg= earg)),
+ constraints=eval(substitute(expression({
+ constraints = cm.vgam(matrix(1,M,1), x, .parallel, constraints,
+ intercept.apply=TRUE)
+ constraints = cm.zero.vgam(constraints, x, .zero, M)
+ }), list( .parallel=parallel, .zero=zero ))),
+ initialize=eval(substitute(expression({
+ orig.y = cbind(y) # Convert y into a matrix if necessary
+ if( .countdata ) {
+ extra$NOS = M = NOS = .NOS
+ extra$Levels = Levels = .Levels
+ y.names = dimnames(y)[[2]] # Hopefully the user inputted them
+ } else {
+ if(any(w != 1) || ncol(cbind(w)) != 1)
+ stop("the 'weights' argument must be a vector of all ones")
+ extra$NOS = M = NOS = if(is.Numeric( .NOS )) .NOS else
+ ncol(orig.y)
+ Levels = rep( if(is.Numeric( .Levels )) .Levels else 0, len=NOS)
+ if(!is.Numeric( .Levels ))
+ for(iii in 1:NOS) {
+ Levels[iii] = length(unique(sort(orig.y[,iii])))
+ }
+ extra$Levels = Levels
+ }
+
+
+ initmu = if(is.Numeric( .init.mu )) rep( .init.mu, len=NOS) else NULL
+ cutpoints = rep( .cutpoints, len=sum(Levels))
+ delete.zero.colns = FALSE
+ use.y = if( .countdata ) y else matrix(0, n, sum(Levels))
+ use.etastart = matrix(0, n, M)
+ cptr = 1
+ for(iii in 1:NOS) {
+ y = factor(orig.y[,iii], levels=(1:Levels[iii]))
+ if( !( .countdata )) {
+ eval(process.categorical.data.vgam) # Creates mustart and y
+ use.y[,cptr:(cptr+Levels[iii]-1)] = y
+ }
+ use.etastart[,iii] = if(is.Numeric(initmu)) initmu[iii] else
+ median(cutpoints[cptr:(cptr+Levels[iii]-1-1)])
+ cptr = cptr + Levels[iii]
+ }
+ mustart = NULL # Overwrite it
+ etastart = theta2eta(use.etastart, .link, earg= .earg)
+ y = use.y # n x sum(Levels)
+ M = NOS
+ for(iii in 1:NOS) {
+ mu.names = paste("mu", iii, ".", sep="")
+ }
+
+ ncoly = extra$ncoly = sum(Levels)
+ cp.vector = rep( .cutpoints, length=ncoly)
+ extra$countdata = .countdata
+ extra$cutpoints = cp.vector
+ extra$n = n
+ mynames = if(M > 1) paste("mu",1:M,sep="") else "mu"
+ predictors.names = namesof(mynames, .link, short=TRUE, earg= .earg)
+ }), list( .link=link, .countdata = countdata, .earg = earg,
+ .cutpoints=cutpoints, .NOS=NOS, .Levels=Levels,
+ .init.mu = init.mu
+ ))),
+ inverse=eval(substitute( function(eta, extra=NULL) {
+ mu = eta2theta(eta, link= .link, earg= .earg) # Poisson means
+ mu = cbind(mu)
+ mu
+ }, list( .link=link, .earg= earg, .countdata = countdata ))),
+ last=eval(substitute(expression({
+ if( .countdata ) {
+ misc$link = .link
+ misc$earg = list( .earg )
+ } else {
+ misc$link = rep( .link, length=M)
+ names(misc$link) = mynames
+ misc$earg = vector("list", M)
+ names(misc$earg) = names(misc$link)
+ for(ii in 1:M) misc$earg[[ii]] = .earg
+ }
+ misc$parameters = mynames
+ misc$countdata = .countdata
+ misc$true.mu <- FALSE # $fitted is not a true mu
+ }), list( .link=link, .countdata = countdata, .earg= earg ))),
+ loglikelihood= function(mu, y, w, residuals = FALSE, eta, extra=NULL) {
+ if(residuals) stop("loglikelihood residuals not implemented yet") else {
+ probs = ordpoissonProbs(extra, mu)
+ index0 <- y == 0
+ probs[index0] = 1
+ pindex0 <- probs == 0
+ probs[pindex0] = 1
+ sum(pindex0) * (-1.0e+10) + sum(w * y * log(probs))}},
+ vfamily=c("ordpoisson", "vcategorical"),
+ deriv=eval(substitute(expression({
+ probs = ordpoissonProbs(extra, mu)
+ probs.use = pmax(probs, .Machine$double.eps * 1.0e-0)
+
+ cp.vector = extra$cutpoints
+ NOS = extra$NOS
+ Levels = extra$Levels
+ answer.matrix = matrix(0, n, M)
+ dl.dprob = y / probs.use
+ dmu.deta = dtheta.deta(mu, .link, earg=.earg)
+ dprob.dmu = ordpoissonProbs(extra, mu, deriv=1)
+ cptr = 1
+ for(iii in 1:NOS) {
+ for(kkk in 1:Levels[iii]) {
+ answer.matrix[,iii] = answer.matrix[,iii] +
+ dl.dprob[,cptr] * dprob.dmu[,cptr]
+ cptr = cptr + 1
+ }
+ }
+ answer.matrix = w * answer.matrix * dmu.deta
+ answer.matrix
+ }), list( .link=link, .earg= earg, .countdata=countdata ))),
+ weight= eval(substitute(expression({
+ d2l.dmu2 = matrix(0, n, M) # Diagonal matrix
+ cptr = 1
+ for(iii in 1:NOS) {
+ for(kkk in 1:Levels[iii]) {
+ d2l.dmu2[,iii] = d2l.dmu2[,iii] +
+ dprob.dmu[,cptr]^2 / probs.use[,cptr]
+ cptr = cptr + 1
+ }
+ }
+ wz = w * d2l.dmu2 * dmu.deta^2
+ wz
+ }), list( .earg=earg, .link=link, .countdata=countdata ))))
+}
+
+ordpoissonProbs = function(extra, mu, deriv=0) {
+ cp.vector = extra$cutpoints
+ NOS = extra$NOS
+ if(deriv == 1) {
+ dprob.dmu = matrix(0, extra$n, extra$ncoly)
+ } else {
+ probs = matrix(0, extra$n, extra$ncoly)
+ }
+ mu = cbind(mu)
+ cptr = 1
+ for(iii in 1:NOS) {
+ if(deriv == 1) {
+ dprob.dmu[,cptr] = -dpois(x=cp.vector[cptr], lamb=mu[,iii])
+ } else {
+ probs[,cptr] = ppois(q=cp.vector[cptr], lambda=mu[,iii])
+ }
+ cptr = cptr + 1
+ while(is.finite(cp.vector[cptr])) {
+ if(deriv == 1) {
+ dprob.dmu[,cptr] = dpois(x=cp.vector[cptr-1], lamb=mu[,iii]) -
+ dpois(x=cp.vector[cptr], lambda=mu[,iii])
+ } else {
+ probs[,cptr] = ppois(q=cp.vector[cptr], lambda=mu[,iii]) -
+ ppois(q=cp.vector[cptr-1], lambda=mu[,iii])
+ }
+ cptr = cptr + 1
+ }
+ if(deriv == 1) {
+ dprob.dmu[,cptr] = dpois(x=cp.vector[cptr-1], lamb=mu[,iii]) -
+ dpois(x=cp.vector[cptr], lambda=mu[,iii])
+ } else {
+ probs[,cptr] = ppois(q=cp.vector[cptr], lamb=mu[,iii]) -
+ ppois(q=cp.vector[cptr-1], lambda=mu[,iii])
+ }
+ cptr = cptr + 1
+ }
+ if(deriv == 1) dprob.dmu else probs
+}
+
+
+
diff --git a/R/family.censored.q b/R/family.censored.q
index 87bc389..04aeb88 100644
--- a/R/family.censored.q
+++ b/R/family.censored.q
@@ -115,8 +115,9 @@ cnormal1 = function(lmu="identity", lsd="loge", imethod=1, zero=2)
if(any(extra$rightcensored & extra$leftcensored))
stop("some observations are both right and left censored!")
- predictors.names = c(namesof("mu", .lmu, tag= FALSE),
- namesof("sd", .lsd, tag= FALSE))
+ predictors.names =
+ c(namesof("mu", .lmu, tag= FALSE),
+ namesof("sd", .lsd, tag= FALSE))
if(!length(etastart)) {
anyc = extra$leftcensored | extra$rightcensored
i11 = if( .imethod == 1) anyc else FALSE # can be all data
@@ -231,54 +232,58 @@ cnormal1 = function(lmu="identity", lsd="loge", imethod=1, zero=2)
-crayleigh = function(link="loge", expected=FALSE) {
+crayleigh = function(link="loge", earg = list(), expected=FALSE) {
if(mode(link) != "character" && mode(link) != "name")
link = as.character(substitute(link))
if(!is.logical(expected) || length(expected) != 1)
stop("bad input for argument \"expected\"")
+ if(!is.list(earg)) earg = list()
new("vglmff",
blurb=c("Censored Rayleigh distribution",
"f(y) = y*exp(-0.5*(y/a)^2)/a^2, y>0, a>0\n",
"Link: ",
- namesof("a", link), "\n", "\n",
+ namesof("a", link, earg= earg ), "\n", "\n",
"Mean: a * sqrt(pi / 2)"),
initialize=eval(substitute(expression({
+ if(ncol(cbind(y)) != 1)
+ stop("response must be a vector or a one-column matrix")
if(length(extra$leftcensored)) stop("cannot handle left-censored data")
if(!length(extra$rightcensored)) extra$rightcensored = rep(FALSE, len=n)
- predictors.names = namesof("a", .link, tag= FALSE)
+ predictors.names = namesof("a", .link, earg= .earg, tag= FALSE)
if(!length(etastart)) {
a.init = (y+1/8) / sqrt(pi/2)
- etastart = theta2eta(a.init, .link)
+ etastart = theta2eta(a.init, .link, earg= .earg )
}
- }), list( .link=link ))),
+ }), list( .link=link, .earg=earg ))),
inverse=eval(substitute(function(eta, extra=NULL) {
- a = eta2theta(eta, .link)
+ a = eta2theta(eta, .link, earg= .earg )
a * sqrt(pi/2)
- }, list( .link=link ))),
+ }, list( .link=link, .earg=earg ))),
last=eval(substitute(expression({
misc$link = c("a"= .link)
+ misc$earg = list(a= .earg)
misc$expected = .expected
- }), list( .link=link, .expected=expected ))),
+ }), list( .link=link, .earg=earg, .expected=expected ))),
loglikelihood=eval(substitute(
function(mu,y,w,residuals= FALSE,eta, extra=NULL) {
- a = eta2theta(eta, .link)
+ a = eta2theta(eta, .link, earg= .earg )
cen0 = !extra$rightcensored # uncensored obsns
cenU = extra$rightcensored
if(residuals) stop("loglikelihood residuals not implemented yet") else
sum(w[cen0]*(log(y[cen0]) - 2*log(a[cen0]) - 0.5*(y[cen0]/a[cen0])^2)) -
0.5 * sum(w[cenU] * (y[cenU]/a[cenU])^2)
- }, list( .link=link ))),
+ }, list( .link=link, .earg=earg ))),
vfamily=c("crayleigh"),
deriv=eval(substitute(expression({
cen0 = !extra$rightcensored # uncensored obsns
cenU = extra$rightcensored
- a = eta2theta(eta, .link)
+ a = eta2theta(eta, .link, earg= .earg )
dl.da = ((y/a)^2 - 2) / a
- da.deta = dtheta.deta(a, .link)
+ da.deta = dtheta.deta(a, .link, earg= .earg )
dl.da[cenU] = y[cenU]^2 / a[cenU]^3
w * dl.da * da.deta
- }), list( .link=link ))),
+ }), list( .link=link, .earg=earg ))),
weight=eval(substitute(expression({
ed2l.da2 = 4 / a^2
wz = da.deta^2 * ed2l.da2
@@ -287,11 +292,11 @@ crayleigh = function(link="loge", expected=FALSE) {
wz[cenU] = (da.deta[cenU])^2 * ed2l.da2[cenU]
} else {
d2l.da2 = 3 * (y[cenU])^2 / (a[cenU])^4
- d2a.deta2 = d2theta.deta2(a[cenU], .link)
+ d2a.deta2 = d2theta.deta2(a[cenU], .link, earg= .earg )
wz[cenU] = (da.deta[cenU])^2 * d2l.da2 - dl.da[cenU] * d2a.deta2
}
w * wz
- }), list( .link=link, .expected=expected ))))
+ }), list( .link=link, .earg=earg, .expected=expected ))))
}
@@ -333,8 +338,9 @@ weibull = function(lshape="logoff", lscale="loge",
if(any(extra$rightcensored & extra$leftcensored))
stop("some observations are both right and left censored!")
- predictors.names = c(namesof("shape", .lshape, earg= .eshape, tag=FALSE),
- namesof("scale", .lscale, earg= .escale, tag=FALSE))
+ predictors.names =
+ c(namesof("shape", .lshape, earg= .eshape, tag=FALSE),
+ namesof("scale", .lscale, earg= .escale, tag=FALSE))
if(!length(.ishape) || !length(.iscale)) {
anyc = extra$leftcensored | extra$rightcensored
i11 = if( .imethod == 1) anyc else FALSE # can be all data
diff --git a/R/family.extremes.q b/R/family.extremes.q
index 39a0e4c..e5c33ce 100644
--- a/R/family.extremes.q
+++ b/R/family.extremes.q
@@ -56,9 +56,10 @@ gev <- function(llocation="identity",
constraints = cm.zero.vgam(constraints, x, .zero, M)
}), list( .zero=zero ))),
initialize=eval(substitute(expression({
- predictors.names = c(namesof("location", .llocation, earg= .elocation, short=TRUE),
- namesof("scale", .lscale, earg= .escale, short=TRUE),
- namesof("shape", .lshape, earg= .eshape, short=TRUE))
+ predictors.names =
+ c(namesof("location", .llocation, earg= .elocation, short=TRUE),
+ namesof("scale", .lscale, earg= .escale, short=TRUE),
+ namesof("shape", .lshape, earg= .eshape, short=TRUE))
y = as.matrix(y)
if(ncol(y) > 1)
y = -t(apply(-y, 1, sort, na.last=TRUE))
@@ -650,8 +651,9 @@ gumbel <- function(llocation="identity",
constraints = cm.zero.vgam(constraints, x, .zero, M)
}), list( .zero=zero ))),
initialize=eval(substitute(expression({
- predictors.names = c(namesof("location", .llocation, earg= .elocation, short=TRUE),
- namesof("scale", .lscale, earg= .escale , short=TRUE))
+ predictors.names =
+ c(namesof("location", .llocation, earg= .elocation, short=TRUE),
+ namesof("scale", .lscale, earg= .escale , short=TRUE))
y = as.matrix(y)
if(ncol(y) > 1)
y = if(is.R()) -t(apply(-y,1,sort, na.last = TRUE)) else {
@@ -932,8 +934,9 @@ gpd = function(threshold=0,
extra$threshold = .threshold
w = w[keep] # -> origw
n = length(w)
- predictors.names= c(namesof("scale", .lscale, earg= .escale, short=TRUE),
- namesof("shape", .lshape, earg= .eshape, short=TRUE ))
+ predictors.names=
+ c(namesof("scale", .lscale, earg= .escale, short=TRUE),
+ namesof("shape", .lshape, earg= .eshape, short=TRUE ))
if(!length(etastart)) {
meany = mean(y)
vary = var(y)
@@ -1157,9 +1160,12 @@ bvevd.log.qn <- function(lscale="loge",
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")
- predictors.names = c("loc1", namesof("scale1", lscale), "shape1",
- "loc2", namesof("scale2", lscale), "shape2",
- namesof("dep", ldep))
+ predictors.names =
+ c("loc1",
+ namesof("scale1", lscale), "shape1",
+ "loc2",
+ namesof("scale2", lscale), "shape2",
+ namesof("dep", ldep))
if(!length(etastart)) {
etastart <- theta2eta(mu, link=.link)
}
@@ -1350,8 +1356,9 @@ egumbel = function(llocation="identity",
stop("Use gumbel() to handle multivariate responses")
if(min(y) <= 0)
stop("all response values must be positive")
- predictors.names = c(namesof("location", .llocation, earg= .elocation, tag= FALSE),
- namesof("scale", .lscale, earg= .escale , tag= FALSE))
+ predictors.names =
+ c(namesof("location", .llocation, earg= .elocation, tag= FALSE),
+ namesof("scale", .lscale, earg= .escale , tag= FALSE))
extra$R = .R
extra$mpv = .mpv
@@ -1486,8 +1493,8 @@ cgumbel = function(llocation="identity",
stop("some observations are both right and left censored!")
predictors.names =
- c(namesof("location", .llocation, earg= .elocation, tag= FALSE),
- namesof("scale", .lscale, earg= .escale , tag= FALSE))
+ c(namesof("location", .llocation, earg= .elocation, tag= FALSE),
+ namesof("scale", .lscale, earg= .escale , tag= FALSE))
if(!length(etastart)) {
sc.init = if(is.Numeric( .iscale, posit=TRUE))
.iscale else 1.1 * sqrt(var(y) * 6 ) / pi
@@ -1675,8 +1682,9 @@ frechet2 = function(location=0,
constraints <- cm.zero.vgam(constraints, x, .zero, M)
}), list( .zero=zero ))),
initialize=eval(substitute(expression({
- predictors.names = c(namesof("scale", .lscale, earg=.escale, short=TRUE),
- namesof("shape", .lshape, earg=.eshape, short=TRUE))
+ predictors.names =
+ c(namesof("scale", .lscale, earg=.escale, short=TRUE),
+ namesof("shape", .lshape, earg=.eshape, short=TRUE))
extra$location = rep( .location, len=n) # stored here
if(!length(etastart)) {
# Initial values for limiting case as xi --> 0, r_i==1
@@ -2112,13 +2120,14 @@ exbilogi <- function(zero=c(3,6,7),
constraints = cm.zero.vgam(constraints, x, .zero, M)
}), list( .zero=zero ))),
initialize=eval(substitute(expression({
- predictors.names = c(namesof("loc1", .llocation, short=TRUE),
- namesof("scale1", .lscale, short=TRUE),
- namesof("shape1", .lshape, short=TRUE),
- namesof("loc2", .llocation, short=TRUE),
- namesof("scale2", .lscale, short=TRUE),
- namesof("shape2", .lshape, short=TRUE),
- namesof("dependency", .ldependency, short=TRUE))
+ predictors.names = c(
+ namesof("loc1", .llocation, short=TRUE),
+ namesof("scale1", .lscale, short=TRUE),
+ namesof("shape1", .lshape, short=TRUE),
+ namesof("loc2", .llocation, short=TRUE),
+ namesof("scale2", .lscale, short=TRUE),
+ namesof("shape2", .lshape, short=TRUE),
+ namesof("dependency", .ldependency, short=TRUE))
if(ncol(as.matrix(y)) != 2)
stop("the response must be a two-column matrix")
diff --git a/R/family.genetic.q b/R/family.genetic.q
index 2dabad3..963162a 100644
--- a/R/family.genetic.q
+++ b/R/family.genetic.q
@@ -8,25 +8,26 @@
-G1G2G3 <- function(link="logit", ip1=NULL, ip2=NULL, iF=NULL)
+G1G2G3 <- function(link="logit", earg = list(), ip1=NULL, ip2=NULL, iF=NULL)
{
if(mode(link) != "character" && mode(link) != "name")
link <- as.character(substitute(link))
+ if(!is.list(earg)) earg = list()
new("vglmff",
blurb=c("G1/G2/G3 zzphenotype\n\n",
"Links: ",
- namesof("p1", link), ", ",
- namesof("p2", link), ", ",
- namesof("f", link, tag=FALSE),
+ namesof("p1", link, earg= earg), ", ",
+ namesof("p2", link, earg= earg), ", ",
+ namesof("f", link, earg= earg, tag=FALSE),
"\n",
"Variance: multinomial type variance"),
initialize=eval(substitute(expression({
delete.zero.colns <- FALSE
eval(process.categorical.data.vgam)
- predictors.names <- c(namesof("p1", .link, tag=FALSE),
- namesof("p2", .link, tag=FALSE),
- namesof("f", .link, tag=FALSE))
+ predictors.names <- c(namesof("p1", .link, earg= .earg, tag=FALSE),
+ namesof("p2", .link, earg= .earg, tag=FALSE),
+ namesof("f", .link, earg= .earg, tag=FALSE))
if(is.null(etastart)) {
p1 <- if(is.numeric(.ip1)) rep(.ip1, n) else
sqrt(mustart[,1])
@@ -38,35 +39,39 @@ G1G2G3 <- function(link="logit", ip1=NULL, ip2=NULL, iF=NULL)
stop("bad initial value for p1")
if(any(p2 <= 0) || any(p2 >= 1))
stop("bad initial value for p2")
- etastart <- cbind(theta2eta(p1, .link),
- theta2eta(p2, .link),
- theta2eta(f, .link))
+ etastart <- cbind(theta2eta(p1, .link, earg= .earg),
+ theta2eta(p2, .link, earg= .earg),
+ theta2eta(f, .link, earg= .earg))
}
- }), list(.link=link, .ip1=ip1, .ip2=ip2, .iF=iF))),
+ }), list(.link=link, .ip1=ip1, .ip2=ip2, .iF=iF,
+ .earg=earg ))),
inverse=eval(substitute(function(eta, extra=NULL){
- p1 <- eta2theta(eta[,1], link=.link)
- p2 <- eta2theta(eta[,2], link=.link)
+ p1 <- eta2theta(eta[,1], link=.link, earg= .earg)
+ p2 <- eta2theta(eta[,2], link=.link, earg= .earg)
p3 <- 1-p1-p2
- f <- eta2theta(eta[,3], link=.link)
+ f <- eta2theta(eta[,3], link=.link, earg= .earg)
cbind("G1/G1"=f*p1+(1-f)*p1^2,
"G1/G2"=2*p1*p2*(1-f),
"G1/G3"=2*p1*p3*(1-f),
"G2/G2"=f*p2+(1-f)*p2^2,
"G2/G3"=2*p2*p3*(1-f),
"G3/G3"=f*p3+(1-f)*p3^2)
- }, list(.link=link))),
+ }, list(.link=link,
+ .earg=earg ))),
last=eval(substitute(expression({
misc$link <- c(p1= .link, p2= .link, f= .link)
- }), list(.link=link))),
+ misc$earg = list(p1= .earg, p2= .earg, f= .earg )
+ }), list(.link=link,
+ .earg=earg ))),
loglikelihood=function(mu,y,w,residuals=FALSE,eta,extra=NULL)
if(residuals) stop("loglikelihood residuals not implemented yet") else
sum((w*y)*log(mu)),
vfamily=c("G1G2G3", "vgenetic"),
deriv=eval(substitute(expression({
- p1 <- eta2theta(eta[,1], link=.link)
- p2 <- eta2theta(eta[,2], link=.link)
+ p1 <- eta2theta(eta[,1], link=.link, earg= .earg)
+ p2 <- eta2theta(eta[,2], link=.link, earg= .earg)
p3 <- 1-p1-p2
- f <- eta2theta(eta[,3], link=.link)
+ f <- eta2theta(eta[,3], link=.link, earg= .earg)
dP1 <- cbind(f + 2*p1*(1-f), 2*(1-f)*p2, 2*(1-f)*(1-p2-2*p1), 0,
-2*(1-f)*p2, -f - 2*p3*(1-f))
dP2 <- cbind(0, 2*p1*(1-f), -2*(1-f)*p1, f+2*p2*(1-f),
@@ -76,10 +81,11 @@ G1G2G3 <- function(link="logit", ip1=NULL, ip2=NULL, iF=NULL)
dl1 <- apply(y * dP1 / mu, 1, sum)
dl2 <- apply(y * dP2 / mu, 1, sum)
dl3 <- apply(y * dP3 / mu, 1, sum)
- dPP.deta <- dtheta.deta(cbind(p1,p2,f), link=.link)
+ dPP.deta <- dtheta.deta(cbind(p1,p2,f), link=.link, earg= .earg)
w * cbind(dPP.deta[,1] * dl1, dPP.deta[,2] * dl2,
dPP.deta[,3] * dl3)
- }), list(.link=link))),
+ }), list(.link=link,
+ .earg=earg ))),
weight=eval(substitute(expression({
dPP <- array(c(dP1,dP2,dP3), c(n,6,3))
@@ -91,28 +97,30 @@ G1G2G3 <- function(link="logit", ip1=NULL, ip2=NULL, iF=NULL)
mu, 1, sum) * dPP.deta[,i1] * dPP.deta[,i2]
}
w * wz
- }), list(.link=link))))
+ }), list(.link=link,
+ .earg=earg ))))
}
-AAaa.nohw <- function(link="logit", ipA=NULL, iF=NULL)
+AAaa.nohw <- function(link="logit", earg = list(), ipA=NULL, iF=NULL)
{
if(mode(link) != "character" && mode(link) != "name")
link <- as.character(substitute(link))
+ if(!is.list(earg)) earg = list()
new("vglmff",
blurb=c("AA-Aa-aa phenotype (without Hardy-Weinberg assumption)\n\n",
"Links: ",
- namesof("pA", link), ", ",
+ namesof("pA", link, earg= earg), ", ",
namesof("f", "identity", tag=FALSE),
"\n",
"Variance: multinomial type variance"),
initialize=eval(substitute(expression({
delete.zero.colns <- FALSE
eval(process.categorical.data.vgam)
- predictors.names <- c(namesof("pA", .link, tag=FALSE),
+ predictors.names <- c(namesof("pA", .link, earg= .earg, tag=FALSE),
namesof("f", "identity", tag=FALSE))
if(is.null(etastart)) {
pA <- if(is.numeric(.ipA)) rep(.ipA, n) else
@@ -121,42 +129,48 @@ AAaa.nohw <- function(link="logit", ipA=NULL, iF=NULL)
rep(0.01, n) # 1- mustart[,2]/(2*pA*(1-pA))
if(any(pA <= 0) || any(pA >= 1))
stop("bad initial value for pA")
- etastart <- cbind(theta2eta(pA, .link),
+ etastart <- cbind(theta2eta(pA, .link, earg= .earg),
theta2eta(f, "identity"))
}
- }), list(.link=link, .ipA=ipA, .iF=iF))),
+ }), list(.link=link, .ipA=ipA, .iF=iF,
+ .earg=earg ))),
inverse=eval(substitute(function(eta, extra=NULL){
- pA <- eta2theta(eta[,1], link=.link)
+ pA <- eta2theta(eta[,1], link=.link, earg= .earg)
f <- eta2theta(eta[,2], link="identity")
cbind(AA=pA^2+pA*(1-pA)*f, Aa=2*pA*(1-pA)*(1-f),
aa=(1-pA)^2 + pA*(1-pA)*f)
- }, list(.link=link))),
+ }, list(.link=link,
+ .earg=earg ))),
last=eval(substitute(expression({
misc$link <- c(pA= .link, f= "identity")
- }), list(.link=link))),
+ misc$earg = list(pA= .earg, f= list() )
+ }), list(.link=link,
+ .earg=earg ))),
link=eval(substitute(function(mu, extra=NULL){
pA <- sqrt(mu[,1] - mu[,2]/2)
f <- 1- mu[,2]/(2*pA*(1-pA))
- cbind(theta2eta(pA, .link),
+ cbind(theta2eta(pA, .link, earg= .earg),
theta2eta(f, "identity"))
- }, list(.link=link))),
+ }, list(.link=link,
+ .earg=earg ))),
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("AAaa.nohw", "vgenetic"),
deriv=eval(substitute(expression({
- pA <- eta2theta(eta[,1], link=.link)
+ pA <- eta2theta(eta[,1], link=.link, earg= .earg)
f <- eta2theta(eta[,2], link="identity")
dP1 <- cbind(f + 2*pA*(1-f), 2*(1-f)*(1-2*pA), -2*(1-pA) +f*(1-2*pA))
dP2 <- cbind(pA*(1-pA), -2*pA*(1-pA), pA*(1-pA))
dl1 <- apply(y * dP1 / mu, 1, sum)
dl2 <- apply(y * dP2 / mu, 1, sum)
- dPP.deta <- dtheta.deta(pA, link=.link)
+ dPP.deta <- dtheta.deta(pA, link=.link, earg= .earg)
w * cbind(dPP.deta * dl1, dl2)
- }), list(.link=link))),
+ }), list(.link=link,
+ .earg=earg ))),
weight=eval(substitute(expression({
dPP <- array(c(dP1,dP2), c(n,3,2))
- dPP.deta <- cbind(dtheta.deta(pA, link=.link),
+ dPP.deta <- cbind(dtheta.deta(pA, link=.link, earg= .earg),
dtheta.deta(f, link="identity"))
wz <- matrix(as.numeric(NA), n, dimm(M)) # dimm(M)==3 because M==2
for(i1 in 1:M)
@@ -166,119 +180,137 @@ AAaa.nohw <- function(link="logit", ipA=NULL, iF=NULL)
mu, 1, sum) * dPP.deta[,i1] * dPP.deta[,i2]
}
w * wz
- }), list(.link=link))))
+ }), list(.link=link,
+ .earg=earg ))))
}
-AB.Ab.aB.ab2 <- function(link="logit", init.p=NULL)
+AB.Ab.aB.ab2 <- function(link="logit", earg = list(), init.p=NULL)
{
if(mode(link) != "character" && mode(link) != "name")
link <- as.character(substitute(link))
+ if(!is.list(earg)) earg = list()
new("vglmff",
blurb=c("AB-Ab-aB-ab2 phenotype\n\n",
"Links: ",
- namesof("p", link),
+ namesof("p", link, earg= earg),
"\n",
"Variance: multinomial type variance"),
initialize=eval(substitute(expression({
delete.zero.colns <- FALSE
eval(process.categorical.data.vgam)
- predictors.names <- namesof("p", .link, tag=FALSE)
+ predictors.names <- namesof("p", .link, earg= .earg, tag=FALSE)
if(is.null(etastart)) {
p.init <- if(is.numeric(.init.p)) rep(.init.p, n) else
c(1 - 2 * sqrt(mustart[,4]))
- etastart <- theta2eta(p.init, .link)
+ etastart <- theta2eta(p.init, .link, earg= .earg)
}
- }), list(.link=link, .init.p=init.p))),
+ }), list(.link=link, .init.p=init.p,
+ .earg=earg ))),
inverse=eval(substitute(function(eta,extra=NULL){
- p <- eta2theta(eta, link=.link)
+ p <- eta2theta(eta, link=.link, earg= .earg)
cbind("A-B-"=(2+(1-p)^2),
"A-bb"=(1-(1-p)^2),
"aaB-"=(1-(1-p)^2),
"aabb"=(1-p)^2) / 4
- }, list(.link=link) )),
+ }, list(.link=link,
+ .earg=earg ) )),
last=eval(substitute(expression({
misc$link <- c(p = .link)
- }), list(.link=link) )),
+ misc$earg = list(p= .earg )
+ }), list(.link=link,
+ .earg=earg ) )),
link=eval(substitute(function(mu, extra=NULL){
p <- 1 - 2 * sqrt(mu[,4])
- theta2eta(p, .link)
- }, list(.link=link) )),
+ theta2eta(p, .link, earg= .earg)
+ }, list(.link=link,
+ .earg=earg ) )),
loglikelihood= function(mu,y,w,residuals=FALSE,eta,extra=NULL)
if(residuals) stop("loglikelihood residuals not implemented yet") else
sum((w*y)*log(mu)),
vfamily=c("AB.Ab.aB.ab2", "vgenetic"),
deriv=eval(substitute(expression({
- pp <- eta2theta(eta, link=.link)
+ pp <- eta2theta(eta, link=.link, earg= .earg)
dP1 <- cbind(-0.5*(1-pp), 0.5*(1-pp), 0.5*(1-pp), -0.5*(1-pp))
dl1 <- apply(y * dP1 / mu, 1, sum)
- dPP.deta <- dtheta.deta(pp, link=.link)
+ dPP.deta <- dtheta.deta(pp, link=.link, earg= .earg)
w * dPP.deta * dl1
- }), list(.link=link) )),
+ }), list(.link=link,
+ .earg=earg ) )),
weight=eval(substitute(expression({
wz <- apply(dP1 * dP1 / mu, 1, sum) * dPP.deta^2
w * wz
- }), list(.link=link) )))
+ }), list(.link=link,
+ .earg=earg ) )))
}
-A1A2A3 <- function(link="logit", ip1=NULL, ip2=NULL)
+A1A2A3 <- function(link="logit", earg = list(), ip1=NULL, ip2=NULL)
{
if(mode(link) != "character" && mode(link) != "name")
link <- as.character(substitute(link))
+ if(!is.list(earg)) earg = list()
new("vglmff",
blurb=c("A1A2A3 Allele System (A1A1, A1A2, A2A2, A1A3, A2A3, A3A3)\n\n",
"Links: ",
- namesof("p1",link), ", ",
- namesof("p2", link, tag=FALSE),
+ namesof("p1",link, earg= earg), ", ",
+ namesof("p2", link, earg= earg, tag=FALSE),
"\n",
"Variance: multinomial type variance"),
initialize=eval(substitute(expression({
delete.zero.colns <- FALSE
eval(process.categorical.data.vgam)
- predictors.names <- c(namesof("p_A",.link,tag=FALSE),
- namesof("p_B",.link,tag=FALSE))
+ predictors.names <- c(namesof("pA", .link, earg= .earg,tag=FALSE),
+ namesof("pB", .link, earg= .earg,tag=FALSE))
if(is.null(etastart)) {
p1 <- if(is.numeric(.ip1)) rep(.ip1, n) else
c(sqrt(mustart[,1]))
p2 <- if(is.numeric(.ip2)) rep(.ip2, n) else
c(sqrt(mustart[,3]))
- etastart <- cbind(theta2eta(p1,.link), theta2eta(p2,.link))
+ etastart <- cbind(theta2eta(p1, .link, earg= .earg),
+ theta2eta(p2, .link, earg= .earg))
}
- }), list(.link=link, .ip1=ip1, .ip2=ip2))),
+ }), list(.link=link, .ip1=ip1, .ip2=ip2,
+ .earg=earg ))),
inverse=eval(substitute(function(eta, extra=NULL){
- p1 <- eta2theta(eta[,1], link=.link)
- p2 <- eta2theta(eta[,2], link=.link)
+ p1 <- eta2theta(eta[,1], link=.link, earg= .earg)
+ p2 <- eta2theta(eta[,2], link=.link, earg= .earg)
qq <- 1-p1-p2
cbind(A1A1=p1*p1, A1A2=2*p1*p2, A2A2=p2*p2, A1A3=2*p1*qq,
A2A3=2*p2*qq, A3A3=qq*qq)
- }, list(.link=link))),
+ }, list(.link=link,
+ .earg=earg ))),
last=eval(substitute(expression({
misc$link <- c(p1= .link, p2= .link)
- }), list(.link=link))),
+ misc$earg = list(p1= .earg, p2= .earg )
+ }), list(.link=link,
+ .earg=earg ))),
link=eval(substitute(function(mu, extra=NULL){
p1 <- sqrt(mu[,1])
p2 <- sqrt(mu[,3])
qq <- 1-p1-p2
- cbind(theta2eta(p1,.link), theta2eta(p2,.link))
- }, list(.link=link))),
+ cbind(theta2eta(p1, .link, earg= .earg),
+ theta2eta(p2, .link, earg= .earg))
+ }, list(.link=link,
+ .earg=earg ))),
loglikelihood=function(mu,y,w,residuals=FALSE,eta,extra=NULL)
if(residuals) stop("loglikelihood residuals not implemented yet") else
sum((w*y)*log(mu)),
vfamily=c("A1A2A3", "vgenetic"),
deriv=eval(substitute(expression({
- p1 <- eta2theta(eta[,1], link=.link)
- p2 <- eta2theta(eta[,2], link=.link)
+ p1 <- eta2theta(eta[,1], link=.link, earg= .earg)
+ p2 <- eta2theta(eta[,2], link=.link, earg= .earg)
dl.dp1 <- (2*y[,1]+y[,2]+y[,4])/p1 - (2*y[,6]+y[,4]+y[,5])/(1-p1-p2)
dl.dp2 <- (2*y[,3]+y[,2]+y[,5])/p2 - (2*y[,6]+y[,4]+y[,5])/(1-p1-p2)
- dp1.deta <- dtheta.deta(p1, link=.link)
- dp2.deta <- dtheta.deta(p2, link=.link)
+ dp1.deta <- dtheta.deta(p1, link=.link, earg= .earg)
+ dp2.deta <- dtheta.deta(p2, link=.link, earg= .earg)
w * cbind(dl.dp1 * dp1.deta, dl.dp2 * dp2.deta)
- }), list(.link=link))),
+ }), list(.link=link,
+ .earg=earg ))),
weight=eval(substitute(expression({
qq <- 1-p1-p2
wz <- matrix(as.numeric(NA), n, dimm(M)) # dimm(M)==3 because M==2
@@ -289,31 +321,34 @@ A1A2A3 <- function(link="logit", ip1=NULL, ip2=NULL)
wz[,iam(2,2,M)] <- dp2.deta^2 * ed2l.dp22
wz[,iam(1,2,M)] <- ed2l.dp1dp2 * dp1.deta * dp2.deta
w * wz
- }), list(.link=link))))
+ }), list(.link=link,
+ .earg=earg ))))
}
-MNSs <- function(link="logit", imS=NULL, ims=NULL, inS=NULL)
+MNSs <- function(link="logit", earg = list(), imS=NULL, ims=NULL, inS=NULL)
{
if(mode(link) != "character" && mode(link) != "name")
link <- as.character(substitute(link))
+ if(!is.list(earg)) earg = list()
new("vglmff",
blurb=c("MNSs Blood Group System (MS-Ms-MNS-MNs-NS-Ns phenotype)\n\n",
"Links: ",
- namesof("mS",link), ", ",
- namesof("ms",link), ", ",
- namesof("nS", link, tag=FALSE),
+ namesof("mS",link, earg= earg), ", ",
+ namesof("ms",link, earg= earg), ", ",
+ namesof("nS", link, earg= earg, tag=FALSE),
"\n",
"Variance: multinomial type variance"),
initialize=eval(substitute(expression({
delete.zero.colns <- FALSE
eval(process.categorical.data.vgam)
- predictors.names <- c(namesof("mS",.link,tag=FALSE),
- namesof("ms",.link,tag=FALSE),
- namesof("nS",.link,tag=FALSE))
+ predictors.names <-
+ c(namesof("mS", .link, earg= .earg,tag=FALSE),
+ namesof("ms", .link, earg= .earg,tag=FALSE),
+ namesof("nS", .link, earg= .earg,tag=FALSE))
if(is.null(etastart)) {
ms <- if(is.numeric(.ims)) rep(.ims, n) else
c(sqrt(mustart[,2]))
@@ -322,39 +357,44 @@ MNSs <- function(link="logit", imS=NULL, ims=NULL, inS=NULL)
c(-ns + sqrt(ns^2 + mustart[,5])) # Solve a quadratic eqn
mS <- if(is.numeric(.imS)) rep(.imS, n) else
1-ns-ms-nS
- etastart <- cbind(theta2eta(mS,.link),
- theta2eta(ms,.link),
- theta2eta(nS,.link))
+ etastart <- cbind(theta2eta(mS, .link, earg= .earg),
+ theta2eta(ms, .link, earg= .earg),
+ theta2eta(nS, .link, earg= .earg))
}
- }), list(.link=link, .imS=imS, .ims=ims, .inS=inS))),
+ }), list(.link=link, .imS=imS, .ims=ims, .inS=inS,
+ .earg=earg ))),
inverse=eval(substitute(function(eta, extra=NULL){
- mS <- eta2theta(eta[,1], link=.link)
- ms <- eta2theta(eta[,2], link=.link)
- nS <- eta2theta(eta[,3], link=.link)
+ mS <- eta2theta(eta[,1], link=.link, earg= .earg)
+ ms <- eta2theta(eta[,2], link=.link, earg= .earg)
+ nS <- eta2theta(eta[,3], link=.link, earg= .earg)
ns <- 1-mS-ms-nS
cbind(MS=mS^2+2*mS*ms, Ms=ms^2, MNS=2*(mS*nS+ms*nS+mS*ns),
MNs=2*ms*ns, NS=nS^2 + 2*nS*ns, Ns=ns^2)
- }, list(.link=link))),
+ }, list(.link=link,
+ .earg=earg ))),
last=eval(substitute(expression({
misc$link <- c(mS= .link, ms= .link, nS= .link)
- }), list(.link=link))),
+ misc$earg = list(mS= .earg, ms= .earg, nS= .earg )
+ }), list(.link=link,
+ .earg=earg ))),
link=eval(substitute(function(mu, extra=NULL){
ms <- sqrt(mu[,2])
ns <- sqrt(mu[,6])
nS <- c(-nS + sqrt(nS^2 + mu[,5]))
mS <- 1-ns-ms-nS
- cbind(theta2eta(mS,.link),
- theta2eta(ms,.link),
- theta2eta(nS,.link))
- }, list(.link=link))),
+ cbind(theta2eta(mS, .link, earg= .earg),
+ theta2eta(ms, .link, earg= .earg),
+ theta2eta(nS, .link, earg= .earg))
+ }, list(.link=link,
+ .earg=earg ))),
loglikelihood=function(mu,y,w,residuals=FALSE,eta,extra=NULL)
if(residuals) stop("loglikelihood residuals not implemented yet") else
sum((w*y)*log(mu)),
vfamily=c("MNSs", "vgenetic"),
deriv=eval(substitute(expression({
- mS <- eta2theta(eta[,1], link=.link)
- ms <- eta2theta(eta[,2], link=.link)
- nS <- eta2theta(eta[,3], link=.link)
+ mS <- eta2theta(eta[,1], link=.link, earg= .earg)
+ ms <- eta2theta(eta[,2], link=.link, earg= .earg)
+ nS <- eta2theta(eta[,3], link=.link, earg= .earg)
ns <- 1-mS-ms-nS
dP1 <- cbind(2*(mS+ms), 0, 2*(nS+ns-mS), -2*ms, -2*nS, -2*ns)
dP2 <- cbind(2*mS, 2*ms, 2*(nS-mS), 2*(ns-ms), -2*nS, -2*ns)
@@ -362,9 +402,10 @@ MNSs <- function(link="logit", imS=NULL, ims=NULL, inS=NULL)
dl1 <- apply(y * dP1 / mu, 1, sum)
dl2 <- apply(y * dP2 / mu, 1, sum)
dl3 <- apply(y * dP3 / mu, 1, sum)
- dPP.deta <- dtheta.deta(cbind(mS,ms,nS), link=.link)
+ dPP.deta <- dtheta.deta(cbind(mS,ms,nS), link=.link, earg= .earg)
w * dPP.deta * cbind(dl1, dl2, dl3)
- }), list(.link=link))),
+ }), list(.link=link,
+ .earg=earg ))),
weight=eval(substitute(expression({
dPP <- array(c(dP1,dP2,dP3), c(n,6,3))
wz <- matrix(as.numeric(NA), n, dimm(M)) # dimm(M)==6 because M==3
@@ -375,44 +416,53 @@ MNSs <- function(link="logit", imS=NULL, ims=NULL, inS=NULL)
mu, 1, sum) * dPP.deta[,i1] * dPP.deta[,i2]
}
w * wz
- }), list(.link=link))))
+ }), list(.link=link,
+ .earg=earg ))))
}
-ABO <- function(link="logit", ir=NULL, ip=NULL)
+ABO <- function(link="logit", earg = list(), ir=NULL, ip=NULL)
{
if(mode(link) != "character" && mode(link) != "name")
link <- as.character(substitute(link))
+ if(!is.list(earg)) earg = list()
new("vglmff",
blurb=c("ABO Blood Group System (A-B-AB-O phenotype)\n\n",
"Links: ",
- namesof("p",link), ", ",
- namesof("q", link, tag=FALSE),
+ namesof("p",link, earg= earg), ", ",
+ namesof("q", link, earg= earg, tag=FALSE),
"\n",
"Variance: multinomial type variance"),
initialize=eval(substitute(expression({
delete.zero.colns <- FALSE
eval(process.categorical.data.vgam)
- predictors.names <- c(namesof("p_A",.link,tag=FALSE), namesof("p_B",.link,tag=FALSE))
+ predictors.names <-
+ c(namesof("pA", .link, earg= .earg,tag=FALSE),
+ namesof("pB", .link, earg= .earg,tag=FALSE))
if(is.null(etastart)) {
r <- if(is.numeric(.ir)) rep(.ir, n) else
c(sqrt(mustart[,4]))
p <- if(is.numeric(.ip)) rep(.ip, n) else
c(1-sqrt(mustart[,2]+mustart[,4]))
q <- 1-p-r
- etastart <- cbind(theta2eta(p,.link), theta2eta(q,.link))
+ etastart <- cbind(theta2eta(p, .link, earg= .earg),
+ theta2eta(q, .link, earg= .earg))
}
- }), list(.link=link, .ir=ir, .ip=ip))),
+ }), list(.link=link, .ir=ir, .ip=ip,
+ .earg=earg ))),
inverse=eval(substitute(function(eta, extra=NULL){
- p <- eta2theta(eta[,1], link=.link)
- q <- eta2theta(eta[,2], link=.link)
+ p <- eta2theta(eta[,1], link=.link, earg= .earg)
+ q <- eta2theta(eta[,2], link=.link, earg= .earg)
r <- 1-p-q
cbind(A=p*(p+2*r), B=q*(q+2*r), AB=2*p*q, O=r*r)
- }, list(.link=link))),
+ }, list(.link=link,
+ .earg=earg ))),
last=eval(substitute(expression({
misc$link <- c(p = .link, q = .link)
- }), list(.link=link))),
+ misc$earg = list(p= .earg, q= .earg )
+ }), list(.link=link,
+ .earg=earg ))),
link=eval(substitute(function(mu, extra=NULL){
r <- sqrt(mu[,4])
p1 <- ( (1-r)+sqrt((1-r)^2 + 2*mu[,3]) )/2
@@ -421,16 +471,18 @@ ABO <- function(link="logit", ir=NULL, ip=NULL)
p <- p1
p[index] <- p2[index]
q <- 1-p-r
- cbind(theta2eta(p,.link), theta2eta(q,.link))
- }, list(.link=link))),
+ cbind(theta2eta(p, .link, earg= .earg),
+ theta2eta(q, .link, earg= .earg))
+ }, list(.link=link,
+ .earg=earg ))),
loglikelihood=function(mu,y,w,residuals=FALSE,eta,extra=NULL)
if(residuals) stop("loglikelihood residuals not implemented yet") else
sum((w*y)*log(mu)),
vfamily=c("ABO", "vgenetic"),
deriv=eval(substitute(expression({
- p <- eta2theta(eta[,1], link=.link)
- q <- eta2theta(eta[,2], link=.link)
+ p <- eta2theta(eta[,1], link=.link, earg= .earg)
+ q <- eta2theta(eta[,2], link=.link, earg= .earg)
r <- 1-p-q
pbar <- 2*r+p
qbar <- 2*r+q
@@ -440,10 +492,11 @@ ABO <- function(link="logit", ir=NULL, ip=NULL)
no <- y[,4]
dl.dp <- (na+nab)/p - na/pbar - 2*nb/qbar - 2*no/r
dl.dq <- (nb+nab)/q - 2*na/pbar - nb/qbar - 2*no/r
- dp.deta <- dtheta.deta(p, link=.link)
- dq.deta <- dtheta.deta(q, link=.link)
+ dp.deta <- dtheta.deta(p, link=.link, earg= .earg)
+ dq.deta <- dtheta.deta(q, link=.link, earg= .earg)
w * cbind(dl.dp * dp.deta, dl.dq * dq.deta)
- }), list(.link=link))),
+ }), list(.link=link,
+ .earg=earg ))),
weight=eval(substitute(expression({
wz <- matrix(as.numeric(NA), n, dimm(M)) # dimm(M)==3 because M==2
ed2l.dp2 <- w * (1 + 2/p + 4*q/qbar + p/pbar)
@@ -453,118 +506,135 @@ ABO <- function(link="logit", ir=NULL, ip=NULL)
wz[,iam(2,2,M)] <- dq.deta^2 * ed2l.dq2
wz[,iam(1,2,M)] <- ed2l.dpdq * dp.deta * dq.deta
wz
- }), list(.link=link))))
+ }), list(.link=link,
+ .earg=earg ))))
}
-AB.Ab.aB.ab <- function(link="logit", init.p=NULL)
+AB.Ab.aB.ab <- function(link="logit", earg = list(), init.p=NULL)
{
if(mode(link) != "character" && mode(link) != "name")
link <- as.character(substitute(link))
+ if(!is.list(earg)) earg = list()
new("vglmff",
blurb=c("AB-Ab-aB-ab phenotype\n\n",
- "Links: ", namesof("p", link, tag=TRUE), "\n",
+ "Links: ", namesof("p", link, earg= earg, tag=TRUE), "\n",
"Variance: multinomial type variance"),
initialize=eval(substitute(expression({
delete.zero.colns <- FALSE
eval(process.categorical.data.vgam)
- predictors.names <- namesof("p", .link, tag=FALSE)
+ predictors.names <- namesof("p", .link, earg= .earg, tag=FALSE)
if(is.null(etastart)) {
p <- if(is.numeric(.init.p)) rep(.init.p,n) else
c(sqrt(4*mustart[,4]))
- etastart <- cbind(theta2eta(p, .link))
+ etastart <- cbind(theta2eta(p, .link, earg= .earg))
}
- }), list(.link=link, .init.p=init.p))),
+ }), list(.link=link, .init.p=init.p,
+ .earg=earg ))),
inverse=eval(substitute(function(eta,extra=NULL){
- p <- eta2theta(eta, link=.link)
+ p <- eta2theta(eta, link=.link, earg= .earg)
pp4 <- p*p/4
cbind(AB=0.5+pp4, Ab=0.25-pp4, aB=0.25-pp4, ab=pp4)
- }, list(.link=link))),
+ }, list(.link=link,
+ .earg=earg ))),
last=eval(substitute(expression({
misc$link <- c(p = .link)
- }), list(.link=link))),
+ misc$earg = list(p= .earg )
+ }), list(.link=link,
+ .earg=earg ))),
link=eval(substitute(function(mu, extra=NULL){
p <- sqrt(4* mu[,4])
- theta2eta(p, .link)
- }, list(.link=link))),
+ theta2eta(p, .link, earg= .earg)
+ }, list(.link=link,
+ .earg=earg ))),
loglikelihood=function(mu,y,w,residuals=FALSE,eta,extra=NULL)
if(residuals) stop("loglikelihood residuals not implemented yet") else
sum((w*y)*log(mu)),
vfamily=c("AB.Ab.aB.ab", "vgenetic"),
deriv=eval(substitute(expression({
- pp <- eta2theta(eta, link=.link)
+ pp <- eta2theta(eta, link=.link, earg= .earg)
p2 <- pp*pp
nAB <- w*y[,1]
nAb <- w*y[,2]
naB <- w*y[,3]
nab <- w*y[,4]
dl.dp <- 8 * pp * (nAB/(2+p2) - (nAb+naB)/(1-p2) + nab/p2)
- dp.deta <- dtheta.deta(pp, link=.link)
+ dp.deta <- dtheta.deta(pp, link=.link, earg= .earg)
dl.dp * dp.deta
- }), list(.link=link))),
+ }), list(.link=link,
+ .earg=earg ))),
weight=eval(substitute(expression({
ed2l.dp2 <- 4 * w * p2 * (1/(2+p2) + 2/(1-p2) + 1/p2)
wz <- cbind((dp.deta^2) * ed2l.dp2)
wz
- }), list(.link=link))))
+ }), list(.link=link,
+ .earg=earg ))))
}
-AA.Aa.aa <- function(link="logit", init.pA=NULL)
+AA.Aa.aa <- function(link="logit", earg = list(), init.pA=NULL)
{
if(mode(link) != "character" && mode(link) != "name")
link <- as.character(substitute(link))
+ if(!is.list(earg)) earg = list()
new("vglmff",
blurb=c("AA-Aa-aa phenotype\n\n",
- "Links: ", namesof("p_A",link), "\n",
+ "Links: ", namesof("pA",link, earg= earg), "\n",
"Variance: multinomial type variance"),
initialize=eval(substitute(expression({
delete.zero.colns <- FALSE
eval(process.categorical.data.vgam)
- predictors.names <- namesof("p_A", .link, tag=FALSE)
+ predictors.names <- namesof("pA", .link, earg= .earg, tag=FALSE)
if(is.null(etastart)) {
pA <- if(is.numeric(.init.pA)) rep(.init.pA, n) else
c(sqrt(mustart[,1]))
- etastart <- cbind(theta2eta(pA, .link))
+ etastart <- cbind(theta2eta(pA, .link, earg= .earg))
}
- }), list(.link=link, .init.pA=init.pA))),
+ }), list(.link=link, .init.pA=init.pA,
+ .earg=earg ))),
inverse=eval(substitute(function(eta,extra=NULL){
- pA <- eta2theta(eta, link=.link)
+ pA <- eta2theta(eta, link=.link, earg= .earg)
pp <- pA*pA
cbind(AA=pp, Aa=2*pA*(1-pA), aa=(1-pA)^2)
- }, list(.link=link))),
+ }, list(.link=link,
+ .earg=earg ))),
last=eval(substitute(expression({
- misc$link <- c("p_A" = .link)
- }), list(.link=link))),
+ misc$link <- c("pA" = .link)
+ misc$earg = list("pA" = .earg )
+ }), list(.link=link,
+ .earg=earg ))),
link=eval(substitute(function(mu, extra=NULL){
pA <- sqrt(mu[,1])
- theta2eta(pA, .link)
- }, list(.link=link))),
+ theta2eta(pA, .link, earg= .earg)
+ }, list(.link=link,
+ .earg=earg ))),
loglikelihood=function(mu,y,w,residuals=FALSE,eta,extra=NULL)
if(residuals) stop("loglikelihood residuals not implemented yet") else
sum((w*y)*log(mu)),
vfamily=c("AA.Aa.aa", "vgenetic"),
deriv=eval(substitute(expression({
- pA <- eta2theta(eta, link=.link)
+ pA <- eta2theta(eta, link=.link, earg= .earg)
nAA <- w*y[,1]
nAa <- w*y[,2]
naa <- w*y[,3]
dl.dpA <- (2*nAA+nAa)/pA - (nAa+2*naa)/(1-pA)
- dpA.deta <- dtheta.deta(pA, link=.link)
+ dpA.deta <- dtheta.deta(pA, link=.link, earg= .earg)
dl.dpA * dpA.deta
- }), list(.link=link))),
+ }), list(.link=link,
+ .earg=earg ))),
weight=eval(substitute(expression({
d2l.dp2 <- (2*nAA+nAa)/pA^2 + (nAa+2*naa)/(1-pA)^2
wz <- cbind((dpA.deta^2) * d2l.dp2)
wz
- }), list(.link=link))))
+ }), list(.link=link,
+ .earg=earg ))))
}
diff --git a/R/family.glmgam.q b/R/family.glmgam.q
index e940675..ff4ccb4 100644
--- a/R/family.glmgam.q
+++ b/R/family.glmgam.q
@@ -5,9 +5,9 @@
-quasiff = function(link,
- variance=c("mu", "mu(1-mu)"),
- power.variance=1,
+if(FALSE)
+quasiff = function(link="polw",
+ earg=if(link=="powl") list(power=1) else list(),
dispersion=0)
{
warning("link=powl doesn't work yet")
@@ -15,16 +15,14 @@ quasiff = function(link,
if(mode(link )!= "character" && mode(link )!= "name")
link <- as.character(substitute(link))
+ if(!is.list(earg)) earg = list()
- if(mode(variance) != "character" && mode(variance) != "name")
- variance <- as.character(substitute(variance))
- variance <- match.arg(variance, c("mu", "mu(1-mu)"))[1]
result <-
new("vglmff",
blurb=c("Quasi family\n\n",
- "Link: ", namesof("mu", link), "\n",
+ "Link: ", namesof("mu", link, earg=earg), "\n",
"Variance: ", ifelse(power.variance==1, variance,
paste(variance, "^", power.variance, sep=""))),
deviance= function(mu, y, w, residuals = FALSE, eta, extra=NULL) {
@@ -56,10 +54,12 @@ quasiff = function(link,
}
- }), list( .link=link, .variance=variance, .power.variance=power.variance ))),
+ }), list( .link=link, .variance=variance,
+ .earg=earg, .power.variance=power.variance ))),
inverse=eval(substitute(function(eta, extra=NULL) {
- eta2theta(eta, link= .link)
- }, list( .link=link ))),
+ eta2theta(eta, link= .link, earg=.earg)
+ }, list( .link=link,
+ .earg=earg ))),
last=eval(substitute(expression({
dpar <- .dispersion
if(!dpar) {
@@ -71,24 +71,28 @@ quasiff = function(link,
misc$estimated.dispersion <- .estimated.dispersion
misc$power.variance <- .power.variance
misc$link = c("mu" = .link )
- }), list( .dispersion=dispersion, .estimated.dispersion=estimated.dispersion,
+ }), list( .dispersion=dispersion,
+ .earg=earg, .estimated.dispersion=estimated.dispersion,
.link=link, .power.variance=power.variance ))),
link=eval(substitute(function(mu, extra=NULL) {
- theta2eta(mu, link= .link)
- }, list( .link=link ))),
+ theta2eta(mu, link= .link, earg=.earg)
+ }, list( .link=link,
+ .earg=earg ))),
vfamily="quasiff",
deriv=eval(substitute(expression({
pow <- extra$power.variance
thing <- extra$variance
dQ.dmu <- if(thing=="mu") (y-mu)/mu^pow else (y-mu)/(mu*(1-mu))^pow
- dmu.deta <- dtheta.deta(theta=mu, link= .link)
+ dmu.deta <- dtheta.deta(theta=mu, link= .link, earg=.earg)
w * dQ.dmu * dmu.deta
- }), list( .link=link, .power.variance=power.variance ))),
+ }), list( .link=link, .power.variance=power.variance,
+ .earg=earg ))),
weight=eval(substitute(expression({
d2Q.dmu2 <- if(thing=="mu") 1 / mu^pow else
1 / (mu*(1-mu))^pow
w * dmu.deta^2 * d2Q.dmu2
- }), list( .link=link, .power.variance=power.variance ))))
+ }), list( .link=link, .power.variance=power.variance,
+ .earg=earg ))))
if(variance=="mu") {
if(power.variance==1)
@@ -104,9 +108,9 @@ quasiff = function(link,
-binomialff <- function(link="logit",
+binomialff <- function(link="logit", earg=list(),
dispersion=1, mv=FALSE, onedpar=!mv,
- parallel = FALSE, earg=NULL,
+ parallel = FALSE,
zero=NULL)
{
@@ -115,13 +119,14 @@ binomialff <- function(link="logit",
estimated.dispersion <- dispersion==0
if(mode(link )!= "character" && mode(link )!= "name")
link <- as.character(substitute(link))
+ if(!is.list(earg)) earg = list()
new("vglmff",
blurb=if(mv) c("Multivariate Binomial model\n\n",
- "Link: ", namesof("mu[,j]", link), "\n",
+ "Link: ", namesof("mu[,j]", link, earg= earg), "\n",
"Variance: mu[,j]*(1-mu[,j])") else
c("Binomial model\n\n",
- "Link: ", namesof("mu", link), "\n",
+ "Link: ", namesof("mu", link, earg= earg), "\n",
"Variance: mu*(1-mu)"),
constraints=eval(substitute(expression({
constraints <- cm.vgam(matrix(1,M,1), x, .parallel, constraints)
@@ -170,7 +175,8 @@ binomialff <- function(link="logit",
} else {
paste("mu", 1:M, sep="")
}
- predictors.names = namesof(if(M>1) dn2 else "mu", .link, short=TRUE)
+ predictors.names = namesof(if(M>1) dn2 else
+ "mu", .link, earg= .earg, short=TRUE)
mustart = (0.5 + w * y) / (1 + w)
} else {
@@ -196,9 +202,9 @@ binomialff <- function(link="logit",
mustart = (0.5 + nn * y) / (1 + nn)
} else
stop("Response not of the right form")
- predictors.names = namesof("mu", .link, short=TRUE)
+ predictors.names = namesof("mu", .link, earg= .earg, short=TRUE)
}
- }), list( .link=link, .mv=mv ))),
+ }), list( .link=link, .mv=mv, .earg=earg ))),
inverse=eval(substitute(function(eta, extra=NULL) {
mu = eta2theta(eta, link= .link, earg = .earg)
mu
@@ -233,11 +239,14 @@ binomialff <- function(link="logit",
misc$mv = .mv
misc$dispersion <- dpar
misc$default.dispersion <- 1
- misc$earg = .earg
misc$estimated.dispersion <- .estimated.dispersion
-
misc$link = rep( .link, length=M)
names(misc$link) = if(M>1) dn2 else "mu"
+
+ misc$earg = vector("list", M)
+ names(misc$earg) = names(misc$link)
+ for(ii in 1:M) misc$earg[[ii]] = .earg
+
misc$expected = TRUE
}), list( .dispersion=dispersion, .estimated.dispersion=estimated.dispersion,
.onedpar=onedpar, .link=link, .mv=mv, .earg = earg ))),
@@ -284,17 +293,17 @@ binomialff <- function(link="logit",
-gammaff <- function(link=c("nreciprocal", "reciprocal", "loge", "identity"),
+gammaff <- function(link="nreciprocal", earg=list(),
dispersion=0)
{
estimated.dispersion <- dispersion==0
if(mode(link )!= "character" && mode(link )!= "name")
link <- as.character(substitute(link))
- link = match.arg(link, c("nreciprocal","reciprocal","loge","identity"))[1]
+ if(!is.list(earg)) earg = list()
new("vglmff",
blurb=c("Gamma distribution\n\n",
- "Link: ", namesof("mu", link), "\n",
+ "Link: ", namesof("mu", link, earg=earg), "\n",
"Variance: mu^2 / k"),
deviance= function(mu, y, w, residuals = FALSE, eta, extra=NULL) {
devi <- -2 * w * (log(ifelse(y == 0, 1, y/mu)) - (y - mu)/mu)
@@ -311,13 +320,14 @@ gammaff <- function(link=c("nreciprocal", "reciprocal", "loge", "identity"),
} else {
paste("mu", 1:M, sep="")
}
- predictors.names = namesof(if(M>1) dn2 else "mu", .link, short=TRUE)
+ predictors.names = namesof(if(M>1) dn2 else "mu", .link,
+ earg=.earg, short=TRUE)
if(!length(etastart))
- etastart <- theta2eta(mustart, link= .link)
- }), list( .link=link ))),
+ etastart <- theta2eta(mustart, link= .link, earg=.earg)
+ }), list( .link=link, .earg=earg ))),
inverse=eval(substitute(function(eta, extra=NULL) {
- eta2theta(eta, link= .link)
- }, list( .link=link ))),
+ eta2theta(eta, link= .link, earg=.earg)
+ }, list( .link=link, .earg=earg ))),
last=eval(substitute(expression({
dpar <- .dispersion
if(!dpar) {
@@ -337,24 +347,29 @@ gammaff <- function(link=c("nreciprocal", "reciprocal", "loge", "identity"),
misc$default.dispersion <- 0
misc$estimated.dispersion <- .estimated.dispersion
misc$link = rep( .link, length=M)
- misc$expected = TRUE
names(misc$link) = if(M>1) paste("mu", 1:M, sep="") else "mu"
- }), list( .dispersion=dispersion,
+
+ misc$earg = vector("list", M)
+ names(misc$earg) = names(misc$link)
+ for(ii in 1:M) misc$earg[[ii]] = .earg
+
+ misc$expected = TRUE
+ }), list( .dispersion=dispersion, .earg=earg,
.estimated.dispersion=estimated.dispersion,
.link=link ))),
link=eval(substitute(function(mu, extra=NULL) {
- theta2eta(mu, link= .link)
- }, list( .link=link ))),
+ theta2eta(mu, link= .link, earg=.earg)
+ }, list( .link=link, .earg=earg ))),
vfamily="gammaff",
deriv=eval(substitute(expression({
dl.dmu = (y-mu) / mu^2
- dmu.deta = dtheta.deta(theta=mu, link= .link)
+ dmu.deta = dtheta.deta(theta=mu, link= .link, earg=.earg)
w * dl.dmu * dmu.deta
- }), list( .link=link ))),
+ }), list( .link=link, .earg=earg ))),
weight=eval(substitute(expression({
d2l.dmu2 = 1 / mu^2
w * dmu.deta^2 * d2l.dmu2
- }), list( .link=link ))))
+ }), list( .link=link, .earg=earg ))))
}
@@ -367,6 +382,7 @@ inverse.gaussianff <- function(link="natural.ig", dispersion=0)
if(mode(link )!= "character" && mode(link )!= "name")
link <- as.character(substitute(link))
+ if(!is.list(earg)) earg = list()
new("vglmff",
blurb=c("Inverse Gaussian distribution\n\n",
@@ -449,8 +465,27 @@ pinv.gaussian = function(q, mu, lambda) {
ans
}
-inv.gaussianff <- function(lmu="loge",
- llambda="loge",
+
+rinv.gaussian = function(n, mu, lambda) {
+ if(!is.Numeric(n, positive=TRUE, integer=TRUE, allow=1))
+ stop("'n' must be a single positive integer")
+ if(!is.Numeric(mu, positive=TRUE))
+ stop("'mu' must have positive values only")
+ if(!is.Numeric(lambda, positive=TRUE))
+ stop("'lambda' must have positive values only")
+ mu = rep(mu, len=n)
+ lambda = rep(lambda, len=n)
+ u = runif(n)
+ z = rnorm(n)^2
+ phi = lambda / mu
+ y1 = 1 - 0.5 * (sqrt(z^2 + 4*phi*z) - z) / phi
+ mu * ifelse((1+y1)*u > 1, 1/y1, y1)
+}
+
+
+
+inv.gaussianff <- function(lmu="loge", llambda="loge",
+ emu=list(), elambda=list(),
ilambda=1,
zero=NULL)
{
@@ -458,61 +493,69 @@ inv.gaussianff <- function(lmu="loge",
lmu <- as.character(substitute(lmu))
if(mode(llambda) != "character" && mode(llambda) != "name")
llambda <- as.character(substitute(llambda))
+ if(!is.list(emu)) emu = list()
+ if(!is.list(elambda)) elambda = list()
new("vglmff",
blurb=c("Inverse Gaussian distribution\n\n",
"f(y) = sqrt(lambda/(2*pi*y^3)) * exp(-lambda*(y-mu)^2/(2*mu^2*y)), y&lambda>0",
- "Link: ", namesof("mu", lmu), ", ",
- namesof("lambda", llambda), "\n",
+ "Link: ", namesof("mu", lmu, earg= emu), ", ",
+ namesof("lambda", llambda, earg= elambda), "\n",
"Mean: ", "mu\n",
"Variance: mu^3 / lambda"),
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")
if(any(y <= 0)) stop("Require the response to have positive values")
- predictors.names = c(namesof("mu", .lmu, short= TRUE),
- namesof("lambda", .llambda, short= TRUE))
+ predictors.names =
+ c(namesof("mu", .lmu, earg= .emu, short= TRUE),
+ namesof("lambda", .llambda, earg= .elambda, short= TRUE))
if(!length(etastart)) {
initmu = y + 1/8
initlambda = rep(if(length( .ilambda)) .ilambda else 1, len=n)
- etastart = cbind(theta2eta(initmu, link=.lmu),
- theta2eta(initlambda, link=.llambda))
+ etastart = cbind(
+ theta2eta(initmu, link=.lmu, earg= .emu),
+ theta2eta(initlambda, link=.llambda, earg= .elambda))
}
}), list( .lmu=lmu, .llambda=llambda,
+ .emu=emu, .elambda=elambda,
.ilambda=ilambda ))),
inverse=eval(substitute(function(eta, extra=NULL) {
- eta2theta(eta[,1], link=.lmu)
- }, list( .lmu=lmu ))),
+ eta2theta(eta[,1], link=.lmu, earg= .emu)
+ }, list( .lmu=lmu, .emu=emu, .elambda=elambda ))),
last=eval(substitute(expression({
misc$link = c(mu = .lmu, lambda = .llambda)
- }), list( .lmu=lmu, .llambda=llambda ))),
+ misc$earg = list(mu = .emu, lambda = .elambda)
+ }), list( .lmu=lmu, .llambda=llambda, .emu=emu, .elambda=elambda ))),
loglikelihood=eval(substitute(
function(mu, y, w, residuals = FALSE, eta, extra=NULL) {
- lambda <- eta2theta(eta[,2], link=.llambda)
+ lambda <- eta2theta(eta[,2], link=.llambda, earg= .elambda)
if(residuals) stop("loglikelihood residuals not implemented yet") else
sum(w*(0.5 * log(lambda / (2 * pi * y^3)) -
lambda *(y-mu)^2 / (2*mu^2 * y)))
- }, list( .llambda=llambda ))),
+ }, list( .llambda=llambda, .emu=emu, .elambda=elambda ))),
vfamily="inv.gaussianff",
deriv=eval(substitute(expression({
- lambda <- eta2theta(eta[,2], link=.llambda)
+ lambda <- eta2theta(eta[,2], link=.llambda, earg= .elambda)
dl.dmu = lambda * (y-mu) / mu^3
dl.dlambda <- 0.5 / lambda - (y-mu)^2 / (2 * mu^2 * y)
- dmu.deta <- dtheta.deta(theta=mu, link=.lmu)
- dlambda.deta <- dtheta.deta(theta=lambda, link=.llambda)
+ dmu.deta <- dtheta.deta(theta=mu, link=.lmu, earg= .emu)
+ dlambda.deta <- dtheta.deta(theta=lambda, link=.llambda, earg= .elambda)
w * cbind(dl.dmu * dmu.deta, dl.dlambda * dlambda.deta)
- }), list( .lmu=lmu, .llambda=llambda ))),
+ }), list( .lmu=lmu, .llambda=llambda, .emu=emu, .elambda=elambda ))),
weight=eval(substitute(expression({
d2l.dmu2 = lambda / mu^3
d2l.dlambda2 = 0.5 / (lambda^2)
w * cbind(dmu.deta^2 * d2l.dmu2, dlambda.deta^2 * d2l.dlambda2)
- }), list( .lmu=lmu, .llambda=llambda ))))
+ }), list( .lmu=lmu, .llambda=llambda, .emu=emu, .elambda=elambda ))))
}
-poissonff <- function(link="loge",
+poissonff <- function(link="loge", earg=list(),
dispersion=1, onedpar=FALSE,
parallel=FALSE, zero=NULL)
{
@@ -520,10 +563,11 @@ poissonff <- function(link="loge",
estimated.dispersion <- dispersion==0
if(mode(link )!= "character" && mode(link )!= "name")
link <- as.character(substitute(link))
+ if(!is.list(earg)) earg = list()
new("vglmff",
blurb=c("Poisson distribution\n\n",
- "Link: ", namesof("mu", link), "\n",
+ "Link: ", namesof("mu", link, earg= earg), "\n",
"Variance: mu"),
constraints=eval(substitute(expression({
constraints <- cm.vgam(matrix(1,M,1), x, .parallel, constraints)
@@ -547,15 +591,17 @@ poissonff <- function(link="loge",
} else {
paste("mu", 1:M, sep="")
}
- predictors.names = namesof(if(M>1) dn2 else "mu", .link, short=TRUE)
- mu = pmax(y, 0.167) # y + 0.167 * (y == 0)
+ predictors.names = namesof(if(M>1) dn2 else "mu", .link,
+ earg= .earg, short=TRUE)
+ mu = pmax(y, 1/8) # y + 0.167 * (y == 0)
if(!length(etastart))
- etastart <- theta2eta(mu, link= .link)
- }), list( .link=link, .estimated.dispersion=estimated.dispersion ))),
+ etastart <- theta2eta(mu, link= .link, earg= .earg)
+ }), list( .link=link, .estimated.dispersion=estimated.dispersion,
+ .earg=earg ))),
inverse=eval(substitute(function(eta, extra=NULL) {
- mu = eta2theta(eta, link= .link)
+ mu = eta2theta(eta, link= .link, earg= .earg)
mu
- }, list( .link=link ))),
+ }, list( .link=link, .earg=earg ))),
last=eval(substitute(expression({
if(is.R()) {
if(exists("CQO.FastAlgorithm", envir = VGAMenv))
@@ -566,7 +612,8 @@ poissonff <- function(link="loge",
}
dpar <- .dispersion
if(!dpar) {
- temp87 = (y-mu)^2 * wz / (dtheta.deta(mu, link= .link)^2) # w cancel
+ temp87 = (y-mu)^2 *
+ wz / (dtheta.deta(mu, link= .link, earg= .earg)^2) # w cancel
if(M > 1 && ! .onedpar) {
dpar = rep(as.numeric(NA), len=M)
temp87 = cbind(temp87)
@@ -584,11 +631,15 @@ poissonff <- function(link="loge",
misc$expected = TRUE
misc$link = rep( .link, length=M)
names(misc$link) = if(M>1) dn2 else "mu"
+
+ misc$earg = vector("list", M)
+ names(misc$earg) = names(misc$link)
+ for(ii in 1:M) misc$earg[[ii]] = .earg
}), list( .dispersion=dispersion, .estimated.dispersion=estimated.dispersion,
- .onedpar=onedpar, .link=link ))),
+ .onedpar=onedpar, .link=link, .earg=earg ))),
link=eval(substitute(function(mu, extra=NULL) {
- theta2eta(mu, link= .link)
- }, list( .link=link ))),
+ theta2eta(mu, link= .link, earg= .earg)
+ }, list( .link=link, .earg=earg ))),
loglikelihood= function(mu, y, w, residuals = FALSE, eta, extra=NULL) {
if(residuals) w*(y/mu - 1) else sum(w*(-mu + y*log(mu) - lgamma(y+1)))
},
@@ -599,10 +650,10 @@ poissonff <- function(link="loge",
} else {
lambda <- mu
dl.dlambda <- (y-lambda) / lambda
- dlambda.deta <- dtheta.deta(theta=lambda, link= .link)
+ dlambda.deta <- dtheta.deta(theta=lambda, link= .link, earg= .earg)
w * dl.dlambda * dlambda.deta
}
- }), list( .link=link ))),
+ }), list( .link=link, .earg=earg ))),
weight=eval(substitute(expression({
if( .link == "loge" && (any(mu < .Machine$double.eps))) {
tmp600 = mu
@@ -612,7 +663,7 @@ poissonff <- function(link="loge",
d2l.dlambda2 = 1 / lambda
w * dlambda.deta^2 * d2l.dlambda2
}
- }), list( .link=link ))))
+ }), list( .link=link, .earg=earg ))))
}
@@ -660,7 +711,7 @@ poissonqn.control <- function(save.weight=TRUE, ...)
}
-poissonqn <- function(link="loge",
+poissonqn <- function(link="loge", earg=list(),
dispersion=1, onedpar=FALSE,
parallel=FALSE, zero=NULL,
wwts=c("expected","observed","qn"))
@@ -671,10 +722,11 @@ poissonqn <- function(link="loge",
if(mode(wwts) != "character" && mode(wwts) != "name")
wwts <- as.character(substitute(wwts))
wwts <- match.arg(wwts, c("expected","observed","qn"))[1]
+ if(!is.list(earg)) earg = list()
new("vglmff",
blurb=c("Poisson distribution\n\n",
- "Link: ", namesof("mu", link), "\n",
+ "Link: ", namesof("mu", link, earg= earg), "\n",
"Variance: mu"),
constraints=eval(substitute(expression({
constraints <- cm.vgam(matrix(1,M,1), x, .parallel, constraints)
@@ -695,18 +747,21 @@ poissonqn <- function(link="loge",
} else {
paste("mu", 1:M, sep="")
}
- predictors.names = namesof(if(M>1) dn2 else "mu", .link, short=TRUE)
+ predictors.names = namesof(if(M>1) dn2 else "mu", .link,
+ earg= .earg, short=TRUE)
mu = pmax(y, 0.167) # y + 0.167 * (y == 0)
if(!length(etastart))
- etastart <- theta2eta(mu, link= .link)
- }), list( .link=link, .estimated.dispersion=estimated.dispersion ))),
+ etastart <- theta2eta(mu, link= .link, earg= .earg)
+ }), list( .link=link, .estimated.dispersion=estimated.dispersion,
+ .earg=earg ))),
inverse=eval(substitute(function(eta, extra=NULL) {
- eta2theta(eta, link= .link)
- }, list( .link=link ))),
+ eta2theta(eta, link= .link, earg= .earg)
+ }, list( .link=link,
+ .earg=earg ))),
last=eval(substitute(expression({
dpar <- .dispersion
if(!dpar) {
- temp87 = (y-mu)^2 * wz / (dtheta.deta(mu, link= .link)^2) # w cancel
+ temp87 = (y-mu)^2 * wz / (dtheta.deta(mu, link= .link, earg= .earg)^2) # w cancel
if(M > 1 && ! .onedpar) {
dpar = rep(as.numeric(NA), len=M)
temp87 = cbind(temp87)
@@ -725,12 +780,18 @@ poissonqn <- function(link="loge",
misc$expected = FALSE
misc$link = rep( .link, length=M)
names(misc$link) = if(M>1) dn2 else "mu"
- }), list( .dispersion=dispersion,
+
+ misc$earg = vector("list", M)
+ names(misc$earg) = names(misc$link)
+ for(ii in 1:M) misc$earg[[ii]] = .earg
+ }), list( .dispersion=dispersion,
+ .earg=earg,
.estimated.dispersion=estimated.dispersion,
.onedpar=onedpar, .link=link ))),
link=eval(substitute(function(mu, extra=NULL) {
- theta2eta(mu, link= .link)
- }, list( .link=link ))),
+ theta2eta(mu, link= .link, earg= .earg)
+ }, list( .link=link,
+ .earg=earg ))),
loglikelihood= function(mu, y, w, residuals = FALSE, eta, extra=NULL) {
if(residuals) w*(y/mu - 1) else sum(w*(-mu + y*log(mu) - lgamma(y+1)))
},
@@ -750,11 +811,12 @@ poissonqn <- function(link="loge",
} else {
lambda <- mu
dl.dlambda <- (y-lambda) / lambda
- dlambda.deta <- dtheta.deta(theta=lambda, link= .link)
+ dlambda.deta <- dtheta.deta(theta=lambda, link= .link, earg= .earg)
w * dl.dlambda * dlambda.deta
}
derivnew
- }), list( .link=link ))),
+ }), list( .link=link,
+ .earg=earg ))),
weight=eval(substitute(expression({
if( .wwts == "qn") {
if(iter == 1) {
@@ -784,7 +846,8 @@ poissonqn <- function(link="loge",
}
}
wznew
- }), list( .wwts=wwts, .link=link ))))
+ }), list( .wwts=wwts, .link=link,
+ .earg=earg ))))
}
diff --git a/R/family.loglin.q b/R/family.loglin.q
index 070f565..c79619c 100644
--- a/R/family.loglin.q
+++ b/R/family.loglin.q
@@ -46,6 +46,7 @@ loglinb2 <- function(exchangeable=FALSE, zero=NULL)
},
last=expression({
misc$link = c("u1" = "identity", "u2" = "identity", "u12" = "identity")
+ misc$earg = list(u1=list(), u2=list(), u12=list())
}),
link= function(mu, extra=NULL) {
u0 <- log(mu[,1])
@@ -162,6 +163,8 @@ loglinb3 <- function(exchangeable=FALSE, zero=NULL)
last=expression({
misc$link = rep("identity", length=M)
names(misc$link) = predictors.names
+ misc$earg = list(u1=list(), u2=list(), u3=list(),
+ u12=list(), u13=list(), u23=list())
}),
link= function(mu, extra=NULL) {
u0 <- log(mu[,1])
diff --git a/R/family.mixture.q b/R/family.mixture.q
index 7de28d1..d5f9cc2 100644
--- a/R/family.mixture.q
+++ b/R/family.mixture.q
@@ -14,6 +14,7 @@ mix2normal1.control <- function(save.weight=TRUE, ...)
mix2normal1 = function(lphi="logit",
lmu="identity",
lsd="loge",
+ ephi=list(), emu1=list(), emu2=list(), esd1=list(), esd2=list(),
iphi=0.5, imu1=NULL, imu2=NULL, isd1=NULL, isd2=NULL,
qmu=c(0.2, 0.8),
esd=FALSE,
@@ -37,15 +38,20 @@ mix2normal1 = function(lphi="logit",
stop("bad input for argument \"isd1\"")
if(length(isd2) && !is.Numeric(isd2, positive=TRUE))
stop("bad input for argument \"isd2\"")
+ if(!is.list(ephi)) ephi = list()
+ if(!is.list(emu1)) emu1 = list()
+ if(!is.list(emu2)) emu2 = list()
+ if(!is.list(esd1)) esd1 = list()
+ if(!is.list(esd2)) esd2 = list()
new("vglmff",
blurb=c("Mixture of two univariate normals\n\n",
"Links: ",
- namesof("phi",lphi), ", ",
- namesof("mu1", lmu, tag=FALSE), ", ",
- namesof("sd1", lsd, tag=FALSE), ", ",
- namesof("mu2", lmu, tag=FALSE), ", ",
- namesof("sd2", lsd, tag=FALSE), "\n",
+ 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",
"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({
@@ -56,11 +62,12 @@ mix2normal1 = function(lphi="logit",
initialize=eval(substitute(expression({
if(ncol(y <- cbind(y)) != 1)
stop("the response must be a vector or one-column matrix")
- predictors.names = c(namesof("phi", .lphi, tag=FALSE),
- namesof("mu1", .lmu, tag=FALSE),
- namesof("sd1", .lsd, tag=FALSE),
- namesof("mu2", .lmu, tag=FALSE),
- namesof("sd2", .lsd, tag=FALSE))
+ predictors.names = c(
+ namesof("phi", .lphi, tag=FALSE),
+ namesof("mu1", .lmu, earg= .emu1, tag=FALSE),
+ namesof("sd1", .lsd, earg= .esd1, tag=FALSE),
+ namesof("mu2", .lmu, earg= .emu2, tag=FALSE),
+ namesof("sd2", .lsd, earg= .esd2, tag=FALSE))
if(!length(etastart)) {
qy = quantile(y, prob= .qmu)
init.phi = if(length(.iphi)) rep(.iphi, length=n) else {
@@ -83,46 +90,53 @@ mix2normal1 = function(lphi="logit",
init.sd2 = if(length(.isd2)) rep(.isd2, length=n) else {
sd(sorty[ind.2])
}
- etastart = cbind(theta2eta(init.phi, .lphi),
- theta2eta(init.mu1, .lmu),
- theta2eta(init.sd1, .lsd),
- theta2eta(init.mu2, .lmu),
- theta2eta(init.sd2, .lsd))
+ etastart = cbind(theta2eta(init.phi, .lphi, earg= .ephi),
+ theta2eta(init.mu1, .lmu, earg= .emu1),
+ theta2eta(init.sd1, .lsd, earg= .esd1),
+ theta2eta(init.mu2, .lmu, earg= .emu2),
+ theta2eta(init.sd2, .lsd, earg= .esd2))
}
}), list(.lphi=lphi, .lmu=lmu, .iphi=iphi, .imu1=imu1, .imu2=imu2,
+ .ephi=ephi, .emu1=emu1, .emu2=emu2, .esd1=esd1, .esd2=esd2,
.lsd=lsd, .isd1=isd1, .isd2=isd2, .qmu=qmu))),
inverse=eval(substitute(function(eta, extra=NULL){
- phi = eta2theta(eta[,1], link= .lphi)
- mu1 = eta2theta(eta[,2], link= .lmu)
- mu2 = eta2theta(eta[,4], link= .lmu)
+ phi = eta2theta(eta[,1], link= .lphi, earg= .ephi)
+ mu1 = eta2theta(eta[,2], link= .lmu, earg= .emu1)
+ mu2 = eta2theta(eta[,4], link= .lmu, earg= .emu2)
phi*mu1 + (1-phi)*mu2
- }, list(.lphi=lphi, .lmu=lmu))),
+ }, list(.lphi=lphi, .lmu=lmu,
+ .ephi=ephi, .emu1=emu1, .emu2=emu2, .esd1=esd1, .esd2=esd2 ))),
last=eval(substitute(expression({
- misc$links = if( .esd) c("phi"= .lphi, "mu1"= .lmu, "sd"= .lsd,
- "mu2"= .lmu) else c("phi"= .lphi, "mu1"= .lmu,
- "sd1"= .lsd, "mu2"= .lmu, "sd2"= .lsd)
+ misc$link = c("phi"= .lphi, "mu1"= .lmu,
+ "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))),
+ }), list(.lphi=lphi, .lmu=lmu, .lsd=lsd, .esd=esd,
+ .ephi=ephi, .emu1=emu1, .emu2=emu2, .esd1=esd1, .esd2=esd2 ))),
loglikelihood=eval(substitute(
function(mu,y,w,residuals=FALSE,eta,extra=NULL) {
- phi = eta2theta(eta[,1], link= .lphi)
- mu1 = eta2theta(eta[,2], link= .lmu)
- sd1 = eta2theta(eta[,3], link= .lsd)
- mu2 = eta2theta(eta[,4], link= .lmu)
- sd2 = eta2theta(eta[,5], link= .lsd)
+ phi = eta2theta(eta[,1], link= .lphi, earg= .ephi)
+ mu1 = eta2theta(eta[,2], link= .lmu, earg= .emu1)
+ sd1 = eta2theta(eta[,3], link= .lsd, earg= .esd1)
+ mu2 = eta2theta(eta[,4], link= .lmu, earg= .emu2)
+ sd2 = eta2theta(eta[,5], link= .lsd, earg= .esd2)
f1 = dnorm(y, mean=mu1, sd=sd1)
f2 = dnorm(y, mean=mu2, sd=sd2)
if(residuals) stop("loglikelihood residuals not implemented yet") else
sum(w * log(phi*f1 + (1-phi)*f2))
- }, list(.lphi=lphi, .lmu=lmu, .lsd=lsd))),
+ }, list(.lphi=lphi, .lmu=lmu,
+ .ephi=ephi, .emu1=emu1, .emu2=emu2, .esd1=esd1, .esd2=esd2,
+ .lsd=lsd ))),
vfamily=c("mix2normal1"),
deriv=eval(substitute(expression({
- phi = eta2theta(eta[,1], link= .lphi)
- mu1 = eta2theta(eta[,2], link= .lmu)
- sd1 = eta2theta(eta[,3], link= .lsd)
- mu2 = eta2theta(eta[,4], link= .lmu)
- sd2 = eta2theta(eta[,5], link= .lsd)
+ phi = eta2theta(eta[,1], link= .lphi, earg= .ephi)
+ mu1 = eta2theta(eta[,2], link= .lmu, earg= .emu1)
+ sd1 = eta2theta(eta[,3], link= .lsd, earg= .esd1)
+ mu2 = eta2theta(eta[,4], link= .lmu, earg= .emu2)
+ sd2 = eta2theta(eta[,5], link= .lsd, earg= .esd2)
f1 = dnorm(y, mean=mu1, sd=sd1)
f2 = dnorm(y, mean=mu2, sd=sd2)
pdf = phi*f1 + (1-phi)*f2
@@ -133,11 +147,11 @@ mix2normal1 = function(lphi="logit",
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)
- dmu1.deta = dtheta.deta(mu1, link= .lmu)
- dmu2.deta = dtheta.deta(mu2, link= .lmu)
- dsd1.deta = dtheta.deta(sd1, link= .lsd)
- dsd2.deta = dtheta.deta(sd2, link= .lsd)
+ 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 {
@@ -151,7 +165,8 @@ mix2normal1 = function(lphi="logit",
dl.dmu2 * dmu2.deta,
dl.dsd2 * dsd2.deta)
derivnew
- }), list(.lphi=lphi, .lmu=lmu, .lsd=lsd))),
+ }), list(.lphi=lphi, .lmu=lmu, .lsd=lsd,
+ .ephi=ephi, .emu1=emu1, .emu2=emu2, .esd1=esd1, .esd2=esd2 ))),
weight = eval(substitute(expression({
if(iter == 1) {
wznew = cbind(matrix(w, n, M), matrix(0, n, dimm(M)-M))
@@ -175,6 +190,7 @@ mix2poisson.control <- function(save.weight=TRUE, ...)
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)
{
@@ -190,24 +206,27 @@ mix2poisson = function(lphi="logit", llambda="loge",
stop("bad input for argument \"il1\"")
if(length(il2) && !is.Numeric(il2))
stop("bad input for argument \"il2\"")
+ if(!is.list(ephi)) ephi = list()
+ if(!is.list(el1)) el1 = list()
+ if(!is.list(el2)) el2 = list()
new("vglmff",
blurb=c("Mixture of two univariate normals\n\n",
"Links: ",
- namesof("phi",lphi), ", ",
- namesof("lambda1", llambda, tag=FALSE), ", ",
- namesof("lambda2", llambda, tag=FALSE), "\n",
+ namesof("phi",lphi, earg= .ephi), ", ",
+ namesof("lambda1", llambda, earg= el1, tag=FALSE), ", ",
+ namesof("lambda2", llambda, earg= el2, tag=FALSE), "\n",
"Mean: phi*lambda1 + (1-phi)*lambda2\n",
"Variance: phi*lambda1^2 + (1-phi)*lambda2^2 + phi*(1-phi)*(lambda1-lambda2)^2"),
constraints=eval(substitute(expression({
constraints = cm.zero.vgam(constraints, x, .zero, M)
- }), list(.zero=zero))),
+ }), 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("phi", .lphi, tag=FALSE),
- namesof("lambda1", .llambda, tag=FALSE),
- namesof("lambda2", .llambda, tag=FALSE))
+ predictors.names = c(namesof("phi", .lphi, earg= .ephi, tag=FALSE),
+ namesof("lambda1", .llambda, earg= .el1, tag=FALSE),
+ namesof("lambda2", .llambda, earg= .el2, tag=FALSE))
if(!length(etastart)) {
qy = quantile(y, prob= .qmu)
init.phi = if(length(.iphi)) rep(.iphi, length=n) else {
@@ -219,38 +238,43 @@ mix2poisson = function(lphi="logit", llambda="loge",
init.lambda2 = if(length(.il2)) rep(.il2, length=n) else {
rep(qy[2], length=n)
}
- etastart = cbind(theta2eta(init.phi, .lphi),
- theta2eta(init.lambda1, .llambda),
- theta2eta(init.lambda2, .llambda))
+ etastart = cbind(theta2eta(init.phi, .lphi, earg= .ephi),
+ theta2eta(init.lambda1, .llambda, earg= .el1),
+ theta2eta(init.lambda2, .llambda, earg= .el2))
}
}), list(.lphi=lphi, .llambda=llambda, .iphi=iphi, .il1=il1, .il2=il2,
+ .ephi=ephi, .el1=el1, .el2=el2,
.qmu=qmu))),
inverse=eval(substitute(function(eta, extra=NULL){
- phi = eta2theta(eta[,1], link= .lphi)
- lambda1 = eta2theta(eta[,2], link= .llambda)
- lambda2 = eta2theta(eta[,3], link= .llambda)
+ phi = eta2theta(eta[,1], link= .lphi, earg= .ephi)
+ lambda1 = eta2theta(eta[,2], link= .llambda, earg= .el1)
+ lambda2 = eta2theta(eta[,3], link= .llambda, earg= .el2)
phi*lambda1 + (1-phi)*lambda2
- }, list(.lphi=lphi, .llambda=llambda))),
+ }, list(.lphi=lphi, .llambda=llambda,
+ .ephi=ephi, .el1=el1, .el2=el2 ))),
last=eval(substitute(expression({
- misc$links = c("phi"= .lphi, "lambda1"= .llambda, "lambda2"= .llambda)
+ misc$link = c("phi"= .lphi, "lambda1"= .llambda, "lambda2"= .llambda)
+ misc$earg = list("phi"= .ephi, "lambda1"= .el1, "lambda2"= .el2)
misc$expected = FALSE
misc$BFGS = TRUE
- }), list(.lphi=lphi, .llambda=llambda))),
+ }), list(.lphi=lphi, .llambda=llambda,
+ .ephi=ephi, .el1=el1, .el2=el2 ))),
loglikelihood=eval(substitute(
function(mu,y,w,residuals=FALSE,eta,extra=NULL) {
- phi = eta2theta(eta[,1], link= .lphi)
- lambda1 = eta2theta(eta[,2], link= .llambda)
- lambda2 = eta2theta(eta[,3], link= .llambda)
+ phi = eta2theta(eta[,1], link= .lphi, earg= .ephi)
+ lambda1 = eta2theta(eta[,2], link= .llambda, earg= .el1)
+ lambda2 = eta2theta(eta[,3], link= .llambda, earg= .el2)
f1 = dpois(y, lam=lambda1)
f2 = dpois(y, lam=lambda2)
if(residuals) stop("loglikelihood residuals not implemented yet") else
sum(w * log(phi*f1 + (1-phi)*f2))
- }, list(.lphi=lphi, .llambda=llambda))),
+ }, list(.lphi=lphi, .llambda=llambda,
+ .ephi=ephi, .el1=el1, .el2=el2 ))),
vfamily=c("mix2poisson"),
deriv=eval(substitute(expression({
- phi = eta2theta(eta[,1], link= .lphi)
- lambda1 = eta2theta(eta[,2], link= .llambda)
- lambda2 = eta2theta(eta[,3], link= .llambda)
+ phi = eta2theta(eta[,1], link= .lphi, earg= .ephi)
+ lambda1 = eta2theta(eta[,2], link= .llambda, earg= .el1)
+ lambda2 = eta2theta(eta[,3], link= .llambda, earg= .el2)
f1 = dpois(x=y, lam=lambda1)
f2 = dpois(x=y, lam=lambda2)
pdf = phi*f1 + (1-phi)*f2
@@ -259,9 +283,9 @@ 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)
- dlambda1.deta = dtheta.deta(lambda1, link= .llambda)
- dlambda2.deta = dtheta.deta(lambda2, link= .llambda)
+ 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 {
@@ -273,7 +297,8 @@ mix2poisson = function(lphi="logit", llambda="loge",
dl.dlambda1 * dlambda1.deta,
dl.dlambda2 * dlambda2.deta)
derivnew
- }), list(.lphi=lphi, .llambda=llambda))),
+ }), list(.lphi=lphi, .llambda=llambda,
+ .ephi=ephi, .el1=el1, .el2=el2 ))),
weight = eval(substitute(expression({
if(iter == 1) {
wznew = cbind(matrix(w, n, M), matrix(0, n, dimm(M)-M))
diff --git a/R/family.nonlinear.q b/R/family.nonlinear.q
index e6c1c64..e7b8245 100644
--- a/R/family.nonlinear.q
+++ b/R/family.nonlinear.q
@@ -21,6 +21,8 @@ micmen <- function(rpar=0.001, divisor=10,
init1=NULL, init2=NULL,
link1="identity",
link2="identity",
+ earg1=list(),
+ earg2=list(),
dispersion=0,
zero=NULL)
{
@@ -32,13 +34,15 @@ micmen <- function(rpar=0.001, divisor=10,
link1 <- as.character(substitute(link1))
if(mode(link2) != "character" && mode(link2) != "name")
link2 <- as.character(substitute(link2))
+ if(!is.list(earg1)) earg1 = list()
+ if(!is.list(earg2)) earg2 = list()
new("vglmff",
blurb=c("Michaelis-Menton regression model\n",
"Y_i=theta1 * x_i / (theta2 + x_i) + e_i\n\n",
"Links: ",
- namesof("theta1", link1), ", ",
- namesof("theta2", link2),
+ namesof("theta1", link1, earg=earg1), ", ",
+ namesof("theta2", link2, earg=earg2),
"\n",
"Variance: constant"),
constraints=eval(substitute(expression({
@@ -52,11 +56,15 @@ micmen <- function(rpar=0.001, divisor=10,
rss.vgam(y-mu, w, M=M)
},
initialize=eval(substitute(expression({
+ if(ncol(cbind(y)) != 1)
+ stop("response must be a vector or a one-column matrix")
+
uvec = control$regressor # This is the regressor
extra$uvec = uvec # Needed for @inverse
- predictors.names <- c(namesof("theta1", .link1, tag=FALSE),
- namesof("theta2", .link2, tag=FALSE))
+ predictors.names <-
+ c(namesof("theta1", .link1, earg= .earg1, tag=FALSE),
+ namesof("theta2", .link2, earg= .earg2, tag=FALSE))
if(length(mustart) || length(coefstart))
stop("can't handle mustart or coefstart")
@@ -68,21 +76,25 @@ micmen <- function(rpar=0.001, divisor=10,
if(length(.init1)) init1 = .init1
if(length(.init2)) init2 = .init2
- etastart = cbind(rep(theta2eta(init1, .link1), len=n),
- rep(theta2eta(init2, .link2), len=n))
+ etastart = cbind(
+ rep(theta2eta(init1, .link1, earg= .earg1), len=n),
+ rep(theta2eta(init2, .link2, earg= .earg2), len=n))
} else {
stop("can't handle etastart or mustart")
}
}), list(.init1=init1, .init2=init2,
- .link1=link1, .link2=link2))),
+ .earg1=earg1, .earg2=earg2,
+ .link1=link1, .link2=link2))),
inverse=eval(substitute(function(eta, extra=NULL) {
- theta1 <- eta2theta(eta[,1], .link1)
- theta2 <- eta2theta(eta[,2], .link2)
+ theta1 <- eta2theta(eta[,1], .link1, earg= .earg1)
+ theta2 <- eta2theta(eta[,2], .link2, earg= .earg2)
theta1 * extra$uvec / (theta2 + extra$uvec)
- }, list(.link1=link1, .link2=link2))),
+ }, list(.link1=link1, .link2=link2,
+ .earg1=earg1, .earg2=earg2 ))),
last=eval(substitute(expression({
misc$link <- c(theta1= .link1, theta2= .link2)
+ misc$earg = list(theta1= .earg1, theta2= .earg2 )
misc$rpar <- rpar
fit$df.residual <- n - rank # Not n.big - rank
fit$df.total <- n # Not n.big
@@ -95,6 +107,7 @@ micmen <- function(rpar=0.001, divisor=10,
misc$default.dispersion <- 0
misc$estimated.dispersion <- .estimated.dispersion
}), list(.link1=link1, .link2=link2, .dispersion=dispersion,
+ .earg1=earg1, .earg2=earg2,
.estimated.dispersion=estimated.dispersion))),
summary.dispersion=FALSE,
vfamily=c("micmen","vnonlinear"),
@@ -107,8 +120,8 @@ micmen <- function(rpar=0.001, divisor=10,
c("theta1","theta2"), hessian=FALSE)
}
- theta1 <- eta2theta(eta[,1], .link1)
- theta2 <- eta2theta(eta[,2], .link2)
+ theta1 <- eta2theta(eta[,1], .link1, earg= .earg1)
+ theta2 <- eta2theta(eta[,2], .link2, earg= .earg2)
if(TRUE) {
dmus.dthetas = attr(eval(d3), "gradient")
@@ -118,8 +131,8 @@ micmen <- function(rpar=0.001, divisor=10,
dmus.dthetas = cbind(dmu.dtheta1, dmu.dtheta2)
}
- dthetas.detas = cbind(dtheta.deta(theta1, .link1),
- dtheta.deta(theta2, .link2))
+ dthetas.detas = cbind(dtheta.deta(theta1, .link1, earg= .earg1),
+ dtheta.deta(theta2, .link2, earg= .earg2))
if(TRUE) {
index = iam(NA, NA, M=M, both=TRUE)
@@ -132,7 +145,9 @@ micmen <- function(rpar=0.001, divisor=10,
cbind(dmus.dthetas[,1] * dthetas.detas[,1],
dmus.dthetas[,2] * dthetas.detas[,2] + sqrt(rpar))
}
- }), list(.link1=link1, .link2=link2, .rpar=rpar, .divisor=divisor))),
+ }), list( .link1=link1, .link2=link2, .rpar=rpar,
+ .earg1=earg1, .earg2=earg2,
+ .divisor=divisor))),
weight=eval(substitute(expression({
if(TRUE) {
wz = dmus.dthetas[,index$row] * dmus.dthetas[,index$col] *
diff --git a/R/family.normal.q b/R/family.normal.q
index 6002954..5b3b690 100644
--- a/R/family.normal.q
+++ b/R/family.normal.q
@@ -155,6 +155,7 @@ rposnorm = function(n, mean=0, sd=1) {
}
posnormal1 = function(lmean="identity", lsd="loge",
+ emean=list(), esd=list(),
imean=NULL, isd=NULL, zero=NULL)
{
if(mode(lmean) != "character" && mode(lmean) != "name")
@@ -165,66 +166,70 @@ posnormal1 = function(lmean="identity", lsd="loge",
stop("bad input for argument \"zero\"")
if(length(isd) && !is.Numeric(isd, posit=TRUE))
stop("bad input for argument \"isd\"")
+ if(!is.list(emean)) emean = list()
+ if(!is.list(esd)) esd = list()
new("vglmff",
blurb=c("Positive (univariate) normal distribution\n\n",
"Links: ",
- namesof("mean", lmean, tag= TRUE), "; ",
- namesof("sd", lsd, tag= TRUE)),
+ namesof("mean", lmean, earg= emean, tag= TRUE), "; ",
+ namesof("sd", lsd, earg= esd, tag= TRUE)),
constraints=eval(substitute(expression({
constraints = cm.zero.vgam(constraints, x, .zero, M)
}), list( .zero=zero ))),
initialize=eval(substitute(expression({
- predictors.names = c(namesof("mean", .lmean, tag= FALSE),
- namesof("sd", .lsd, tag= FALSE))
if(ncol(y <- cbind(y)) != 1)
stop("response must be a vector or a one-column matrix")
if(min(y) <= 0)
stop("response must be positive")
+ predictors.names = c(namesof("mean", .lmean, earg= .emean, tag= FALSE),
+ namesof("sd", .lsd, earg= .esd, tag= FALSE))
if(!length(etastart)) {
init.me = if(length( .imean)) rep( .imean, len=n) else NULL
init.sd = if(length( .isd )) rep( .isd , len=n) else NULL
if(!length(init.me)) init.me = rep(quantile(y, probs=0.40), len=n)
if(!length(init.sd)) init.sd = rep(sd(y)*1.2, len=n)
- etastart = cbind(theta2eta(init.me, .lmean),
- theta2eta(init.sd, .lsd))
+ etastart = cbind(theta2eta(init.me, .lmean, earg= .emean),
+ theta2eta(init.sd, .lsd, earg= .esd))
}
- }), list( .lmean=lmean, .lsd=lsd, .imean=imean, .isd=isd ))),
+ }), list( .lmean=lmean, .lsd=lsd, .imean=imean, .isd=isd,
+ .emean=emean, .esd=esd ))),
inverse=eval(substitute(function(eta, extra=NULL) {
- mymu = eta2theta(eta[,1], .lmean)
- mysd = eta2theta(eta[,2], .lsd)
+ mymu = eta2theta(eta[,1], .lmean, earg= .emean)
+ mysd = eta2theta(eta[,2], .lsd, earg= .esd)
mymu + mysd * dnorm(-mymu/mysd) / (1-pnorm(-mymu/mysd))
- }, list( .lmean=lmean, .lsd=lsd ))),
+ }, list( .lmean=lmean, .lsd=lsd, .emean=emean, .esd=esd ))),
last=eval(substitute(expression({
misc$link = c("mean"= .lmean, "sd"= .lsd) # zz mu or mean ?
+ misc$earg = list("mean"= .emean, "sd"= .esd )
misc$expected = TRUE
- }), list( .lmean=lmean, .lsd=lsd ))),
+ }), list( .lmean=lmean, .lsd=lsd, .emean=emean, .esd=esd ))),
loglikelihood=eval(substitute(
function(mu,y,w,residuals= FALSE,eta, extra=NULL) {
- mymu = eta2theta(eta[,1], .lmean)
- mysd = eta2theta(eta[,2], .lsd)
+ mymu = eta2theta(eta[,1], .lmean, earg= .emean)
+ mysd = eta2theta(eta[,2], .lsd, earg= .esd)
if(residuals) stop("loglikelihood residuals not implemented yet") else {
if(is.R())
sum(w*(dnorm(y, m=mymu, sd=mysd, log=TRUE) -
pnorm(-mymu/mysd, log=TRUE, lower.tail=FALSE))) else
sum(w*(-log(mysd)-0.5*((y-mymu)/mysd)^2 -log(1-pnorm(-mymu/mysd))))
}
- }, list( .lmean=lmean, .lsd=lsd ))),
+ }, list( .lmean=lmean, .lsd=lsd, .emean=emean, .esd=esd ))),
vfamily=c("posnormal1"),
deriv=eval(substitute(expression({
- mymu = eta2theta(eta[,1], .lmean)
- mysd = eta2theta(eta[,2], .lsd)
+ mymu = eta2theta(eta[,1], .lmean, earg= .emean)
+ mysd = eta2theta(eta[,2], .lsd, earg= .esd)
zedd = (y-mymu) / mysd
temp7 = dnorm(-mymu/mysd)
temp8 = if(is.R()) pnorm(-mymu/mysd, low=FALSE) else 1-pnorm(-mymu/mysd)
temp8 = temp8 * mysd
dl.dmu = zedd / mysd - temp7 / temp8
dl.dsd = (mymu*temp7/temp8 + zedd^2 - 1) / mysd
- dmu.deta = dtheta.deta(mymu, .lmean)
- dsd.deta = dtheta.deta(mysd, .lsd)
+ dmu.deta = dtheta.deta(mymu, .lmean, earg= .emean)
+ dsd.deta = dtheta.deta(mysd, .lsd, earg= .esd)
w * cbind(dl.dmu * dmu.deta,
dl.dsd * dsd.deta)
- }), list( .lmean=lmean, .lsd=lsd ))),
+ }), list( .lmean=lmean, .lsd=lsd, .emean=emean, .esd=esd ))),
weight=eval(substitute(expression({
wz = matrix(as.numeric(NA), n, dimm(M))
ed2l.dmu2 = (1 - temp7*mymu/temp8) / mysd^2 - (temp7/temp8)^2
@@ -236,7 +241,7 @@ posnormal1 = function(lmean="identity", lsd="loge",
wz[,iam(2,2,M)] = ed2l.dsd2 * dsd.deta^2
wz[,iam(1,2,M)] = ed2l.dmusd * dsd.deta * dmu.deta
w * wz
- }), list( .lmean=lmean, .lsd=lsd ))))
+ }), list( .lmean=lmean, .lsd=lsd, .emean=emean, .esd=esd ))))
}
@@ -281,6 +286,7 @@ rbetanorm = function(n, shape1, shape2, mean=0, sd=1) {
tikuv = function(d, lmean="identity", lsigma="loge",
+ emean=list(), esigma=list(),
isigma=NULL, zero=2)
{
if(mode(lmean) != "character" && mode(lmean) != "name")
@@ -292,12 +298,14 @@ tikuv = function(d, lmean="identity", lsigma="loge",
stop("bad input for argument \"zero\"")
if(!is.Numeric(d, allow=1) || max(d) >= 2)
stop("bad input for argument \"d\"")
+ if(!is.list(emean)) emean = list()
+ if(!is.list(esigma)) esigma = list()
new("vglmff",
blurb=c("Short-tailed symmetric [Tiku and Vaughan (1999)] distribution\n",
"Link: ",
- namesof("mean", lmean), ", ",
- namesof("sigma", lsigma),
+ namesof("mean", lmean, earg= emean), ", ",
+ namesof("sigma", lsigma, earg= esigma),
"\n",
"\n",
"Mean: mean"),
@@ -307,8 +315,9 @@ tikuv = function(d, lmean="identity", lsigma="loge",
initialize=eval(substitute(expression({
if(ncol(cbind(y)) != 1)
stop("the response must be a vector or one-column matrix")
- predictors.names = c(namesof("mean", .lmean, tag= FALSE),
- namesof("sigma", .lsigma, tag= FALSE))
+ predictors.names =
+ c(namesof("mean", .lmean, earg= .emean, tag= FALSE),
+ namesof("sigma", .lsigma, earg= .esigma, tag= FALSE))
if(!length(etastart)) {
sigma.init = if(length(.isigma)) rep(.isigma, length=n) else {
hh = 2 - .d
@@ -317,41 +326,47 @@ tikuv = function(d, lmean="identity", lsigma="loge",
rep(sqrt(var(y) / (KK*K2)), len=n)
}
mean.init = rep(weighted.mean(y, w), len=n)
- etastart = cbind(theta2eta(mean.init, .lmean),
- theta2eta(sigma.init, .lsigma))
+ etastart = cbind(theta2eta(mean.init, .lmean, earg= .emean),
+ theta2eta(sigma.init, .lsigma, earg= .esigma))
}
- }),list( .lmean=lmean, .lsigma=lsigma, .isigma=isigma, .d=d ))),
+ }),list( .lmean=lmean, .lsigma=lsigma, .isigma=isigma, .d=d,
+ .emean=emean, .esigma=esigma ))),
inverse=eval(substitute(function(eta, extra=NULL) {
- eta2theta(eta[,1], .lmean)
- }, list( .lmean=lmean ))),
+ eta2theta(eta[,1], .lmean, earg= .emean)
+ }, list( .lmean=lmean,
+ .emean=emean, .esigma=esigma ))),
last=eval(substitute(expression({
misc$link = c("mean"= .lmean, "sigma"= .lsigma)
+ misc$earg = list("mean"= .emean, "sigma"= .esigma )
misc$expected = TRUE
misc$d = .d
- }), list( .lmean=lmean, .lsigma=lsigma, .d=d ))),
+ }), list( .lmean=lmean, .lsigma=lsigma, .d=d,
+ .emean=emean, .esigma=esigma ))),
loglikelihood=eval(substitute(
function(mu,y,w,residuals= FALSE,eta, extra=NULL) {
- mymu = eta2theta(eta[,1], .lmean)
- sigma = eta2theta(eta[,2], .lsigma)
+ mymu = eta2theta(eta[,1], .lmean, earg= .emean)
+ sigma = eta2theta(eta[,2], .lsigma, earg= .esigma)
if(residuals) stop("loglikelihood residuals not implemented yet") else {
zedd = (y - mymu) / sigma
hh = 2 - .d
sum(w * (-log(sigma) + 2 * log(1 + 0.5*zedd^2 / hh) - 0.5*zedd^2))
}
- }, list( .lmean=lmean, .lsigma=lsigma, .d=d ))),
+ }, list( .lmean=lmean, .lsigma=lsigma, .d=d,
+ .emean=emean, .esigma=esigma ))),
vfamily=c("tikuv"),
deriv=eval(substitute(expression({
- mymu = eta2theta(eta[,1], .lmean)
- sigma = eta2theta(eta[,2], .lsigma)
- dmu.deta = dtheta.deta(mymu, .lmean)
- dsigma.deta = dtheta.deta(sigma, .lsigma)
+ mymu = eta2theta(eta[,1], .lmean, earg= .emean)
+ sigma = eta2theta(eta[,2], .lsigma, earg= .esigma)
+ dmu.deta = dtheta.deta(mymu, .lmean, earg= .emean)
+ dsigma.deta = dtheta.deta(sigma, .lsigma, earg= .esigma)
zedd = (y - mymu) / sigma
hh = 2 - .d
gzedd = zedd / (1 + 0.5*zedd^2 / hh)
dl.dmu = zedd / sigma - 2 * gzedd / (hh*sigma)
dl.dsigma = (zedd^2 - 1 - 2 * zedd * gzedd / hh) / sigma
w * cbind(dl.dmu * dmu.deta, dl.dsigma * dsigma.deta)
- }), list( .lmean=lmean, .lsigma=lsigma, .d=d ))),
+ }), list( .lmean=lmean, .lsigma=lsigma, .d=d,
+ .emean=emean, .esigma=esigma ))),
weight=eval(substitute(expression({
ayy = 1 / (2*hh)
Dnos = 1 - (2/hh) * (1 - ayy) / (1 + 2*ayy + 3*ayy^2)
@@ -362,7 +377,8 @@ tikuv = function(d, lmean="identity", lsigma="loge",
wz[,iam(1,1,M)] = ed2l.dmymu2 * dmu.deta^2
wz[,iam(2,2,M)] = ed2l.dnu2 * dsigma.deta^2
w * wz
- }), list( .lmean=lmean, .lsigma=lsigma ))))
+ }), list( .lmean=lmean, .lsigma=lsigma,
+ .emean=emean, .esigma=esigma ))))
}
diff --git a/R/family.positive.q b/R/family.positive.q
index 78519b4..8daa2cb 100644
--- a/R/family.positive.q
+++ b/R/family.positive.q
@@ -6,6 +6,7 @@
posnegbinomial = function(lmunb = "loge", lk = "loge",
+ emunb =list(), ek = list(),
ik = NULL, zero = -2, cutoff = 0.995,
method.init=1)
{
@@ -20,12 +21,14 @@ posnegbinomial = function(lmunb = "loge", lk = "loge",
lmunb = as.character(substitute(lmunb))
if(mode(lk) != "character" && mode(lk) != "name")
lk = as.character(substitute(lk))
+ if(!is.list(emunb)) emunb = list()
+ if(!is.list(ek)) ek = list()
new("vglmff",
blurb=c("Positive-negative binomial distribution\n\n",
"Links: ",
- namesof("munb", lmunb), ", ",
- namesof("k", lk), "\n",
+ namesof("munb", lmunb, earg= emunb ), ", ",
+ namesof("k", lk, earg= ek ), "\n",
"Mean: munb / (1 - (k/(k+munb))^k)"),
constraints=eval(substitute(expression({
temp752 = .zero
@@ -39,9 +42,9 @@ posnegbinomial = function(lmunb = "loge", lk = "loge",
M = 2 * ncol(y)
extra$NOS = NOS = ncoly = ncol(y) # Number of species
predictors.names = c(namesof(if(NOS==1) "munb" else
- paste("munb", 1:NOS, sep=""), .lmunb, tag= FALSE),
+ paste("munb", 1:NOS, sep=""), .lmunb, earg= .emunb, tag= FALSE),
namesof(if(NOS==1) "k" else paste("k", 1:NOS, sep=""),
- .lk, tag= FALSE))
+ .lk, earg= .ek, tag= FALSE))
predictors.names = predictors.names[interleave.VGAM(M, M=2)]
if(!length(etastart)) {
if( .method.init == 3) {
@@ -73,44 +76,55 @@ posnegbinomial = function(lmunb = "loge", lk = "loge",
}
}
p00 = (kmat0 / (kmat0 + mu.init))^kmat0
- etastart = cbind(theta2eta(mu.init*(1-p00), .lmunb),
- theta2eta(kmat0, .lk))
+ etastart = cbind(theta2eta(mu.init*(1-p00), .lmunb, earg= .emunb ),
+ theta2eta(kmat0, .lk, earg= .ek ))
etastart = etastart[,interleave.VGAM(M, M=2),drop=FALSE]
}
- }), list( .lmunb=lmunb, .lk=lk, .ik=ik, .method.init=method.init ))),
+ }), list( .lmunb=lmunb, .lk=lk, .ik=ik,
+ .emunb=emunb, .ek=ek,
+ .method.init=method.init ))),
inverse=eval(substitute(function(eta, extra=NULL) {
NOS = ncol(eta) / 2
- munb = eta2theta(eta[,2*(1:NOS)-1,drop=FALSE], .lmunb)
- kmat = eta2theta(eta[,2*(1:NOS),drop=FALSE], .lk)
+ munb = eta2theta(eta[,2*(1:NOS)-1,drop=FALSE], .lmunb, earg= .emunb )
+ kmat = eta2theta(eta[,2*(1:NOS),drop=FALSE], .lk, earg= .ek )
p0 = (kmat / (kmat + munb))^kmat
munb / (1 - p0)
- }, list( .lk=lk, .lmunb=lmunb ))),
+ }, list( .lk=lk, .lmunb=lmunb,
+ .emunb=emunb, .ek=ek ))),
last=eval(substitute(expression({
- temp0303 = c(rep(.lmunb, length=NOS), rep(.lk, length=NOS))
+ temp0303 = c(rep( .lmunb, length=NOS), rep( .lk, length=NOS))
names(temp0303) = c(if(NOS==1) "munb" else paste("munb", 1:NOS, sep=""),
if(NOS==1) "k" else paste("k", 1:NOS, sep=""))
temp0303 = temp0303[interleave.VGAM(M, M=2)]
misc$link = temp0303 # Already named
+ misc$earg = vector("list", 2*NOS)
+ names(misc$earg) = names(misc$link)
+ for(ii in 1:NOS) {
+ misc$earg[[2*ii-1]] = .emunb
+ misc$earg[[2*ii ]] = .ek
+ }
misc$cutoff = .cutoff
misc$method.init = .method.init
}), list( .lmunb=lmunb, .lk=lk, .cutoff=cutoff,
+ .emunb=emunb, .ek=ek,
.method.init=method.init ))),
loglikelihood=eval(substitute(
function(mu,y,w,residuals= FALSE,eta, extra=NULL) {
NOS = ncol(eta) / 2
- munb = eta2theta(eta[,2*(1:NOS)-1,drop=FALSE], .lmunb)
- kmat = eta2theta(eta[,2*(1:NOS),drop=FALSE], .lk)
+ munb = eta2theta(eta[,2*(1:NOS)-1,drop=FALSE], .lmunb, earg= .emunb )
+ kmat = eta2theta(eta[,2*(1:NOS),drop=FALSE], .lk, earg= .ek )
p0 = (kmat / (kmat + munb))^kmat
if(residuals) stop("loglikelihood residuals not implemented yet") else
sum(w * (y * log(munb/(munb+kmat)) + kmat*log(kmat/(munb+kmat)) +
lgamma(y+kmat) - lgamma(kmat) - lgamma(y+1) -
(if(is.R()) log1p(-p0) else log(1 - p0))))
- }, list( .lmunb=lmunb, .lk=lk ))),
+ }, list( .lmunb=lmunb, .lk=lk,
+ .emunb=emunb, .ek=ek ))),
vfamily=c("posnegbinomial"),
deriv=eval(substitute(expression({
NOS= extra$NOS
- munb = eta2theta(eta[,2*(1:NOS)-1,drop=FALSE], .lmunb)
- kmat = eta2theta(eta[,2*(1:NOS),drop=FALSE], .lk)
+ munb = eta2theta(eta[,2*(1:NOS)-1,drop=FALSE], .lmunb, earg= .emunb )
+ kmat = eta2theta(eta[,2*(1:NOS),drop=FALSE], .lk, earg= .ek )
d3 = deriv3(~ -log(1 - (kmat. /(kmat. + munb. ))^kmat. ),
c("munb.", "kmat."), hessian= TRUE) # Extra term
dl0.dthetas = array(NA, c(n, NOS, 2))
@@ -130,11 +144,12 @@ posnegbinomial = function(lmunb = "loge", lk = "loge",
dl.dmunb = y/munb - (y+kmat)/(kmat+munb) + dl0.dthetas[,,1]
dl.dk = digamma(y+kmat) - digamma(kmat) - (y+kmat)/(munb+kmat) + 1 +
log(kmat/(kmat+munb)) + dl0.dthetas[,,2]
- dmunb.deta = dtheta.deta(munb, .lmunb)
- dk.deta = dtheta.deta(kmat, .lk)
+ dmunb.deta = dtheta.deta(munb, .lmunb, earg= .emunb )
+ dk.deta = dtheta.deta(kmat, .lk, earg= .ek )
myderiv = w * cbind(dl.dmunb * dmunb.deta, dl.dk * dk.deta)
myderiv[,interleave.VGAM(M, M=2)]
- }), list( .lmunb=lmunb, .lk=lk ))),
+ }), list( .lmunb=lmunb, .lk=lk,
+ .emunb=emunb, .ek=ek ))),
weight=eval(substitute(expression({
wz = matrix(0, n, 4*NOS-1) # wz is no longer 'diagonal'
p0 = (kmat / (kmat + munb))^kmat
@@ -207,94 +222,103 @@ rpospois = function(n, lambda) {
-pospoisson = function(link="loge")
+pospoisson = function(link="loge", earg=list())
{
if(!missing(link))
link = as.character(substitute(link))
+ if(!is.list(earg)) earg = list()
new("vglmff",
blurb=c("Positive-Poisson distribution\n\n",
"Links: ",
- namesof("lambda", link, tag=FALSE),
+ namesof("lambda", link, earg= earg, tag=FALSE),
"\n"),
initialize=eval(substitute(expression({
y = as.matrix(y)
predictors.names = namesof(if(ncol(y)==1) "lambda"
- else paste("lambda", 1:ncol(y), sep=""), .link, tag=FALSE)
+ else paste("lambda", 1:ncol(y), sep=""), .link,
+ earg= .earg, tag=FALSE)
if(!length(etastart))
- etastart = theta2eta(y / (1-exp(-y)), .link)
- }), list( .link=link ))),
+ etastart = theta2eta(y / (1-exp(-y)), .link, earg= .earg )
+ }), list( .link=link, .earg= earg ))),
inverse=eval(substitute(function(eta, extra=NULL) {
- lambda = eta2theta(eta, .link)
+ lambda = eta2theta(eta, .link, earg= .earg )
lambda / (1-exp(-lambda))
- }, list( .link=link ))),
+ }, list( .link=link, .earg= earg ))),
last=eval(substitute(expression({
- misc$link = c(lambda = .link)
- }), list( .link=link ))),
+ 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 ))),
loglikelihood=eval(substitute(
function(mu,y,w,residuals=FALSE, eta,extra=NULL) {
- lambda = eta2theta(eta, .link)
+ lambda = eta2theta(eta, .link, earg= .earg )
if(residuals) stop("loglikelihood residuals not implemented yet") else
sum(w * (-log(1-exp(-lambda)) - lambda + y*log(lambda)))
- }, list( .link=link ))),
+ }, list( .link=link, .earg= earg ))),
vfamily=c("pospoisson"),
deriv=eval(substitute(expression({
- lambda = eta2theta(eta, .link)
+ lambda = eta2theta(eta, .link, earg= .earg )
dl.dlambda = y/lambda - 1 - 1/(exp(lambda)-1)
- dlambda.deta = dtheta.deta(lambda, .link)
+ dlambda.deta = dtheta.deta(lambda, .link, earg= .earg )
w * dl.dlambda * dlambda.deta
- }), list( .link=link ))),
+ }), 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 ))))
+ }), list( .link=link, .earg= earg ))))
}
-posbinomial = function(link="logit")
+posbinomial = function(link="logit", earg=list())
{
if(!missing(link))
link = as.character(substitute(link))
+ if(!is.list(earg)) earg = list()
new("vglmff",
blurb=c("Positive-Binomial distribution\n\n",
"Links: ",
- namesof("p", link, tag=FALSE), "\n"),
+ namesof("p", link, earg= earg, tag=FALSE), "\n"),
initialize=eval(substitute(expression({
eval(binomialff(link= .link)@initialize)
- predictors.names = namesof("p", .link, tag = FALSE)
+ predictors.names = namesof("p", .link, earg= .earg , tag=FALSE)
if(length(extra)) extra$w = w else extra = list(w=w)
if(!length(etastart))
- etastart = cbind(theta2eta(mustart, .link))
- }), list( .link = link ))),
+ etastart = cbind(theta2eta(mustart, .link, earg= .earg ))
+ }), list( .link = link, .earg=earg ))),
inverse=eval(substitute(function(eta, extra=NULL){
- theta = eta2theta(eta, .link)
+ theta = eta2theta(eta, .link, earg= .earg )
theta/(1-(1-theta)^(extra$w))},
- list(.link=link ))),
+ list(.link=link, .earg=earg ))),
last=eval(substitute(expression({
extra$w = NULL # Kill it off
misc$link = c(p = .link)
- }), list( .link=link ))),
+ misc$earg = list(p = .earg )
+ }), list( .link=link, .earg=earg ))),
loglikelihood=eval(substitute(
function(mu,y,w,residuals=FALSE,eta,extra=NULL) {
yi = round(y*w)
- theta = eta2theta(eta, .link)
+ theta = eta2theta(eta, .link, earg= .earg )
if(residuals) stop("loglikelihood residuals not implemented yet") else
sum(yi*log(theta)+(w-yi)*log(1-theta)-log(1-(1-theta)^w))
- }, list( .link=link ))),
+ }, list( .link=link, .earg=earg ))),
vfamily=c("posbinomial"),
deriv=eval(substitute(expression({
yi = round(y*w)
- theta = eta2theta(eta, .link)
+ theta = eta2theta(eta, .link, earg= .earg )
dldtheta = yi/theta-(w-yi)/(1-theta)-w*(1-theta)^(w-1) /
(1-(1-theta)^w)
- dthetadeta = dtheta.deta(theta, .link)
+ dthetadeta = dtheta.deta(theta, .link, earg= .earg )
dldtheta * dthetadeta
- }), list( .link=link ))),
+ }), list( .link=link, .earg=earg ))),
weight=eval(substitute(expression({
temp = 1 - (1-theta)^w
temp2 = (1-theta)^2
@@ -303,7 +327,7 @@ posbinomial = function(link="logit")
w^2 * temp2^(w-1) / temp^2
wz = -(dthetadeta^2) * ed2ldtheta2
wz
- }), list( .link=link ))))
+ }), list( .link=link, .earg=earg ))))
}
diff --git a/R/family.qreg.q b/R/family.qreg.q
index a813294..8f13022 100644
--- a/R/family.qreg.q
+++ b/R/family.qreg.q
@@ -22,8 +22,9 @@ lms.yjn.control <- function(trace=TRUE, ...)
lms.bcn <- function(percentiles=c(25,50,75),
zero=NULL,
- link.sigma="loge",
link.mu="identity",
+ link.sigma="loge",
+ emu=list(), esigma=list(),
dfmu.init=4,
dfsigma.init=2,
init.lambda=1,
@@ -33,25 +34,28 @@ lms.bcn <- function(percentiles=c(25,50,75),
link.sigma <- as.character(substitute(link.sigma))
if(mode(link.mu) != "character" && mode(link.mu) != "name")
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",
"Links: ",
- "lambda",
- ", ",
- namesof("mu", link=link.mu),
- ", ",
- namesof("sigma", link=link.sigma)),
+ "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)
}), list(.zero=zero))),
initialize=eval(substitute(expression({
+ if(ncol(cbind(y)) != 1)
+ stop("response must be a vector or a one-column matrix")
if(any(y<0, na.rm = TRUE))
stop("negative responses not allowed")
- predictors.names <- c("lambda",
- namesof("mu", .link.mu, short= TRUE),
- namesof("sigma", .link.sigma, short= TRUE))
+ predictors.names <-
+ c(namesof("lambda", "identity"),
+ namesof("mu", .link.mu, earg= .emu, short= TRUE),
+ namesof("sigma", .link.sigma, earg= .esigma, short= TRUE))
if(!length(etastart)) {
@@ -70,25 +74,28 @@ lms.bcn <- function(percentiles=c(25,50,75),
} else .init.sigma
etastart <- cbind(lambda.init,
- theta2eta(fv.init, .link.mu),
- theta2eta(sigma.init, .link.sigma))
+ theta2eta(fv.init, .link.mu, earg= .emu),
+ theta2eta(sigma.init, .link.sigma, earg= .esigma))
}
}), list(.link.sigma=link.sigma,
.link.mu=link.mu,
+ .esigma=esigma, .emu=emu,
.dfmu.init=dfmu.init,
.dfsigma.init=dfsigma.init,
.init.lambda=init.lambda,
.init.sigma=init.sigma))),
inverse=eval(substitute(function(eta, extra=NULL) {
- eta[,2] <- eta2theta(eta[,2], .link.mu)
- eta[,3] <- eta2theta(eta[,3], .link.sigma)
+ 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$earg = list(lambda = list(), mu = .emu, sigma = .esigma)
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),
@@ -96,54 +103,60 @@ lms.bcn <- function(percentiles=c(25,50,75),
}
}), list(.percentiles=percentiles,
.link.mu=link.mu,
+ .esigma=esigma, .emu=emu,
.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)
- sigma <- eta2theta(eta[,3], .link.sigma)
+ 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, .link.mu=link.mu))),
+ }, list(.link.sigma=link.sigma,
+ .esigma=esigma, .emu=emu,
+ .link.mu=link.mu))),
vfamily=c("lms.bcn", "lmscreg"),
deriv=eval(substitute(expression({
lambda <- eta[,1]
- mymu <- eta2theta(eta[,2], .link.mu)
- sigma <- eta2theta(eta[,3], .link.sigma)
+ 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)
+ d2 <- d2 * dtheta.deta(mymu, .link.mu, earg= .emu)
d3 <- z2m1 / sigma
- d3 <- d3 * dtheta.deta(sigma, .link.sigma)
+ d3 <- d3 * dtheta.deta(sigma, .link.sigma, earg= .esigma)
w * cbind(d1, d2, d3)
- }), list(.link.sigma=link.sigma, .link.mu=link.mu))),
+ }), 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 *
- dtheta.deta(mymu, .link.mu)^2
+ dtheta.deta(mymu, .link.mu, earg= .emu)^2
wz[,iam(3,3,M)] <- (2 / sigma^2) *
- dtheta.deta(sigma, .link.sigma)^2
+ dtheta.deta(sigma, .link.sigma, earg= .esigma)^2
wz[,iam(1,2,M)] <- (-1 / (2 * mymu)) *
- dtheta.deta(mymu, .link.mu)
+ dtheta.deta(mymu, .link.mu, earg= .emu)
wz[,iam(1,3,M)] <- (lambda * sigma) *
- dtheta.deta(sigma, .link.sigma)
+ dtheta.deta(sigma, .link.sigma, earg= .esigma)
wz[,iam(2,3,M)] <- (2 * lambda / (mymu * sigma)) *
- dtheta.deta(sigma, .link.sigma) *
- dtheta.deta(mymu, .link.mu)
+ dtheta.deta(sigma, .link.sigma, earg= .esigma) *
+ dtheta.deta(mymu, .link.mu, earg= .emu)
wz * w
- }), list(.link.sigma=link.sigma, .link.mu=link.mu))))
+ }), list(.link.sigma=link.sigma, .link.mu=link.mu,
+ .esigma=esigma, .emu=emu ))))
}
lms.bcg <- function(percentiles=c(25,50,75),
zero=NULL,
- link.sigma="loge",
link.mu="identity",
+ link.sigma="loge",
+ emu=list(), esigma=list(),
dfmu.init=4,
dfsigma.init=2,
init.lambda=1,
@@ -153,25 +166,29 @@ lms.bcg <- function(percentiles=c(25,50,75),
link.sigma <- as.character(substitute(link.sigma))
if(mode(link.mu) != "character" && mode(link.mu) != "name")
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",
"Links: ",
"lambda",
", ",
- namesof("mu", link=link.mu),
+ namesof("mu", link=link.mu, earg= emu),
", ",
- namesof("sigma", link=link.sigma)),
+ 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(any(y<0, na.rm = TRUE))
+ if(ncol(cbind(y)) != 1)
+ stop("response must be a vector or a one-column matrix")
+ if(any(y<0, na.rm = TRUE))
stop("negative responses not allowed")
- predictors.names <- c("lambda",
- namesof("mu", .link.mu, short= TRUE),
- namesof("sigma", .link.sigma, short= TRUE))
+ predictors.names <- c(namesof("lambda", "identity"),
+ namesof("mu", .link.mu, earg= .emu, short=TRUE),
+ namesof("sigma", .link.sigma, earg= .esigma, short=TRUE))
if(!length(etastart)) {
@@ -192,25 +209,28 @@ lms.bcg <- function(percentiles=c(25,50,75),
} else .init.sigma
etastart <- cbind(lambda.init,
- theta2eta(fv.init, .link.mu),
- theta2eta(sigma.init, .link.sigma))
+ theta2eta(fv.init, .link.mu, earg= .emu),
+ theta2eta(sigma.init, .link.sigma, earg= .esigma))
}
}), list(.link.sigma=link.sigma,
.link.mu=link.mu,
+ .esigma=esigma, .emu=emu,
.dfmu.init=dfmu.init,
.dfsigma.init=dfsigma.init,
.init.lambda=init.lambda,
.init.sigma=init.sigma))),
inverse=eval(substitute(function(eta, extra=NULL) {
- eta[,2] <- eta2theta(eta[,2], .link.mu)
- eta[,3] <- eta2theta(eta[,3], .link.sigma)
+ 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$links = c(lambda = "identity", mu = .link.mu, sigma = .link.sigma)
+ 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
if(control$cdf) {
post$cdf = cdf.lms.bcg(y, eta0=matrix(c(lambda,mymu,sigma),
@@ -218,24 +238,26 @@ lms.bcg <- function(percentiles=c(25,50,75),
}
}), list(.percentiles=percentiles,
.link.mu=link.mu,
+ .esigma=esigma, .emu=emu,
.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)
- sigma <- eta2theta(eta[,3], .link.sigma)
+ 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)))
- }, list(.link.sigma=link.sigma, .link.mu=link.mu))),
+ }, list(.link.sigma=link.sigma,
+ .esigma=esigma, .emu=emu,
+ .link.mu=link.mu))),
vfamily=c("lms.bcg", "lmscreg"),
deriv=eval(substitute(expression({
lambda <- eta[,1]
- mymu <- eta2theta(eta[,2], .link.mu)
- sigma <- eta2theta(eta[,3], .link.sigma)
+ 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
@@ -245,12 +267,13 @@ lms.bcg <- function(percentiles=c(25,50,75),
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)
+ dsigma.deta <- dtheta.deta(sigma, link=.link.sigma, earg= .esigma)
cbind(dl.dlambda,
- dl.dmu * dtheta.deta(mymu, link= .link.mu),
+ dl.dmu * dtheta.deta(mymu, link= .link.mu, earg= .emu),
dl.dsigma * dsigma.deta) * w
- }), list(.link.sigma=link.sigma, .link.mu=link.mu))),
+ }), list(.link.sigma=link.sigma, .link.mu=link.mu,
+ .esigma=esigma, .emu=emu ))),
weight=eval(substitute(expression({
tt <- trigamma(theta)
@@ -266,16 +289,17 @@ lms.bcg <- function(percentiles=c(25,50,75),
}
wz[,iam(2,2,M)] <- 1 / (mymu*sigma)^2 *
- dtheta.deta(mymu, .link.mu)^2
+ dtheta.deta(mymu, .link.mu, earg= .emu)^2
wz[,iam(3,3,M)] <- (4*theta*(theta*tt-1) / sigma^2) *
- dtheta.deta(sigma, .link.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)] *
- dtheta.deta(mymu, .link.mu)
+ dtheta.deta(mymu, .link.mu, earg= .emu)
wz[,iam(1,3,M)] <- 2 * theta^1.5 * (2 * theta * tt - 2 -
- 1/theta) * dtheta.deta(sigma, .link.sigma)
+ 1/theta) * dtheta.deta(sigma, .link.sigma, earg= .esigma)
wz * w
- }), list(.link.sigma=link.sigma, .link.mu=link.mu))))
+ }), list(.link.sigma=link.sigma, .link.mu=link.mu,
+ .esigma=esigma, .emu=emu ))))
}
@@ -507,6 +531,7 @@ lms.yjn <- function(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.0,
@@ -522,6 +547,8 @@ lms.yjn <- function(percentiles=c(25,50,75),
link.sigma <- as.character(substitute(link.sigma))
if(mode(link.lambda) != "character" && mode(link.lambda) != "name")
link.lambda <- as.character(substitute(link.lambda))
+ if(!is.list(elambda)) elambda = list()
+ if(!is.list(esigma)) esigma = list()
rule = rule[1] # Number of points (common) for all the quadrature schemes
if(rule != 5 && rule != 10)
@@ -530,15 +557,19 @@ lms.yjn <- function(percentiles=c(25,50,75),
new("vglmff",
blurb=c("LMS Quantile Regression (Yeo-Johnson transformation to normality)\n",
"Links: ",
- namesof("lambda", link=link.lambda),
+ namesof("lambda", link=link.lambda, earg= elambda),
", mu, ",
- namesof("sigma", link=link.sigma)),
+ 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({
- predictors.names <- c(namesof("lambda", .link.lambda, short= TRUE),
- "mu", namesof("sigma", .link.sigma, short= TRUE))
+ 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),
+ "mu",
+ namesof("sigma", .link.sigma, earg= .esigma, short= TRUE))
y.save <- y
yoff = if(is.Numeric( .yoffset)) .yoffset else -median(y)
@@ -566,28 +597,31 @@ lms.yjn <- function(percentiles=c(25,50,75),
} else
.init.sigma
- etastart <- cbind(theta2eta(lambda.init, .link.lambda),
+ etastart <- cbind(theta2eta(lambda.init, .link.lambda, earg= .elambda),
fv.init,
- theta2eta(sigma.init, .link.sigma))
+ theta2eta(sigma.init, .link.sigma, earg= .esigma))
}
}), list(.link.sigma=link.sigma,
.link.lambda=link.lambda,
+ .esigma=esigma, .elambda=elambda,
.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)
- eta[,3] = eta2theta(eta[,3], .link.sigma)
+ 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$percentiles <- .percentiles
- misc$links = c(lambda= .link.lambda, mu= "identity", sigma= .link.sigma)
+ 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
@@ -599,23 +633,25 @@ lms.yjn <- function(percentiles=c(25,50,75),
ncol=3, dimnames=list(dimnames(x)[[1]], NULL)))
}
}), list(.percentiles=percentiles,
+ .esigma=esigma, .elambda=elambda,
.link.lambda=link.lambda,
.link.sigma=link.sigma))),
loglikelihood=eval(substitute(
function(mu,y,w, residuals= FALSE, eta, extra=NULL) {
- lambda <- eta2theta(eta[,1], .link.lambda)
+ lambda <- eta2theta(eta[,1], .link.lambda, earg= .elambda)
mu <- eta[,2]
- sigma <- eta2theta(eta[,3], .link.sigma)
+ 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)))
- }, list(.link.sigma=link.sigma, .link.lambda=link.lambda))),
+ }, 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)
+ lambda <- eta2theta(eta[,1], .link.lambda, earg= .elambda)
mymu <- eta[,2]
- sigma <- eta2theta(eta[,3], .link.sigma)
+ sigma <- eta2theta(eta[,3], .link.sigma, earg= .esigma)
psi <- yeo.johnson(y, lambda)
d1 <- yeo.johnson(y, lambda, deriv=1)
@@ -624,13 +660,14 @@ lms.yjn <- function(percentiles=c(25,50,75),
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)
- dsigma.deta <- dtheta.deta(sigma, link=.link.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,
dl.dsigma * dsigma.deta) * w
- }), list(.link.sigma=link.sigma, .link.lambda=link.lambda))),
+ }), list( .esigma=esigma, .elambda=elambda,
+ .link.sigma=link.sigma, .link.lambda=link.lambda ))),
weight=eval(substitute(expression({
wz <- matrix(0, n, 6)
@@ -762,6 +799,7 @@ lms.yjn <- function(percentiles=c(25,50,75),
wz = wz * w
wz
}), list(.link.sigma=link.sigma,
+ .esigma=esigma, .elambda=elambda,
.rule=rule,
.diagW=diagW,
.iters.diagW=iters.diagW,
@@ -799,12 +837,13 @@ lms.yjn1 = function(percentiles=c(25,50,75),
new("vglmff",
blurb=c("LMS Quantile Regression (Yeo-Johnson transformation to normality)\n",
"Links: ",
- namesof("lambda", link=link.lambda)),
+ 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, short= TRUE))
+ predictors.names <- c(
+ namesof("lambda", .link.lambda, earg= .elambda, short= TRUE))
y.save <- y
yoff = if(is.Numeric( .yoffset)) .yoffset else -median(y)
@@ -834,7 +873,7 @@ lms.yjn1 = function(percentiles=c(25,50,75),
1
extra$sigma = sigma.init
- etastart <- cbind(theta2eta(lambda.init, .link.lambda))
+ etastart <- cbind(theta2eta(lambda.init, .link.lambda, earg= .elambda))
}
}), list(.link.lambda=link.lambda,
.dfmu.init=dfmu.init,
@@ -843,7 +882,7 @@ lms.yjn1 = function(percentiles=c(25,50,75),
.yoffset=yoffset,
))),
inverse=eval(substitute(function(eta, extra=NULL) {
- eta = eta2theta(eta, .link.lambda)
+ eta = eta2theta(eta, .link.lambda, earg= .elambda)
eta2 = extra$mymu
eta3 = extra$sigma
qtplot.lms.yjn(percentiles= .percentiles,
@@ -852,7 +891,8 @@ lms.yjn1 = function(percentiles=c(25,50,75),
.link.lambda=link.lambda))),
last=eval(substitute(expression({
misc$percentiles <- .percentiles
- misc$links <- c(lambda = .link.lambda)
+ 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
@@ -867,7 +907,7 @@ lms.yjn1 = function(percentiles=c(25,50,75),
.link.lambda=link.lambda))),
loglikelihood=eval(substitute(
function(mu,y,w, residuals= FALSE, eta, extra=NULL) {
- lambda <- eta2theta(eta, .link.lambda)
+ lambda <- eta2theta(eta, .link.lambda, earg= .elambda)
mu <- extra$mymu
sigma <- extra$sigma
psi <- yeo.johnson(y, lambda)
@@ -876,7 +916,7 @@ lms.yjn1 = function(percentiles=c(25,50,75),
}, list(.link.lambda=link.lambda))),
vfamily=c("lms.yjn", "lmscreg"),
deriv=eval(substitute(expression({
- lambda <- eta2theta(eta, .link.lambda)
+ 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)
@@ -892,10 +932,11 @@ lms.yjn1 = function(percentiles=c(25,50,75),
dl.dlambda = -AA * d1 / sigma
warning("dl.dlambda is wrong")
- dlambda.deta <- dtheta.deta(lambda, link=.link.lambda)
+ 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,
+ .dfsigma.init=dfsigma.init,
+ .elambda=stop("hi4"),
.link.lambda=link.lambda))),
weight=eval(substitute(expression({
wz = (d1 / sigma)^2 # Approximate
diff --git a/R/family.rcqo.q b/R/family.rcqo.q
index 73b41e7..bab771c 100644
--- a/R/family.rcqo.q
+++ b/R/family.rcqo.q
@@ -77,7 +77,17 @@ rcqo <- function(n, p, S,
if(Rank > 1 && any(diff(sdlv) > 0))
stop("argument \"sdlv)\" must be a vector with decreasing values")
- if(length(seed)) set.seed(seed)
+ if(!exists(".Random.seed", envir = .GlobalEnv, inherits = FALSE))
+ runif(1) # initialize the RNG if necessary
+ if(is.null(seed)) {
+ RNGstate <- get(".Random.seed", envir = .GlobalEnv)
+ } else {
+ R.seed <- get(".Random.seed", envir = .GlobalEnv)
+ set.seed(seed)
+ RNGstate <- structure(seed, kind = as.list(RNGkind()))
+ on.exit(assign(".Random.seed", R.seed, envir = .GlobalEnv))
+ }
+
V = matrix(rhox, p-1, p-1)
diag(V) = 1
L = chol(V)
@@ -216,7 +226,7 @@ rcqo <- function(n, p, S,
attr(ans, "EqualTolerances") = EqualTolerances
attr(ans, "EqualMaxima") = EqualMaxima || all(loabundance == hiabundance)
attr(ans, "ESOptima") = ESOptima
- attr(ans, "seed") = seed
+ attr(ans, "seed") = RNGstate
attr(ans, "sdTolerances") = sdTolerances
attr(ans, "sdlv") = sdlv
attr(ans, "sdOptima") = sdOptima
diff --git a/R/family.rrr.q b/R/family.rrr.q
index be82fe0..cbbee2b 100644
--- a/R/family.rrr.q
+++ b/R/family.rrr.q
@@ -1086,7 +1086,7 @@ Coef.qrrvglm <- function(object, varlvI = FALSE, reference = NULL, ...) {
}
-setClass("Coef.rrvglm", representation(
+setClass(Class="Coef.rrvglm", representation(
"A" = "matrix",
"B1" = "matrix",
"C" = "matrix",
@@ -1095,7 +1095,7 @@ setClass("Coef.rrvglm", representation(
"colx2.index" = "numeric",
"Atilde" = "matrix"))
-setClass("Coef.uqo", representation(
+setClass(Class="Coef.uqo", representation(
"A" = "matrix",
"B1" = "matrix",
"Constrained" = "logical",
@@ -1112,7 +1112,7 @@ setClass("Coef.uqo", representation(
"Dzero" = "logical",
"Tolerance" = "array"))
-setClass("Coef.qrrvglm", representation("Coef.uqo",
+setClass(Class="Coef.qrrvglm", representation("Coef.uqo",
"C" = "matrix"))
printCoef.qrrvglm = function(x, ...) {
@@ -2512,7 +2512,7 @@ printsummary.qrrvglm = function(x, ...) {
}
-setClass("summary.qrrvglm", representation("qrrvglm"))
+setClass(Class="summary.qrrvglm", representation("qrrvglm"))
setMethod("summary", "qrrvglm",
function(object, ...)
@@ -2806,7 +2806,7 @@ vcovqrrvglm = function(object,
"Maximum"))
NAthere = is.na(answer %*% rep(1, len=3))
answer[NAthere,] = NA # NA in tolerance means NA everywhere else
- new("vcov.qrrvglm",
+ new(Class="vcov.qrrvglm",
Cov.unscaled=Cov.unscaled,
dispersion=dispersion,
se=sqrt(answer))
@@ -2819,7 +2819,7 @@ setMethod("vcov", "rrvglm", function(object, ...)
setMethod("vcov", "qrrvglm", function(object, ...)
vcovqrrvglm(object, ...))
-setClass("vcov.qrrvglm", representation(
+setClass(Class="vcov.qrrvglm", representation(
Cov.unscaled="array", # permuted cov.unscaled
dispersion="numeric",
se="matrix"))
diff --git a/R/family.survival.q b/R/family.survival.q
index 8e8c3c3..3d6cff5 100644
--- a/R/family.survival.q
+++ b/R/family.survival.q
@@ -8,24 +8,27 @@
dcnormal1 = function(r1=0, r2=0, link.sd="loge",
+ earg=list(),
isd=NULL, zero=NULL)
{
if(!is.Numeric(r1, allow=1, integ=TRUE) || r1<0) stop("bad input for r1")
if(!is.Numeric(r2, allow=1, integ=TRUE) || r2<0) stop("bad input for r2")
if(mode(link.sd) != "character" && mode(link.sd) != "name")
link.sd = as.character(substitute(link.sd))
+ if(!is.list(earg)) earg = list()
new("vglmff",
blurb=c("Univariate Normal distribution with double censoring\n\n",
"Links: ",
- "mean; ", namesof("sd", link.sd, tag= TRUE),
+ "mean; ", namesof("sd", link.sd, earg=earg, tag= TRUE),
"\n",
"Variance: sd^2"),
constraints=eval(substitute(expression({
constraints = cm.zero.vgam(constraints, x, .zero, M)
}) , list( .zero=zero))),
initialize=eval(substitute(expression({
- predictors.names = c("mean", namesof("sd", .link.sd, tag= FALSE))
+ predictors.names =
+ c("mean", namesof("sd", .link.sd, earg=.earg, tag= FALSE))
if(ncol(y <- cbind(y)) != 1)
stop("the response must be a vector or a one-column matrix")
if(length(w) != n || !is.Numeric(w, integ=TRUE, posit=TRUE))
@@ -39,27 +42,32 @@ dcnormal1 = function(r1=0, r2=0, link.sd="loge",
lm.wfit(x=x, y=y, w=w, method="qr")
1.25 * sqrt( sum(w * junk$resid^2) / junk$df.residual )
}
- etastart = cbind(mu=y, theta2eta(sd.y.est, .link.sd))
+ etastart = cbind(mu=y,
+ theta2eta(sd.y.est, .link.sd, earg=.earg))
}
- }) , list( .link.sd=link.sd, .r1=r1, .r2=r2, .isd=isd))),
+ }) , list( .link.sd=link.sd, .r1=r1, .r2=r2, .isd=isd,
+ .earg=earg ))),
inverse=function(eta, extra=NULL) eta[,1],
last=eval(substitute(expression({
misc$link = c(mu="identity", sd= .link.sd)
+ misc$earg = list(mu=list(), sd= .earg)
misc$expected = TRUE
misc$r1 = .r1
misc$r2 = .r2
- }) , list( .link.sd=link.sd, .r1=r1, .r2=r2))),
+ }) , list( .link.sd=link.sd, .r1=r1, .r2=r2,
+ .earg=earg ))),
loglikelihood=eval(substitute(
function(mu,y,w,residuals= FALSE,eta, extra=NULL) {
- sd = eta2theta(eta[,2], .link.sd)
+ sd = eta2theta(eta[,2], .link.sd, earg=.earg)
if(residuals) stop("loglikelihood residuals not implemented yet") else
sum(w * (-log(sd) - 0.5 * ((y - mu)/sd)^2)) +
(if(.r1==0) 0 else {z1=min((y-mu)/sd); Fz1=pnorm(z1); .r1*log(Fz1)}) +
(if(.r2==0) 0 else {z2=max((y-mu)/sd); Fz2=pnorm(z2); .r2*log(1-Fz2)})
- } , list( .link.sd=link.sd, .r1=r1, .r2=r2))),
+ } , list( .link.sd=link.sd, .r1=r1, .r2=r2,
+ .earg=earg ))),
vfamily=c("dcnormal1"),
deriv=eval(substitute(expression({
- sd = eta2theta(eta[,2], .link.sd)
+ sd = eta2theta(eta[,2], .link.sd, earg=.earg)
q1 = .r1 / extra$bign
q2 = .r2 / extra$bign
pee = 1 - q1 - q2 # 1 if r1==r2==0
@@ -74,9 +82,10 @@ dcnormal1 = function(r1=0, r2=0, link.sd="loge",
dl.dsd = -1/sd + (y-mu)^2 / sd^3 +
((- .r1 * z1*fz1/Fz1 + .r2 * z2*fz2/(1-Fz2)) / sd) / (n*w)
dmu.deta = dtheta.deta(mu, "identity")
- dsd.deta = dtheta.deta(sd, .link.sd)
+ dsd.deta = dtheta.deta(sd, .link.sd, earg=.earg)
cbind(w * dl.dmu * dmu.deta, w * dl.dsd * dsd.deta)
- }) , list( .link.sd=link.sd, .r1=r1, .r2=r2))),
+ }) , list( .link.sd=link.sd, .r1=r1, .r2=r2,
+ .earg=earg ))),
weight=expression({
wz = matrix(as.numeric(NA), n, dimm(M))
Q1 = ifelse(q1==0, 1, q1) # Saves division by 0 below; not elegant
@@ -159,6 +168,7 @@ bisa.control <- function(save.weight=TRUE, ...)
bisa = function(lshape="loge",
lscale="loge",
+ eshape = list(), escale = list(),
ishape=NULL, iscale=1,
method.init=1, fsmax=9001, zero=NULL)
{
@@ -175,22 +185,24 @@ bisa = function(lshape="loge",
stop("method.init must be 1 or 2")
if(!is.Numeric(fsmax, allow=1, integ=TRUE))
stop("bad input for \"fsmax\"")
+ if(!is.list(eshape)) eshape = list()
+ if(!is.list(escale)) escale = list()
new("vglmff",
blurb=c("Birnbaum-Saunders distribution\n\n",
"Links: ",
- namesof("shape", lshape, tag= TRUE), "; ",
- namesof("scale", lscale, tag= TRUE)),
+ namesof("shape", lshape, earg= eshape, tag= TRUE), "; ",
+ namesof("scale", lscale, earg= escale, tag= TRUE)),
constraints=eval(substitute(expression({
constraints = cm.zero.vgam(constraints, x, .zero, M)
}) , list( .zero=zero))),
initialize=eval(substitute(expression({
+ if(ncol(y <- cbind(y)) != 1)
+ stop("the response must be a vector or a one-column matrix")
useFS <- intercept.only || n < .fsmax
save.weight <- control$save.weight <- !useFS
- predictors.names = c(namesof("shape", .lshape, tag= FALSE),
+ predictors.names = c(namesof("shape", .lshape, earg= .eshape, tag= FALSE),
namesof("scale", .lscale, tag= FALSE))
- if(ncol(y <- cbind(y)) != 1)
- stop("the response must be a vector or a one-column matrix")
if(!length(etastart)) {
scale.init = rep( .iscale, len=n)
shape.init = if( .method.init==2) sqrt(2*( pmax(y, scale.init+0.1) /
@@ -198,39 +210,44 @@ bisa = function(lshape="loge",
ybar = rep(weighted.mean(y, w), len=n)
sqrt(2*( pmax(ybar, scale.init+0.1) / scale.init - 1))
}
- etastart = cbind(theta2eta(shape.init, .lshape),
- theta2eta(scale.init, .lscale))
+ etastart = cbind(theta2eta(shape.init, .lshape, earg= .eshape),
+ theta2eta(scale.init, .lscale, earg= .escale))
}
}) , list( .lshape=lshape, .lscale=lscale, .ishape=ishape, .iscale=iscale,
+ .eshape=eshape, .escale=escale,
.fsmax=fsmax, .method.init=method.init ))),
inverse=eval(substitute(function(eta, extra=NULL) {
- sh = eta2theta(eta[,1], .lshape)
- sc = eta2theta(eta[,2], .lscale)
+ sh = eta2theta(eta[,1], .lshape, earg= .eshape)
+ sc = eta2theta(eta[,2], .lscale, earg= .escale)
sc * (1 + sh^2 / 2)
- }, list( .lshape=lshape, .lscale=lscale ))),
+ }, list( .lshape=lshape, .lscale=lscale,
+ .eshape=eshape, .escale=escale ))),
last=eval(substitute(expression({
misc$link = c(shape= .lshape, scale= .lscale)
+ misc$earg = list(shape= .eshape, scale= .escale)
misc$expected = useFS
misc$BFGS = !useFS
- }) , list( .lshape=lshape, .lscale=lscale ))),
+ }) , list( .lshape=lshape, .lscale=lscale,
+ .eshape=eshape, .escale=escale ))),
loglikelihood=eval(substitute(
function(mu,y,w,residuals= FALSE,eta, extra=NULL) {
- sh = eta2theta(eta[,1], .lshape)
- sc = eta2theta(eta[,2], .lscale)
+ sh = eta2theta(eta[,1], .lshape, earg= .eshape)
+ sc = eta2theta(eta[,2], .lscale, earg= .escale)
if(residuals) stop("loglikelihood residuals not implemented yet") else
sum(w * (-log(sh) - 0.5 * log(sc) + log(1 + sc/y) -
(y/sc - 2 + sc/y) / (2*sh^2)))
- } , list( .lshape=lshape, .lscale=lscale ))),
+ } , list( .lshape=lshape, .lscale=lscale,
+ .eshape=eshape, .escale=escale ))),
vfamily=c("bisa"),
deriv=eval(substitute(expression({
useFS <- intercept.only || n < .fsmax # must be same as above
- sh = eta2theta(eta[,1], .lshape)
- sc = eta2theta(eta[,2], .lscale)
+ sh = eta2theta(eta[,1], .lshape, earg= .eshape)
+ sc = eta2theta(eta[,2], .lscale, earg= .escale)
dl.dsh = ((y/sc - 2 + sc/y) / sh^2 - 1) / sh
dl.dsc = -0.5 / sc + 1/(y+sc) + sqrt(y) * ((y+sc)/y) *
(sqrt(y/sc) - sqrt(sc/y)) / (2 * sh^2 * sc^1.5)
- dsh.deta = dtheta.deta(sh, .lshape)
- dsc.deta = dtheta.deta(sc, .lscale)
+ dsh.deta = dtheta.deta(sh, .lshape, earg= .eshape)
+ dsc.deta = dtheta.deta(sc, .lscale, earg= .escale)
if(useFS) {
w * cbind(dl.dsh * dsh.deta, dl.dsc * dsc.deta)
} else {
@@ -244,7 +261,9 @@ bisa = function(lshape="loge",
derivnew = w * cbind(dl.dsh * dsh.deta, dl.dsc * dsc.deta)
derivnew
}
- }) , list( .lshape=lshape, .lscale=lscale, .fsmax=fsmax ))),
+ }) , list( .lshape=lshape, .lscale=lscale,
+ .eshape=eshape, .escale=escale,
+ .fsmax=fsmax ))),
weight=eval(substitute(expression({
if(useFS) {
wz = matrix(as.numeric(NA), n, M) # Diagonal!!
diff --git a/R/family.ts.q b/R/family.ts.q
index 2720eb2..1c6657d 100644
--- a/R/family.ts.q
+++ b/R/family.ts.q
@@ -260,10 +260,10 @@ vglm.garma.control <- function(save.weight=TRUE, ...)
garma <- function(link=c("identity","loge","reciprocal",
"logit","probit","cloglog","cauchit"),
+ earg=list(),
p.ar.lag=1, q.lag.ma=0,
coefstart=NULL,
- step=1.0,
- constant=0.1)
+ step=1.0)
{
if(mode(link) != "character" && mode(link) != "name")
link = as.character(substitute(link))
@@ -275,15 +275,16 @@ garma <- function(link=c("identity","loge","reciprocal",
stop("bad input for argument \"q.lag.ma\"")
if(q.lag.ma != 0)
stop("sorry, only q.lag.ma=0 is currently implemented")
+ if(!is.list(earg)) earg = list()
new("vglmff",
blurb=c("GARMA(", p.ar.lag, ",", q.lag.ma, ")\n\n",
"Link: ",
- namesof("mu_t", link),
+ namesof("mu_t", link, earg= earg),
", t = ", paste(paste(1:p.ar.lag, coll=",", sep=""))),
initialize=eval(substitute(expression({
plag <- .p.ar.lag
- predictors.names = namesof("mu", .link, tag=FALSE)
+ predictors.names = namesof("mu", .link, earg= .earg, tag=FALSE)
indices <- 1:plag
tt <- (1+plag):nrow(x)
pp <- ncol(x)
@@ -323,14 +324,15 @@ garma <- function(link=c("identity","loge","reciprocal",
for(i in 1:plag)
more[[i]] <- i + max(unlist(attr(x.save, "assign")))
attr(x, "assign") <- c(attr(x.save, "assign"), more)
- }), list( .link=link, .p.ar.lag=p.ar.lag, .coefstart=coefstart ))),
+ }), list( .link=link, .p.ar.lag=p.ar.lag, .coefstart=coefstart, .earg=earg ))),
inverse=eval(substitute(function(eta, extra=NULL) {
- eta2theta(eta, link= .link)
- }, list( .link=link ))),
+ eta2theta(eta, link= .link, earg= .earg)
+ }, list( .link=link, .earg=earg ))),
last=eval(substitute(expression({
misc$link <- c(mu = .link)
+ misc$earg <- list(mu = .earg)
misc$plag <- plag
- }), list( .link=link ))),
+ }), list( .link=link, .earg=earg ))),
loglikelihood=eval(substitute(
function(mu, y, w, residuals = FALSE, eta, extra=NULL) {
if(residuals) switch( .link,
@@ -343,7 +345,7 @@ garma <- function(link=c("identity","loge","reciprocal",
loge=sum(w*(-mu + y*log(mu))),
inverse=sum(w*(-mu + y*log(mu))),
sum(w*(y*log(mu) + (1-y)*log(1-mu))))
- }, list( .link=link ))),
+ }, list( .link=link, .earg=earg ))),
middle2=eval(substitute(expression({
realfv <- fv
for(i in 1:plag) {
@@ -353,7 +355,7 @@ garma <- function(link=c("identity","loge","reciprocal",
true.eta <- realfv + offset
mu <- family at inverse(true.eta, extra) # overwrite mu with correct one
- }), list( .link=link ))),
+ }), list( .link=link, .earg=earg ))),
vfamily=c("garma", "vglmgam"),
deriv=eval(substitute(expression({
dl.dmu <- switch( .link,
@@ -361,17 +363,15 @@ garma <- function(link=c("identity","loge","reciprocal",
loge=(y-mu)/mu,
inverse=(y-mu)/mu,
(y-mu) / (mu*(1-mu)))
- dmu.deta <- dtheta.deta(mu, .link)
+ dmu.deta <- dtheta.deta(mu, .link, earg= .earg)
step <- .step # This is another method of adjusting step lengths
step * w * dl.dmu * dmu.deta
- }), list( .link=link, .step=step ))),
+ }), list( .link=link, .step=step, .earg=earg ))),
weight=eval(substitute(expression({
x[,1:pp] <- x.save[tt,1:pp] # Reinstate
for(i in 1:plag) {
- temp = theta2eta(y.save[tt-i], .link,
- earg=if( any( .link == c("loge","logit")) )
- .constant else NULL)
+ temp = theta2eta(y.save[tt-i], .link, earg= .earg)
x[,1:pp] <- x[,1:pp] - x.save[tt-i,1:pp] * new.coeffs[i+pp]
x[,pp+i] <- temp - x.save[tt-i,1:pp,drop=FALSE] %*% new.coeffs[1:pp]
}
@@ -387,8 +387,9 @@ garma <- function(link=c("identity","loge","reciprocal",
loge=mu,
inverse=mu^2,
mu*(1-mu))
- w * dtheta.deta(mu, link= .link)^2 / vary
- }), list( .link=link, .constant=constant ))))
+ w * dtheta.deta(mu, link= .link, earg= .earg)^2 / vary
+ }), list( .link=link,
+ .earg=earg ))))
}
@@ -397,7 +398,7 @@ garma <- function(link=c("identity","loge","reciprocal",
if(FALSE) {
-setClass("Coef.rrar", representation(
+setClass(Class="Coef.rrar", representation(
"plag" = "integer",
"Ranks" = "integer",
"omega" = "integer",
@@ -411,7 +412,7 @@ setClass("Coef.rrar", representation(
Coef.rrar = function(object, ...) {
- result = new("Coef.rrar",
+ result = new(Class="Coef.rrar",
"plag" = object at misc$plag,
"Ranks" = object at misc$Ranks,
"omega" = object at misc$omega,
diff --git a/R/family.univariate.q b/R/family.univariate.q
index 39b2884..bffae55 100644
--- a/R/family.univariate.q
+++ b/R/family.univariate.q
@@ -11,6 +11,11 @@
+
+
+
+
+
mccullagh89 = function(ltheta="rhobit", lnu="logoff",
itheta=NULL, inu=NULL,
etheta=list(),
@@ -45,7 +50,7 @@ mccullagh89 = function(ltheta="rhobit", lnu="logoff",
if(any(y <= -1 | y >= 1))
stop("all y values must be in (-1,1)")
predictors.names= c(namesof("theta", .ltheta, earg= .etheta,tag=FALSE),
- namesof("nu", .lnu, earg= .enu, tag= FALSE))
+ namesof("nu", .lnu, earg= .enu, tag=FALSE))
if(!length(etastart)) {
theta.init = if(length(.itheta)) rep(.itheta, length=n) else {
theta.grid = rvar = seq(-0.9, 0.9, by=0.1)
@@ -109,56 +114,58 @@ mccullagh89 = function(ltheta="rhobit", lnu="logoff",
-hzeta = function(link="loglog", init.alpha=NULL)
+hzeta = function(link="loglog", earg=list(), init.alpha=NULL)
{
if(length(init.alpha) && !is.Numeric(init.alpha, positive=TRUE))
stop("'init.alpha' must be > 0")
if(mode(link) != "character" && mode(link) != "name")
link = as.character(substitute(link))
+ if(!is.list(earg)) earg = list()
new("vglmff",
blurb=c(
"Haight's Zeta distribution f(y) = (2y-1)^(-alpha) - (2y+1)^(-alpha),\n",
" alpha>0, y=1,2,..\n\n",
"Link: ",
- namesof("alpha", link), "\n\n",
+ namesof("alpha", link, earg=earg), "\n\n",
"Mean: (1-2^(-alpha)) * zeta(alpha) if alpha>1",
"\n",
"Variance: (1-2^(1-alpha)) * zeta(alpha-1) - mean^2 if alpha>2"),
initialize=eval(substitute(expression({
y = as.numeric(y)
+ if(ncol(cbind(y)) != 1)
+ stop("response must be a vector or a one-column matrix")
if(any(y < 1))
stop("all y values must be in 1,2,3,...")
-
- predictors.names = namesof("alpha", .link, tag= FALSE)
-
+ 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
if(meany < 2.5) 1.4 else 1.1
}
ainit = rep(ainit, length=n)
- etastart = theta2eta(ainit, .link)
+ etastart = theta2eta(ainit, .link, earg= .earg )
}
- }), list( .link=link, .init.alpha=init.alpha ))),
+ }), list( .link=link, .earg=earg, .init.alpha=init.alpha ))),
inverse=eval(substitute(function(eta, extra=NULL) {
- alpha = eta2theta(eta, .link)
+ alpha = eta2theta(eta, .link, earg= .earg )
mu = (1-2^(-alpha)) * zeta(alpha)
mu[alpha <= 1] = Inf
mu
- }, list( .link=link ))),
+ }, 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 ))),
+ }), list( .link=link, .earg=earg ))),
loglikelihood=eval(substitute(
function(mu,y,w,residuals= FALSE,eta, extra=NULL) {
- alpha = eta2theta(eta, .link)
+ 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 )))
- }, list( .link=link ))),
+ }, list( .link=link, .earg=earg ))),
vfamily=c("hzeta"),
deriv=eval(substitute(expression({
if(iter==1) {
@@ -166,16 +173,16 @@ hzeta = function(link="loglog", init.alpha=NULL)
"alpha", hessian= TRUE)
}
- alpha = eta2theta(eta, .link)
+ alpha = eta2theta(eta, .link, earg= .earg )
eval.d3 = eval(d3)
dl.dalpha = attr(eval.d3, "gradient")
- dalpha.deta = dtheta.deta(alpha, .link)
+ dalpha.deta = dtheta.deta(alpha, .link, earg= .earg )
dl.dalpha * dalpha.deta
- }), list( .link=link ))),
+ }), 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)
+ dl.dalpha * d2theta.deta2(alpha, .link, earg= .earg )
if(FALSE && intercept.only) {
sumw = sum(w)
@@ -186,7 +193,7 @@ hzeta = function(link="loglog", init.alpha=NULL)
} else
pooled.weight = FALSE
c(wz)
- }), list( .link=link ))))
+ }), list( .link=link, .earg=earg ))))
}
@@ -246,8 +253,8 @@ rhzeta = function(n, alpha)
}
-dirmultinomial = function(lphi="logit",
- iphi = 0.10, parallel= FALSE, zero="M")
+dirmultinomial = function(lphi="logit", ephi = list(),
+ iphi = 0.10, parallel= FALSE, zero="M")
{
if(mode(lphi) != "character" && mode(lphi) != "name")
@@ -257,12 +264,13 @@ dirmultinomial = function(lphi="logit",
stop("bad input for argument \"zero\"")
if(!is.Numeric(iphi, positive=TRUE) || max(iphi) >= 1.0)
stop("bad input for argument \"iphi\"")
+ if(!is.list(ephi)) ephi = list()
new("vglmff",
blurb=c("Dirichlet-multinomial distribution\n\n",
"Links: ",
"log(prob[1]/prob[M]), ..., log(prob[M-1]/prob[M]), ",
- namesof("phi", lphi), "\n", "\n",
+ namesof("phi", lphi, earg=ephi), "\n", "\n",
"Mean: shape_j / sum_j(shape_j)"),
constraints=eval(substitute(expression({
.ZERO = .zero
@@ -290,7 +298,7 @@ dirmultinomial = function(lphi="logit",
stop("all values of the response (matrix) must be non-negative")
predictors.names =
c(paste("log(prob[,",1:(M-1),"]/prob[,",M,"])", sep=""),
- namesof("phi", .lphi, short= TRUE))
+ namesof("phi", .lphi, short=TRUE))
extra$n2 = w # aka omega, must be integer # as.vector(apply(y, 1, sum))
if(!length(etastart)) {
prob.init = apply(ycount, 2, sum)
@@ -298,28 +306,32 @@ dirmultinomial = function(lphi="logit",
prob.init = matrix(prob.init, n, M, byrow=TRUE)
phi.init = rep( .iphi, len=n)
etastart = cbind(log(prob.init[,-M]/prob.init[,M]),
- theta2eta(phi.init, .lphi))
+ theta2eta(phi.init, .lphi, earg= .ephi ))
}
- }), list( .lphi=lphi, .iphi=iphi ))),
+ }), list( .lphi=lphi, .ephi=ephi, .iphi=iphi ))),
inverse=eval(substitute(function(eta, extra=NULL) {
M = if(is.matrix(eta)) ncol(eta) else 1
temp = cbind(exp(eta[,-M]), 1)
temp / as.vector(temp %*% rep(1, M))
- }, list( .lphi=lphi ))),
+ }, list( .ephi=ephi, .lphi=lphi ))),
last=eval(substitute(expression({
misc$link = c(rep("noLinkFunction", length=M-1), .lphi)
names(misc$link) = c(paste("prob", 1:(M-1), sep=""), "phi")
+ misc$earg = vector("list", M)
+ names(misc$earg) = names(misc$link)
+ for(ii in 1:(M-1)) misc$earg[[ii]] = list()
+ misc$earg[[M]] = .ephi
misc$expected = TRUE
if(intercept.only) {
misc$shape=probs[1,]*(1/phi[1]-1) # phi & probs computed in @deriv
}
- }), list( .lphi=lphi ))),
+ }), list( .ephi=ephi, .lphi=lphi ))),
loglikelihood=eval(substitute(
function(mu,y,w,residuals= FALSE,eta, extra=NULL) {
M = if(is.matrix(eta)) ncol(eta) else 1
probs = cbind(exp(eta[,-M]), 1)
probs = probs / as.vector(probs %*% rep(1, M))
- phi = eta2theta(eta[,M], .lphi)
+ phi = eta2theta(eta[,M], .lphi, earg= .ephi )
n = length(phi)
ycount = as.matrix(y * w)
if(residuals) stop("loglikelihood residuals not implemented yet") else {
@@ -361,12 +373,12 @@ dirmultinomial = function(lphi="logit",
}
sum(ans)
}
- }, list( .lphi=lphi ))),
+ }, list( .ephi=ephi, .lphi=lphi ))),
vfamily=c("dirmultinomial "),
deriv=eval(substitute(expression({
probs = cbind(exp(eta[,-M]), 1)
probs = probs / as.vector(probs %*% rep(1, M))
- phi = eta2theta(eta[,M], .lphi)
+ phi = eta2theta(eta[,M], .lphi, earg= .ephi )
dl.dprobs = matrix(0.0, n, M-1)
dl.dphi = rep(0.0, len=n)
omega = extra$n2
@@ -421,10 +433,10 @@ dirmultinomial = function(lphi="logit",
}
}
dprobs.deta = probs[,-M] * (1 - probs[,-M]) # n x (M-1)
- dphi.deta = dtheta.deta(phi, .lphi)
+ dphi.deta = dtheta.deta(phi, .lphi, earg= .ephi )
ans = cbind(dl.dprobs * dprobs.deta, dl.dphi * dphi.deta)
ans
- }), list( .lphi=lphi ))),
+ }), list( .ephi=ephi, .lphi=lphi ))),
weight=eval(substitute(expression({
wz = matrix(0, n, dimm(M))
loopOveri = n < maxomega
@@ -500,11 +512,11 @@ dirmultinomial = function(lphi="logit",
index = iam(NA, NA, M, both = TRUE, diag = TRUE)
wz = wz * d1Thetas.deta[,index$row] * d1Thetas.deta[,index$col]
wz
- }), list( .lphi=lphi ))))
+ }), list( .ephi=ephi, .lphi=lphi ))))
}
-dirmul.old = function(link="loge", init.alpha = 0.01,
+dirmul.old = function(link="loge", earg=list(), init.alpha = 0.01,
parallel= FALSE, zero=NULL)
{
@@ -514,12 +526,13 @@ dirmul.old = function(link="loge", init.alpha = 0.01,
stop("bad input for argument \"zero\"")
if(!is.Numeric(init.alpha, posit=TRUE))
stop("'init.alpha' must contain positive values only")
+ if(!is.list(earg)) earg = list()
new("vglmff",
blurb=c("Dirichlet-Multinomial distribution\n\n",
"Links: ",
- namesof("shape1", link), ", ..., ",
- namesof("shapeM", link), "\n\n",
+ namesof("shape1", link, earg=earg), ", ..., ",
+ namesof("shapeM", link, earg=earg), "\n\n",
"Posterior mean: (n_j + shape_j)/(2*sum(n_j) + sum(shape_j))\n"),
constraints=eval(substitute(expression({
constraints = cm.vgam(matrix(1,M,1), x, .parallel, constraints, int= TRUE)
@@ -531,45 +544,49 @@ dirmul.old = function(link="loge", init.alpha = 0.01,
if(any(y != round(y )))
stop("all y values must be integer-valued")
- predictors.names = namesof(paste("shape", 1:M, sep=""), .link, short= TRUE)
+ predictors.names = namesof(paste("shape", 1:M, sep=""), .link,
+ earg=.earg, short=TRUE)
extra$n2 = as.vector(apply(y, 1, sum)) # Nb. don't multiply by 2
extra$y = y
if(!length(etastart)) {
yy = if(is.numeric(.init.alpha))
matrix(.init.alpha, n, M, byrow= TRUE) else
matrix(runif(n*M), n, M)
- etastart = theta2eta(yy, .link)
+ etastart = theta2eta(yy, .link, earg=.earg)
}
- }), list( .link=link, .init.alpha=init.alpha ))),
+ }), list( .link=link, .earg=earg, .init.alpha=init.alpha ))),
inverse=eval(substitute(function(eta, extra=NULL) {
- shape = eta2theta(eta, .link)
+ shape = eta2theta(eta, .link, earg=.earg)
M = if(is.matrix(eta)) ncol(eta) else 1
sumshape = as.vector(shape %*% rep(1, len=M))
(extra$y + shape) / (extra$n2 + sumshape)
- }, list( .link=link ))),
+ }, list( .link=link, .earg=earg ))),
last=eval(substitute(expression({
misc$link = rep(.link, length=M)
names(misc$link) = paste("shape", 1:M, sep="")
+ misc$earg = vector("list", M)
+ names(misc$earg) = names(misc$link)
+ for(ii in 1:M) misc$earg[[ii]] = .earg
misc$pooled.weight = pooled.weight
- }), list( .link=link ))),
+ }), list( .link=link, .earg=earg ))),
loglikelihood=eval(substitute(
function(mu,y,w,residuals= FALSE,eta, extra=NULL) {
- shape = eta2theta(eta, .link)
+ shape = eta2theta(eta, .link, earg=.earg)
M = if(is.matrix(eta)) ncol(eta) else 1
sumshape = as.vector(shape %*% rep(1, len=M))
if(residuals) stop("loglikelihood residuals not implemented yet") else
sum(w*(lgamma(sumshape) - lgamma(extra$n2 + sumshape ))) +
sum(w * (lgamma(y + shape) - lgamma(shape )))
- }, list( .link=link ))),
+ }, list( .link=link, .earg=earg ))),
vfamily=c("dirmul.old"),
deriv=eval(substitute(expression({
- shape = eta2theta(eta, .link)
+ shape = eta2theta(eta, .link, earg=.earg)
sumshape = as.vector(shape %*% rep(1, len=M))
dl.dsh = digamma(sumshape) - digamma(extra$n2 + sumshape) +
digamma(y + shape) - digamma(shape)
- dsh.deta = dtheta.deta(shape, .link)
+ dsh.deta = dtheta.deta(shape, .link, earg=.earg)
w * dl.dsh * dsh.deta
- }), list( .link=link ))),
+ }), list( .link=link, .earg=earg ))),
weight=eval(substitute(expression({
index = iam(NA, NA, M, both = TRUE, diag = TRUE)
wz = matrix(trigamma(sumshape)-trigamma(extra$n2 + sumshape),
@@ -588,7 +605,7 @@ dirmul.old = function(link="loge", init.alpha = 0.01,
pooled.weight = FALSE
wz
- }), list( .link=link ))))
+ }), list( .link=link, .earg=earg ))))
}
@@ -609,17 +626,18 @@ rdiric = function(n, shape, dimension=NULL) {
}
-dirichlet = function(link="loge", zero=NULL)
+dirichlet = function(link="loge", earg=list(), zero=NULL)
{
if(mode(link) != "character" && mode(link) != "name")
link = as.character(substitute(link))
if(length(zero) && !is.Numeric(zero, integer=TRUE, posit=TRUE))
stop("bad input for argument \"zero\"")
+ if(!is.list(earg)) earg = list()
new("vglmff",
blurb=c("Dirichlet distribution\n\n",
"Links: ",
- namesof("shapej", link), "\n\n",
+ namesof("shapej", link, earg=earg), "\n\n",
"Mean: shape_j/(1 + sum(shape_j)), j=1,..,ncol(y)"),
constraints=eval(substitute(expression({
constraints = cm.zero.vgam(constraints, x, .zero, M)
@@ -629,37 +647,44 @@ dirichlet = function(link="loge", zero=NULL)
M = ncol(y)
if(any(y <= 0) || any(y>=1))
stop("all y values must be > 0 and < 1")
- predictors.names = namesof(paste("shape", 1:M, sep=""), .link, short= TRUE)
+ predictors.names = namesof(paste("shape", 1:M, sep=""), .link,
+ earg=.earg, short=TRUE)
if(!length(etastart)) {
yy = matrix(t(y) %*% rep(1/nrow(y), nrow(y)), nrow(y), M, byrow= TRUE)
- etastart = theta2eta(yy, .link)
+ etastart = theta2eta(yy, .link, earg= .earg )
}
- }), list( .link=link ))),
+ }), list( .link=link, .earg=earg ))),
inverse=eval(substitute(function(eta, extra=NULL) {
- shape = eta2theta(eta, .link)
+ shape = eta2theta(eta, .link, earg= .earg )
M = if(is.matrix(eta)) ncol(eta) else 1
sumshape = as.vector(shape %*% rep(1, len=M)) # apply(shape, 1, sum)
shape / sumshape
- }, list( .link=link ))),
+ }, list( .link=link, .earg=earg ))),
last=eval(substitute(expression({
misc$link = c(shape= .link)
- }), list( .link=link ))),
+ temp.names = paste("shape", 1:M, sep="")
+ misc$link = rep( .link, len=M)
+ names(misc$link) = temp.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 ))),
loglikelihood=eval(substitute(
function(mu,y,w,residuals= FALSE,eta, extra=NULL) {
- shape = eta2theta(eta, .link)
+ shape = eta2theta(eta, .link, earg= .earg )
M = if(is.matrix(eta)) ncol(eta) else 1
sumshape = as.vector(shape %*% rep(1, len=M))
if(residuals) stop("loglikelihood residuals not implemented yet") else
sum(w * (lgamma(sumshape) - lgamma(shape) + (shape-1)*log(y )))
- }, list( .link=link ))),
+ }, list( .link=link, .earg=earg ))),
vfamily=c("dirichlet"),
deriv=eval(substitute(expression({
- shape = eta2theta(eta, .link)
+ shape = eta2theta(eta, .link, earg= .earg )
sumshape = as.vector(shape %*% rep(1, len=M))
dl.dsh = digamma(sumshape) - digamma(shape) + log(y)
- dsh.deta = dtheta.deta(shape, .link)
+ dsh.deta = dtheta.deta(shape, .link, earg= .earg )
w * dl.dsh * dsh.deta
- }), list( .link=link ))),
+ }), list( .link=link, .earg=earg ))),
weight=expression({
index = iam(NA, NA, M, both = TRUE, diag = TRUE)
wz = matrix(trigamma(sumshape), nrow=n, ncol=dimm(M))
@@ -776,18 +801,19 @@ dzeta = function(x, p)
ans
}
-zetaff = function(link="loge", init.p=NULL)
+zetaff = function(link="loge", earg=list(), init.p=NULL)
{
if(length(init.p) && !is.Numeric(init.p, positi=TRUE))
stop("argument \"init.p\" must be > 0")
if(mode(link) != "character" && mode(link) != "name")
link = as.character(substitute(link))
+ if(!is.list(earg)) earg = list()
new("vglmff",
blurb=c("Zeta distribution f(y) = 1/(y^(p+1) zeta(p+1)), p>0, y=1,2,..\n\n",
"Link: ",
- namesof("p", link), "\n\n",
+ namesof("p", link, earg=earg), "\n\n",
"Mean: zeta(p) / zeta(p+1), provided p>1\n",
"Variance: zeta(p-1) / zeta(p+1) - mean^2, provided p>2"),
initialize=eval(substitute(expression({
@@ -796,8 +822,10 @@ zetaff = function(link="loge", init.p=NULL)
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("p", .link, tag= FALSE)
+ predictors.names = namesof("p", .link, earg=.earg, tag=FALSE)
if(!length(etastart)) {
llfun = function(pp, y, w) {
@@ -807,33 +835,34 @@ zetaff = function(link="loge", init.p=NULL)
getInitVals(gvals=seq(0.1, 3.0, len=19), llfun=llfun, y=y, w=w)
pp.init = rep(pp.init, length=length(y))
if( .link == "loglog") pp.init[pp.init <= 1] = 1.2
- etastart = theta2eta(pp.init, .link)
+ etastart = theta2eta(pp.init, .link, earg=.earg)
}
- }), list( .link=link, .init.p=init.p ))),
+ }), list( .link=link, .earg=earg, .init.p=init.p ))),
inverse=eval(substitute(function(eta, extra=NULL) {
- ans = pp = eta2theta(eta, .link)
+ ans = pp = eta2theta(eta, .link, earg=.earg)
ans[pp>1] = zeta(pp[pp>1]) / zeta(pp[pp>1]+1)
ans[pp<=1] = NA
ans
- }, list( .link=link ))),
+ }, list( .link=link, .earg=earg ))),
last=eval(substitute(expression({
misc$link = c(pp= .link)
- }), list( .link=link ))),
+ misc$earg = list(pp = .earg)
+ }), list( .link=link, .earg=earg ))),
loglikelihood=eval(substitute(
function(mu,y,w,residuals= FALSE,eta, extra=NULL) {
- pp = eta2theta(eta, .link)
+ pp = eta2theta(eta, .link, earg=.earg)
if(residuals) stop("loglikelihood residuals not implemented yet") else
sum(w * (-(pp+1) * log(y) - log(zeta(pp+1 ))))
- }, list( .link=link ))),
+ }, list( .link=link, .earg=earg ))),
vfamily=c("zeta"),
deriv=eval(substitute(expression({
- pp = eta2theta(eta, .link)
+ pp = eta2theta(eta, .link, earg=.earg)
fred1 = zeta(pp+1)
fred2 = zeta(pp+1, deriv=1)
dl.dpp = -log(y) - fred2 / fred1
- dpp.deta = dtheta.deta(pp, .link)
+ dpp.deta = dtheta.deta(pp, .link, earg=.earg)
w * dl.dpp * dpp.deta
- }), list( .link=link ))),
+ }), list( .link=link, .earg=earg ))),
weight=expression({
ed2l.dpp2 = zeta(pp+1, deriv=2) / fred1 - (fred2/fred1)^2
wz = w * dpp.deta^2 * ed2l.dpp2
@@ -909,9 +938,8 @@ pzipf = function(q, N, s) {
}
-zipf = function(N=NULL, link="loge", init.s=NULL)
+zipf = function(N=NULL, link="loge", earg=list(), init.s=NULL)
{
-
if(length(N) &&
(!is.Numeric(N, positi=TRUE, integ=TRUE, allow=1) || N <= 1))
stop("bad input for argument \"N\"")
@@ -921,22 +949,23 @@ zipf = function(N=NULL, link="loge", init.s=NULL)
if(mode(link) != "character" && mode(link) != "name")
link = as.character(substitute(link))
+ if(!is.list(earg)) earg = list()
new("vglmff",
blurb=c("Zipf distribution f(y;s) = y^(-s) / sum((1:N)^(-s)),",
" s>0, y=1,2,...,N", ifelse(enteredN, paste("=",N,sep=""), ""),
"\n\n",
"Link: ",
- namesof("s", link),
+ namesof("s", link, earg=earg),
"\n\n",
"Mean: gharmonic(N,s-1) / gharmonic(N,s)"),
initialize=eval(substitute(expression({
- if(ncol(y <- cbind(y)) != 1)
+ if(ncol(cbind(y)) != 1)
stop("response must be a vector or a one-column matrix")
y = as.numeric(y)
if(any(y != round(y )))
stop("y must be integer-valued")
- predictors.names = namesof("s", .link, tag= FALSE)
+ predictors.names = namesof("s", .link, earg= .earg, tag=FALSE)
NN = .N
if(!is.Numeric(NN, allow=1, posit=TRUE, integ=TRUE))
NN = max(y)
@@ -954,34 +983,35 @@ zipf = function(N=NULL, link="loge", init.s=NULL)
y=y, N=extra$N, w=w)
ss.init = rep(ss.init, length=length(y))
if( .link == "loglog") ss.init[ss.init <= 1] = 1.2
- etastart = theta2eta(ss.init, .link)
+ etastart = theta2eta(ss.init, .link, earg= .earg)
}
- }), list( .link=link, .init.s=init.s, .N=N ))),
+ }), list( .link=link, .earg=earg, .init.s=init.s, .N=N ))),
inverse=eval(substitute(function(eta, extra=NULL) {
- ss = eta2theta(eta, .link)
+ ss = eta2theta(eta, .link, earg= .earg)
gharmonic(extra$N, s=ss-1) / gharmonic(extra$N, s=ss)
- }, list( .link=link ))),
+ }, list( .link=link, .earg=earg ))),
last=eval(substitute(expression({
misc$expected = FALSE
misc$link = c(s= .link)
+ misc$earg = list(s= .earg )
misc$N = extra$N
- }), list( .link=link ))),
+ }), list( .link=link, .earg=earg ))),
loglikelihood=eval(substitute(
function(mu,y,w,residuals= FALSE,eta, extra=NULL) {
- ss = eta2theta(eta, .link)
+ ss = eta2theta(eta, .link, earg= .earg)
if(residuals) stop("loglikelihood residuals not implemented yet") else
sum(w * ((-ss) * log(y) - log(gharmonic(extra$N, ss ))))
- }, list( .link=link ))),
+ }, list( .link=link, .earg=earg ))),
vfamily=c("zipf"),
deriv=eval(substitute(expression({
- ss = eta2theta(eta, .link)
+ ss = eta2theta(eta, .link, earg= .earg)
fred1 = gharmonic(extra$N, ss)
fred2 = gharmonic(extra$N, ss, lognexp=1)
dl.dss = -log(y) + fred2 / fred1
- dss.deta = dtheta.deta(ss, .link)
- d2ss.deta2 = d2theta.deta2(ss, .link)
+ dss.deta = dtheta.deta(ss, .link, earg= .earg)
+ d2ss.deta2 = d2theta.deta2(ss, .link, earg= .earg)
w * dl.dss * dss.deta
- }), list( .link=link ))),
+ }), list( .link=link, .earg=earg ))),
weight=expression({
d2l.dss = gharmonic(extra$N, ss, lognexp=2) / fred1 - (fred2/fred1)^2
wz = w * (dss.deta^2 * d2l.dss - d2ss.deta2 * dl.dss)
@@ -991,6 +1021,7 @@ zipf = function(N=NULL, link="loge", init.s=NULL)
cauchy1 = function(scale.arg=1, llocation="identity",
+ elocation=list(),
ilocation=NULL, method.init=1)
{
if(mode(llocation) != "character" && mode(llocation) != "name")
@@ -999,15 +1030,19 @@ cauchy1 = function(scale.arg=1, llocation="identity",
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()
new("vglmff",
blurb=c("One parameter Cauchy distribution (location unknown, scale known)\n\n",
"Link: ",
- namesof("location", llocation), "\n\n",
- "Mean: doesn't exist\n",
- "Variance: doesn't exist"),
+ namesof("location", llocation, earg=elocation), "\n\n",
+ "Mean: NA\n",
+ "Variance: NA"),
initialize=eval(substitute(expression({
- predictors.names = namesof("location", .llocation, tag= FALSE)
+ predictors.names = namesof("location", .llocation,
+ earg=.elocation, 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 {
@@ -1026,42 +1061,49 @@ cauchy1 = function(scale.arg=1, llocation="identity",
}
loc.init = rep(loc.init, len=n)
if(.llocation == "loge") loc.init = abs(loc.init)+0.01
- etastart = theta2eta(loc.init, .llocation)
+ etastart = theta2eta(loc.init, .llocation, earg=.elocation)
}
}), list( .scale.arg=scale.arg, .ilocation=ilocation,
- .llocation=llocation, .method.init=method.init ))),
+ .elocation=elocation, .llocation=llocation,
+ .method.init=method.init ))),
inverse=function(eta, extra=NULL) {
rep(as.numeric(NA), length(eta))
},
last=eval(substitute(expression({
misc$link = c("location"= .llocation)
+ misc$earg = list(location= .elocation )
misc$scale.arg = .scale.arg
- }), list( .scale.arg=scale.arg, .llocation=llocation ))),
+ }), list( .scale.arg=scale.arg, .elocation=elocation,
+ .llocation=llocation ))),
loglikelihood=eval(substitute(
function(mu,y,w,residuals= FALSE,eta, extra=NULL) {
- location = eta2theta(eta, .llocation)
+ location = eta2theta(eta, .llocation, earg=.elocation)
temp = (y-location)/ .scale.arg
if(residuals) stop("loglikelihood residuals not implemented yet") else
sum(w * (-log(1+ temp^2) - log(pi) - log(.scale.arg )))
- }, list( .scale.arg=scale.arg, .llocation=llocation ))),
+ }, list( .scale.arg=scale.arg, .elocation=elocation,
+ .llocation=llocation ))),
vfamily=c("cauchy1"),
deriv=eval(substitute(expression({
- location = eta2theta(eta, .llocation)
+ location = eta2theta(eta, .llocation, earg=.elocation)
temp = (y-location)/.scale.arg
dl.dlocation = 2 * temp / ((1 + temp^2) * .scale.arg)
- dlocation.deta = dtheta.deta(location, .llocation)
+ dlocation.deta = dtheta.deta(location, .llocation, earg=.elocation)
w * dl.dlocation * dlocation.deta
- }), list( .scale.arg=scale.arg, .llocation=llocation ))),
+ }), list( .scale.arg=scale.arg, .elocation=elocation,
+ .llocation=llocation ))),
weight=eval(substitute(expression({
wz = w * dlocation.deta^2 / (.scale.arg^2 * 2)
wz
- }), list( .scale.arg=scale.arg, .llocation=llocation ))))
+ }), list( .scale.arg=scale.arg, .elocation=elocation,
+ .llocation=llocation ))))
}
logistic1 = function(llocation="identity",
+ elocation=list(),
scale.arg=1, method.init=1)
{
if(mode(llocation) != "character" && mode(llocation) != "name")
@@ -1071,44 +1113,52 @@ logistic1 = function(llocation="identity",
if(!is.Numeric(method.init, allow=1, integ=TRUE, posit=TRUE) ||
method.init > 2)
stop("'method.init' must be 1 or 2")
+ if(!is.list(elocation)) elocation = list()
new("vglmff",
blurb=c("One-parameter logistic distribution (location unknown, scale known)\n\n",
"Link: ",
- namesof("location", llocation), "\n", "\n",
+ namesof("location", llocation, earg=elocation), "\n\n",
"Mean: location", "\n",
"Variance: (pi*scale)^2 / 3"),
initialize=eval(substitute(expression({
- predictors.names = namesof("location", .llocation, tag= FALSE)
+ predictors.names = namesof("location", .llocation,
+ earg= .elocation, tag=FALSE)
if(!length(etastart)) {
location.init = if( .method.init == 1) y else median(rep(y, w))
location.init = rep(location.init, len=n)
if(.llocation == "loge") location.init = abs(location.init) + 0.001
- etastart = theta2eta(location.init, .llocation)
+ etastart = theta2eta(location.init, .llocation, earg= .elocation)
}
- }), list( .method.init=method.init, .llocation=llocation ))),
+ }), list( .method.init=method.init, .llocation=llocation,
+ .elocation=elocation ))),
inverse=eval(substitute(function(eta, extra=NULL) {
- eta2theta(eta, .llocation)
- }, list( .llocation=llocation ))),
+ eta2theta(eta, .llocation, earg= .elocation)
+ }, list( .llocation=llocation,
+ .elocation=elocation ))),
last=eval(substitute(expression({
misc$link = c(location= .llocation)
+ misc$earg = list(location= .elocation )
misc$scale.arg = .scale.arg
- }), list( .llocation=llocation, .scale.arg=scale.arg ))),
+ }), list( .llocation=llocation,
+ .elocation=elocation, .scale.arg=scale.arg ))),
loglikelihood=eval(substitute(
function(mu,y,w,residuals= FALSE,eta, extra=NULL) {
- location = eta2theta(eta, .llocation)
+ location = eta2theta(eta, .llocation, earg= .elocation)
zedd = (y-location)/.scale.arg
if(residuals) stop("loglikelihood residuals not implemented yet") else
sum(w * (-zedd - 2 * log(1+exp(-zedd)) - log(.scale.arg )))
- }, list( .llocation=llocation, .scale.arg=scale.arg ))),
+ }, list( .llocation=llocation,
+ .elocation=elocation, .scale.arg=scale.arg ))),
vfamily=c("logistic1"),
deriv=eval(substitute(expression({
- location = eta2theta(eta, .llocation)
+ location = eta2theta(eta, .llocation, earg= .elocation)
ezedd = exp(-(y-location)/.scale.arg)
dl.dlocation = (1 - ezedd) / ((1 + ezedd) * .scale.arg)
- dlocation.deta = dtheta.deta(location, .llocation)
+ dlocation.deta = dtheta.deta(location, .llocation, earg= .elocation)
w * dl.dlocation * dlocation.deta
- }), list( .llocation=llocation, .scale.arg=scale.arg ))),
+ }), list( .llocation=llocation,
+ .elocation=elocation, .scale.arg=scale.arg ))),
weight=eval(substitute(expression({
wz = w * dlocation.deta^2 / (.scale.arg^2 * 3)
wz
@@ -1118,7 +1168,7 @@ logistic1 = function(llocation="identity",
-erlang = function(shape.arg, link="loge", method.init=1)
+erlang = function(shape.arg, link="loge", earg=list(), method.init=1)
{
if(!is.Numeric(shape.arg, allow=1, integer=TRUE, positi=TRUE))
@@ -1129,10 +1179,11 @@ erlang = function(shape.arg, link="loge", method.init=1)
if(mode(link) != "character" && mode(link) != "name")
link = as.character(substitute(link))
+ if(!is.list(earg)) earg = list()
new("vglmff",
blurb=c("Erlang distribution\n\n",
- "Link: ", namesof("scale", link), "\n", "\n",
+ "Link: ", namesof("scale", link, earg=earg), "\n", "\n",
"Mean: shape * scale", "\n",
"Variance: shape * scale^2"),
initialize=eval(substitute(expression({
@@ -1141,7 +1192,7 @@ erlang = function(shape.arg, link="loge", method.init=1)
if(any(y < 0))
stop("all y values must be >= 0")
- predictors.names = namesof("scale", .link, tag= FALSE)
+ predictors.names = namesof("scale", .link, earg=.earg, tag=FALSE)
if(!length(etastart)) {
if(.method.init==1)
@@ -1150,41 +1201,43 @@ erlang = function(shape.arg, link="loge", method.init=1)
sc.init = median(y) / .shape.arg
sc.init = rep(sc.init, length=n)
}
- etastart = theta2eta(sc.init, .link)
+ etastart = theta2eta(sc.init, .link, earg=.earg)
}
- }), list( .link=link, .shape.arg=shape.arg, .method.init=method.init ))),
+ }), list( .link=link, .earg=earg,
+ .shape.arg=shape.arg, .method.init=method.init ))),
inverse=eval(substitute(function(eta, extra=NULL) {
- sc = eta2theta(eta, .link)
+ sc = eta2theta(eta, .link, earg=.earg)
.shape.arg * sc
- }, list( .link=link, .shape.arg=shape.arg ))),
+ }, list( .link=link, .earg=earg, .shape.arg=shape.arg ))),
last=eval(substitute(expression({
misc$link = c(scale= .link)
+ misc$earg = list(scale= .earg )
misc$shape.arg = .shape.arg
- }), list( .link=link, .shape.arg=shape.arg ))),
+ }), list( .link=link, .earg=earg, .shape.arg=shape.arg ))),
loglikelihood=eval(substitute(
function(mu,y,w,residuals= FALSE,eta, extra=NULL) {
- sc = eta2theta(eta, .link)
+ sc = eta2theta(eta, .link, earg=.earg)
if(residuals) stop("loglikelihood residuals not implemented yet") else
sum(w * ((.shape.arg - 1) * log(y) - y / sc - .shape.arg * log(sc) -
lgamma( .shape.arg )))
- }, list( .link=link, .shape.arg=shape.arg ))),
+ }, list( .link=link, .earg=earg, .shape.arg=shape.arg ))),
vfamily=c("erlang"),
deriv=eval(substitute(expression({
- sc = eta2theta(eta, .link)
+ sc = eta2theta(eta, .link, earg=.earg)
dl.dsc = (y / sc - .shape.arg) / sc
- dsc.deta = dtheta.deta(sc, .link)
+ dsc.deta = dtheta.deta(sc, .link, earg=.earg)
w * dl.dsc * dsc.deta
- }), list( .link=link, .shape.arg=shape.arg ))),
+ }), list( .link=link, .earg=earg, .shape.arg=shape.arg ))),
weight=eval(substitute(expression({
ed2l.dsc2 = .shape.arg / sc^2 # Use the expected info matrix
wz = w * dsc.deta^2 * ed2l.dsc2
wz
- }), list( .shape.arg=shape.arg ))))
+ }), list( .earg=earg, .shape.arg=shape.arg ))))
}
-borel.tanner = function(shape.arg, link="logit")
+borel.tanner = function(shape.arg, link="logit", earg=list())
{
if(!is.Numeric(shape.arg, allow=1, integ=TRUE))
@@ -1192,11 +1245,12 @@ borel.tanner = function(shape.arg, link="logit")
if(mode(link) != "character" && mode(link) != "name")
link = as.character(substitute(link))
+ if(!is.list(earg)) earg = list()
new("vglmff",
blurb=c("Borel-Tanner distribution\n\n",
"Link: ",
- namesof("a", link), "\n\n",
+ namesof("a", link, earg=earg), "\n\n",
"Mean: n/(1-a)",
"\n",
"Variance: n*a / (1-a)^3"),
@@ -1206,36 +1260,39 @@ borel.tanner = function(shape.arg, link="logit")
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")
- predictors.names = namesof("a", .link, tag= FALSE)
+ predictors.names = namesof("a", .link, earg=.earg, tag=FALSE)
if(!length(etastart)) {
a.init = .shape.arg / y
- etastart = theta2eta(a.init, .link)
+ etastart = theta2eta(a.init, .link, earg=.earg)
}
- }), list( .link=link, .shape.arg=shape.arg ))),
+ }), list( .link=link, .earg=earg, .shape.arg=shape.arg ))),
inverse=eval(substitute(function(eta, extra=NULL) {
- a = eta2theta(eta, .link)
+ a = eta2theta(eta, .link, earg=.earg)
.shape.arg / (1 - a)
- }, list( .link=link, .shape.arg=shape.arg ))),
+ }, list( .link=link, .earg=earg, .shape.arg=shape.arg ))),
last=eval(substitute(expression({
misc$link = c(a= .link)
+ misc$earg = list(a= .earg )
misc$shape.arg = .shape.arg
- }), list( .link=link, .shape.arg=shape.arg ))),
+ }), list( .link=link, .earg=earg, .shape.arg=shape.arg ))),
loglikelihood=eval(substitute(
function(mu,y,w,residuals= FALSE,eta, extra=NULL) {
- a = eta2theta(eta, .link)
+ 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, .shape.arg=shape.arg ))),
+ }, list( .link=link, .earg=earg, .shape.arg=shape.arg ))),
vfamily=c("borel.tanner"),
deriv=eval(substitute(expression({
- a = eta2theta(eta, .link)
+ a = eta2theta(eta, .link, earg=.earg)
dl.da = (y- .shape.arg)/a - y
- da.deta = dtheta.deta(a, .link)
+ da.deta = dtheta.deta(a, .link, earg=.earg)
w * dl.da * da.deta
- }), list( .link=link, .shape.arg=shape.arg ))),
+ }), list( .link=link, .earg=earg, .shape.arg=shape.arg ))),
weight=eval(substitute(expression({
ed2l.da2 = .shape.arg/(a*(1-a)) # Use the expected info matrix
wz = w * da.deta^2 * ed2l.da2
@@ -1267,22 +1324,23 @@ rsnorm = function(n, location=0, scale=1, shape=0) {
}
-skewnormal1 = function(lshape="identity", ishape=NULL)
+skewnormal1 = function(lshape="identity", earg = list(), ishape=NULL)
{
if(mode(lshape) != "character" && mode(lshape) != "name")
lshape = as.character(substitute(lshape))
+ if(!is.list(earg)) earg = list()
new("vglmff",
blurb=c("1-parameter Skew-normal distribution\n\n",
"Link: ",
- namesof("shape", lshape), "\n",
+ namesof("shape", lshape, earg=earg), "\n",
"Mean: shape * sqrt(2 / (pi * (1+shape^2 )))\n",
"Variance: 1-mu^2"),
initialize=eval(substitute(expression({
y = cbind(y)
if(ncol(y) != 1)
- stop("response must be a vector or a 1-column matrix")
- predictors.names = namesof("shape", .lshape, tag= FALSE)
+ stop("response must be a vector or a one-column matrix")
+ predictors.names = namesof("shape", .lshape, earg=.earg, tag=FALSE)
if(!length(etastart)) {
init.shape = if(length( .ishape)) rep( .ishape, len=n) else {
temp = y
@@ -1293,57 +1351,59 @@ skewnormal1 = function(lshape="identity", ishape=NULL)
}
etastart = matrix(init.shape, n, ncol(y))
}
- }), list( .lshape=lshape, .ishape=ishape ))),
+ }), list( .lshape=lshape, .earg=earg, .ishape=ishape ))),
inverse=eval(substitute(function(eta, extra=NULL) {
- alpha = eta2theta(eta, .lshape)
+ alpha = eta2theta(eta, .lshape, earg=.earg)
alpha * sqrt(2/(pi * (1+alpha^2 )))
- }, list( .lshape=lshape ))),
+ }, list( .earg=earg, .lshape=lshape ))),
last=eval(substitute(expression({
misc$link = c(shape= .lshape)
- }), list( .lshape=lshape ))),
+ misc$earg = list(shape= .earg )
+ }), list( .earg=earg, .lshape=lshape ))),
link=eval(substitute(function(mu, extra=NULL) {
alpha = mu / sqrt(2/pi - mu^2)
- theta2eta(alpha, .lshape)
- }, list( .lshape=lshape ))),
+ theta2eta(alpha, .lshape, earg=.earg)
+ }, list( .earg=earg, .lshape=lshape ))),
loglikelihood=eval(substitute(
function(mu, y, w, residuals = FALSE, eta, extra=NULL) {
- alpha = eta2theta(eta, .lshape)
+ alpha = eta2theta(eta, .lshape, earg=.earg)
if(residuals) stop("loglikelihood residuals not implemented yet") else
sum(w * (pnorm(y*alpha, log=TRUE )))
- }, list( .lshape=lshape ))),
+ }, list( .earg=earg, .lshape=lshape ))),
vfamily=c("skewnormal1"),
deriv=eval(substitute(expression({
- alpha = eta2theta(eta, .lshape)
+ alpha = eta2theta(eta, .lshape, earg=.earg)
zedd = y*alpha
tmp76 = pnorm(zedd)
tmp86 = dnorm(zedd)
dl.dshape = tmp86 * y / tmp76
- dshape.deta = dtheta.deta(alpha, .lshape)
+ dshape.deta = dtheta.deta(alpha, .lshape, earg=.earg)
w * dl.dshape * dshape.deta
- }), list( .lshape=lshape ))),
+ }), list( .earg=earg, .lshape=lshape ))),
weight=eval(substitute(expression({
- d2shape.deta2 = d2theta.deta2(alpha, .lshape) # 0 with identity link
+ 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
wz
- }), list( .lshape=lshape ))))
+ }), list( .earg=earg, .lshape=lshape ))))
}
-betaff = function(link="loge", i1=NULL, i2=NULL, trim=0.05,
- A=0, B=1, earg=list(), zero=NULL)
+betaff = function(link="loge", earg=list(),
+ i1=NULL, i2=NULL, trim=0.05,
+ A=0, B=1, zero=NULL)
{
if(mode(link) != "character" && mode(link) != "name")
link = as.character(substitute(link))
- if(!is.list(earg)) earg = list()
if(length(zero) && !is.Numeric(zero, integer=TRUE, posit=TRUE))
stop("bad input for argument \"zero\"")
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()
new("vglmff",
blurb=c("Two-parameter Beta distribution\n",
@@ -1364,8 +1424,10 @@ betaff = function(link="loge", i1=NULL, i2=NULL, trim=0.05,
initialize=eval(substitute(expression({
if(min(y) <= .A || max(y) >= .B)
stop("data not within (A, B)")
- predictors.names = c(namesof("shape1", .link, earg= .earg, short= TRUE),
- namesof("shape2", .link, earg= .earg, short= TRUE))
+ if(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 ),
@@ -1427,24 +1489,26 @@ betaff = function(link="loge", i1=NULL, i2=NULL, trim=0.05,
-beta4 = function(link="loge", i1=2.3, i2=2.4, iA=NULL, iB=NULL)
+beta4 = function(link="loge", earg=list(),
+ i1=2.3, i2=2.4, iA=NULL, iB=NULL)
{
if(mode(link) != "character" && mode(link) != "name")
link = as.character(substitute(link))
+ if(!is.list(earg)) earg = list()
new("vglmff",
blurb=c("Four-parameter Beta distribution\n",
"(y-A)^(shape1-1) * (B-y)^(shape2-1), A < y < B \n\n",
"Links: ",
- namesof("shape1", link), ", ",
- namesof("shape2", link), ", ",
+ namesof("shape1", link, earg=earg), ", ",
+ namesof("shape2", link, earg=earg), ", ",
" A, B"),
initialize=eval(substitute(expression({
if(!is.vector(y) || (is.matrix(y) && ncol(y) != 1))
- stop("y must be a vector or a 1-column matrix")
+ stop("y must be a vector or a one-column matrix")
if(length(.iA) && any(y < .iA))
stop("initial A value out of range")
@@ -1452,8 +1516,8 @@ beta4 = function(link="loge", i1=2.3, i2=2.4, iA=NULL, iB=NULL)
stop("initial B value out of range")
predictors.names = c(
- namesof("shape1", .link, short= TRUE),
- namesof("shape2", .link, short= TRUE), "A", "B")
+ namesof("shape1", .link, earg=.earg, short=TRUE),
+ namesof("shape2", .link, earg=.earg, short=TRUE), "A", "B")
my.range = diff(range(y))
if(!length(etastart)) {
etastart = cbind(shape1= rep(.i1, len=length(y)),
@@ -1461,20 +1525,22 @@ beta4 = function(link="loge", i1=2.3, i2=2.4, iA=NULL, iB=NULL)
A = if(length(.iA)) .iA else min(y)-my.range/70,
B = if(length(.iB)) .iB else max(y)+my.range/70)
}
- }), list( .i1=i1, .i2=i2, .iA=iA, .iB=iB, .link=link ))),
+ }), list( .i1=i1, .i2=i2, .iA=iA, .iB=iB, .link=link, .earg=earg ))),
inverse=eval(substitute(function(eta, extra=NULL) {
- shapes = eta2theta(eta[,1:2], .link)
+ shapes = eta2theta(eta[,1:2], .link, earg=.earg)
.A = eta[,3]
.B = eta[,4]
.A + (.B-.A) * shapes[,1] / (shapes[,1] + shapes[,2])
- }, list( .link=link ))),
+ }, list( .link=link, .earg=earg ))),
last=eval(substitute(expression({
misc$link = c(shape1 = .link, shape2 = .link,
A="identity", B="identity")
- }), list( .link=link ))),
+ misc$earg = list(shape1 = .earg, shape2 = .earg,
+ A=list(), B=list())
+ }), list( .link=link, .earg=earg ))),
loglikelihood=eval(substitute(
function(mu,y,w,residuals= FALSE,eta,extra=NULL) {
- shapes = eta2theta(eta[,1:2], .link)
+ shapes = eta2theta(eta[,1:2], .link, earg=.earg)
.A = eta[,3]
.B = eta[,4]
temp = if(is.R()) lbeta(shapes[,1], shapes[,2]) else
@@ -1483,13 +1549,13 @@ beta4 = function(link="loge", i1=2.3, i2=2.4, iA=NULL, iB=NULL)
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 ))),
+ }, list( .link=link, .earg=earg ))),
vfamily="beta4",
deriv=eval(substitute(expression({
- shapes = eta2theta(eta[,1:2], .link)
+ shapes = eta2theta(eta[,1:2], .link, earg=.earg)
.A = eta[,3]
.B = eta[,4]
- dshapes.deta = dtheta.deta(shapes, .link)
+ dshapes.deta = dtheta.deta(shapes, .link, earg=.earg)
rr1 = (.B - .A)
temp3 = (shapes[,1] + shapes[,2] - 1)
temp1 = temp3 / rr1
@@ -1498,7 +1564,7 @@ beta4 = function(link="loge", i1=2.3, i2=2.4, iA=NULL, iB=NULL)
dl.dA = -(shapes[,1]-1) / (y- .A) + temp1
dl.dB = (shapes[,2]-1) / (.B - y) - temp1
w * cbind(dl.dshapes * dshapes.deta, dl.dA, dl.dB)
- }), list( .link=link ))),
+ }), list( .link=link, .earg=earg ))),
weight=expression({
temp2 = trigamma(shapes[,1]+shapes[,2])
@@ -1569,13 +1635,14 @@ simple.exponential = function()
}
-exponential = function(link="loge", location=0, expected=TRUE, earg=NULL)
+exponential = function(link="loge", earg=list(), location=0, expected=TRUE)
{
if(!is.Numeric(location, allow=1))
stop("bad input for argument \"location\"")
if(mode(link) != "character" && mode(link) != "name")
link = as.character(substitute(link))
+ if(!is.list(earg)) earg = list()
new("vglmff",
blurb=c("Exponential distribution\n\n",
@@ -1586,10 +1653,12 @@ exponential = function(link="loge", location=0, expected=TRUE, earg=NULL)
if(location==0) "Exponential: mu^2" else
paste("(mu-", location, ")^2", sep="")),
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))
- predictors.names = namesof("rate", .link, tag= FALSE)
+ predictors.names = namesof("rate", .link, tag=FALSE)
mu = y + (y == extra$loc) / 8
if(!length(etastart))
etastart = theta2eta(1/(mu-extra$loc), .link, earg=.earg)
@@ -1600,7 +1669,7 @@ exponential = function(link="loge", location=0, expected=TRUE, earg=NULL)
last=eval(substitute(expression({
misc$location = extra$loc
misc$link = c(rate = .link)
- misc$earg = .earg
+ 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),
@@ -1636,37 +1705,42 @@ exponential = function(link="loge", location=0, expected=TRUE, earg=NULL)
-gamma1 = function(link="loge")
+gamma1 = function(link="loge", earg=list())
{
if(mode(link) != "character" && mode(link) != "name")
link = as.character(substitute(link))
+ if(!is.list(earg)) earg = list()
new("vglmff",
blurb=c("1-parameter Gamma distribution\n",
"Link: ",
- namesof("shape", link, tag= TRUE), "\n",
+ namesof("shape", link, earg=earg, tag= TRUE), "\n",
"Mean: mu (=shape)\n",
"Variance: mu (=shape)"),
initialize=eval(substitute(expression({
if(any(y <= 0))
stop("all responses must be positive")
M = if(is.matrix(y)) ncol(y) else 1
- predictors.names = if(M == 1) namesof("shape", .link, short=TRUE) else
- namesof(paste("shape", 1:M, sep=""), .link, short=TRUE)
+ temp.names = if(M == 1) "shape" else paste("shape", 1:M, sep="")
+ predictors.names = namesof(temp.names, .link, earg=.earg, short=TRUE)
if(!length(etastart))
- etastart = cbind(theta2eta(y+1/8, .link ))
- }), list( .link=link ))),
+ etastart = cbind(theta2eta(y+1/8, .link, earg=.earg ))
+ }), list( .link=link, .earg=earg ))),
inverse=eval(substitute(function(eta, extra=NULL)
- eta2theta(eta, .link)),
- list( .link=link)),
+ eta2theta(eta, .link, earg=.earg)),
+ list( .link=link, .earg=earg )),
last=eval(substitute(expression({
- misc$expected = TRUE
+ temp.names = if(M == 1) "shape" else paste("shape", 1:M, sep="")
misc$link = rep( .link, length=M)
- names(misc$link) = if(M == 1) "shape" else paste("shape", 1:M, sep="")
- }), list( .link=link ))),
+ names(misc$link) = temp.names
+ 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)
- theta2eta(mu, .link)),
- list( .link=link)),
+ theta2eta(mu, .link, earg=.earg)),
+ list( .link=link, .earg=earg )),
loglikelihood= function(mu, y, w, residuals = FALSE, eta, extra=NULL)
if(residuals) stop("loglikelihood residuals not implemented yet") else
sum(w * ((mu-1)*log(y) - y - lgamma(mu))),
@@ -1674,9 +1748,9 @@ gamma1 = function(link="loge")
deriv=eval(substitute(expression({
shape = mu
dl.dshape = log(y) - digamma(shape)
- dshape.deta = dtheta.deta(shape, .link)
+ dshape.deta = dtheta.deta(shape, .link, earg=.earg)
w * dl.dshape * dshape.deta
- }), list( .link=link ))),
+ }), list( .link=link, .earg=earg ))),
weight=expression({
d2l.dshape = -trigamma(shape)
wz = -(dshape.deta^2) * d2l.dshape
@@ -1686,6 +1760,7 @@ gamma1 = function(link="loge")
gamma2.ab = function(lrate="loge", lshape="loge",
+ erate=list(), eshape=list(),
irate=NULL, ishape=NULL, expected=TRUE, zero=2)
{
if(mode(lrate) != "character" && mode(lrate) != "name")
@@ -1700,12 +1775,14 @@ gamma2.ab = function(lrate="loge", lshape="loge",
stop("bad input for argument \"zero\"")
if(!is.logical(expected) || length(expected) != 1)
stop("bad input for argument \"expected\"")
+ if(!is.list(erate)) erate = list()
+ if(!is.list(eshape)) eshape = list()
new("vglmff",
blurb=c("2-parameter Gamma distribution\n",
"Links: ",
- namesof("rate", lrate), ", ",
- namesof("shape", lshape), "\n",
+ namesof("rate", lrate, earg=erate), ", ",
+ namesof("shape", lshape, earg=eshape), "\n",
"Mean: mu = shape/rate\n",
"Variance: (mu^2)/shape = shape/rate^2"),
constraints=eval(substitute(expression({
@@ -1714,11 +1791,11 @@ gamma2.ab = function(lrate="loge", lshape="loge",
initialize=eval(substitute(expression({
# Error check
if(ncol(cbind(y)) != 1)
- stop("response must be a vector or a 1-column matrix")
+ stop("response must be a vector or a one-column matrix")
if(any(y <= 0))
stop("all responses must be positive")
- predictors.names = c(namesof("rate", .lrate, tag= FALSE),
- namesof("shape", .lshape, tag= FALSE))
+ predictors.names = c(namesof("rate", .lrate, earg=.erate, tag=FALSE),
+ namesof("shape", .lshape, earg=.eshape, tag=FALSE))
if(!length(etastart)) {
mymu = y + 0.167 * (y == 0)
junk = lsfit(x, y, wt = w, intercept = FALSE)
@@ -1729,33 +1806,40 @@ gamma2.ab = function(lrate="loge", lshape="loge",
init.shape = rep(init.shape, len=n)
if( .lshape == "loglog")
init.shape[init.shape <= 1] = 3.1 #Hopefully value is big enough
- etastart = cbind(theta2eta(init.rate, .lrate),
- theta2eta(init.shape, .lshape))
+ etastart = cbind(theta2eta(init.rate, .lrate, earg=.erate),
+ theta2eta(init.shape, .lshape, earg=.eshape))
}
- }), list( .lrate=lrate, .lshape=lshape, .irate=irate, .ishape=ishape ))),
+ }), list( .lrate=lrate, .lshape=lshape, .irate=irate, .ishape=ishape,
+ .erate=erate, .eshape=eshape ))),
inverse=eval(substitute(function(eta, extra=NULL) {
- eta2theta(eta[,2], .lshape) / eta2theta(eta[,1], .lrate)
- }, list( .lrate=lrate, .lshape=lshape ))),
+ eta2theta(eta[,2], .lshape, earg=.eshape) / eta2theta(eta[,1], .lrate,
+ earg=.erate)
+ }, list( .lrate=lrate, .lshape=lshape,
+ .erate=erate, .eshape=eshape ))),
last=eval(substitute(expression({
misc$link = c(rate= .lrate, shape= .lshape)
- }), list( .lrate=lrate, .lshape=lshape ))),
+ misc$earg = list(rate= .erate, shape= .eshape)
+ }), list( .lrate=lrate, .lshape=lshape,
+ .erate=erate, .eshape=eshape ))),
loglikelihood=eval(substitute(
function(mu, y, w, residuals= FALSE,eta, extra=NULL) {
- rate = eta2theta(eta[,1], .lrate)
- shape = eta2theta(eta[,2], .lshape)
+ rate = eta2theta(eta[,1], .lrate, earg=.erate)
+ shape = eta2theta(eta[,2], .lshape, earg=.eshape)
if(residuals) stop("loglikelihood residuals not implemented yet") else
sum(w*(-rate * y + (shape-1)*log(y) + shape*log(rate) - lgamma(shape )))
- }, list( .lrate=lrate, .lshape=lshape ))),
+ }, list( .lrate=lrate, .lshape=lshape,
+ .erate=erate, .eshape=eshape ))),
vfamily=c("gamma2.ab"),
deriv=eval(substitute(expression({
- rate = eta2theta(eta[,1], .lrate)
- shape = eta2theta(eta[,2], .lshape)
+ rate = eta2theta(eta[,1], .lrate, earg=.erate)
+ shape = eta2theta(eta[,2], .lshape, earg=.eshape)
dl.drate = mu - y
dl.dshape = log(y*rate) - digamma(shape)
- dratedeta = dtheta.deta(rate, .lrate)
- dshape.deta = dtheta.deta(shape, .lshape)
+ dratedeta = dtheta.deta(rate, .lrate, earg=.erate)
+ dshape.deta = dtheta.deta(shape, .lshape, earg=.eshape)
w * cbind(dl.drate * dratedeta, dl.dshape * dshape.deta)
- }), list( .lrate=lrate, .lshape=lshape ))),
+ }), list( .lrate=lrate, .lshape=lshape,
+ .erate=erate, .eshape=eshape ))),
weight=eval(substitute(expression({
d2l.dshape2 = -trigamma(shape)
d2l.drate2 = -shape/(rate^2)
@@ -1765,18 +1849,21 @@ gamma2.ab = function(lrate="loge", lshape="loge",
wz[,iam(2,2,M)] = -d2l.dshape2 * dshape.deta^2
wz[,iam(1,2,M)] = -d2l.drateshape * dratedeta * dshape.deta
if(! .expected) {
- d2ratedeta2 = d2theta.deta2(rate, .lrate)
- d2shapedeta2 = d2theta.deta2(shape, .lshape)
+ d2ratedeta2 = d2theta.deta2(rate, .lrate, earg=.erate)
+ d2shapedeta2 = d2theta.deta2(shape, .lshape, earg=.eshape)
wz[,iam(1,1,M)] = wz[,iam(1,1,M)] - dl.drate * d2ratedeta2
wz[,iam(2,2,M)] = wz[,iam(2,2,M)] - dl.dshape * d2shapedeta2
}
w * wz
- }), list( .lrate=lrate, .lshape=lshape, .expected=expected ))))
+ }), list( .lrate=lrate, .lshape=lshape,
+ .erate=erate, .eshape=eshape, .expected=expected ))))
}
-gamma2 = function(lmu="loge", lshape="loge", method.init=1,
+gamma2 = function(lmu="loge", lshape="loge",
+ emu=list(), eshape=list(),
+ method.init=1,
deviance.arg=FALSE, ishape=NULL, zero=-2)
{
if(mode(lmu) != "character" && mode(lmu) != "name")
@@ -1790,14 +1877,16 @@ gamma2 = function(lmu="loge", lshape="loge", method.init=1,
if(!is.Numeric(method.init, allow=1, integ=TRUE, posit=TRUE) ||
method.init > 2)
stop("'method.init' must be 1 or 2")
+ if(!is.list(emu)) emu = list()
+ if(!is.list(eshape)) eshape = list()
ans =
new("vglmff",
blurb=c("2-parameter Gamma distribution",
" (McCullagh \& Nelder 1989 parameterization)\n",
"Links: ",
- namesof("mu", lmu), ", ",
- namesof("shape", lshape), "\n",
+ namesof("mu", lmu, earg=emu), ", ",
+ namesof("shape", lshape, earg=eshape), "\n",
"Mean: mu\n",
"Variance: (mu^2)/shape"),
constraints=eval(substitute(expression({
@@ -1817,10 +1906,11 @@ gamma2 = function(lmu="loge", lshape="loge", method.init=1,
y = as.matrix(y)
M = 2 * ncol(y)
NOS = ncoly = ncol(y) # Number of species
- predictors.names = c(namesof(if(NOS==1) "mu" else
- paste("mu", 1:NOS, sep=""), .lmu, tag= FALSE),
- namesof(if(NOS==1) "shape" else paste("shape", 1:NOS, sep=""),
- .lshape, tag= FALSE))
+ temp1.names = if(NOS==1) "mu" else paste("mu", 1:NOS, sep="")
+ temp2.names = if(NOS==1) "shape" else paste("shape", 1:NOS, sep="")
+ predictors.names =
+ c(namesof(temp1.names, .lmu, earg=.emu, tag=FALSE),
+ namesof(temp2.names, .lshape, earg=.eshape, tag=FALSE))
predictors.names = predictors.names[interleave.VGAM(M, M=2)]
@@ -1843,16 +1933,17 @@ gamma2 = function(lmu="loge", lshape="loge", method.init=1,
if( .lshape == "loglog") init.shape[init.shape[,spp] <=
1,spp] = 3.1 # Hopefully value is big enough
}
- etastart = cbind(theta2eta(mymu, .lmu),
- theta2eta(init.shape, .lshape))
+ etastart = cbind(theta2eta(mymu, .lmu, earg=.emu ),
+ theta2eta(init.shape, .lshape, earg=.eshape ))
etastart = etastart[,interleave.VGAM(M, M=2),drop=FALSE]
}
}), list( .lmu=lmu, .lshape=lshape, .ishape=ishape, .zero=zero,
+ .emu=emu, .eshape=eshape,
.method.init=method.init ))),
inverse=eval(substitute(function(eta, extra=NULL) {
NOS = ncol(eta) / 2
- eta2theta(eta[,2*(1:NOS)-1,drop=FALSE], .lmu)
- }, list( .lmu=lmu ))),
+ eta2theta(eta[,2*(1:NOS)-1,drop=FALSE], .lmu, earg=.emu )
+ }, list( .lmu=lmu, .emu=emu ))),
last=eval(substitute(expression({
if(is.R()) {
if(exists("CQO.FastAlgorithm", envir = VGAMenv))
@@ -1866,35 +1957,44 @@ gamma2 = function(lmu="loge", lshape="loge", method.init=1,
if(NOS==1) "shape" else paste("shape", 1:NOS, sep=""))
tmp34 = tmp34[interleave.VGAM(M, M=2)]
misc$link = tmp34 # Already named
+ misc$earg = vector("list", M)
+ names(misc$earg) = names(misc$link)
+ for(ii in 1:NOS) {
+ misc$earg[[2*ii-1]] = .emu
+ misc$earg[[2*ii ]] = .eshape
+ }
misc$expected = TRUE
- }), list( .lmu=lmu, .lshape=lshape ))),
+ }), list( .lmu=lmu, .lshape=lshape,
+ .emu=emu, .eshape=eshape ))),
link=eval(substitute(function(mu, extra=NULL) {
- temp = theta2eta(mu, .lmu)
+ temp = theta2eta(mu, .lmu, earg=.emu )
temp = cbind(temp, NA * temp)
temp[,interleave.VGAM(ncol(temp), M=2),drop=FALSE]
- }, list( .lmu=lmu ))),
+ }, list( .lmu=lmu, .emu=emu ))),
loglikelihood=eval(substitute(
function(mu, y, w, residuals= FALSE,eta, extra=NULL) {
NOS = ncol(eta) / 2
- mymu = mu # eta2theta(eta[,2*(1:NOS)-1], .lmu)
- shapemat = eta2theta(eta[,2*(1:NOS),drop=FALSE], .lshape)
+ mymu = mu # eta2theta(eta[,2*(1:NOS)-1], .lmu, earg=.emu )
+ shapemat = eta2theta(eta[,2*(1:NOS),drop=FALSE], .lshape, earg=.eshape )
if(residuals) stop("loglikelihood residuals not implemented yet") else
sum(w*((shapemat - 1) * log(y) + shapemat *
(log(shapemat) - y / mymu - log(mymu)) - lgamma(shapemat )))
- }, list( .lmu=lmu, .lshape=lshape ))),
+ }, list( .lmu=lmu, .lshape=lshape,
+ .emu=emu, .eshape=eshape ))),
vfamily=c("gamma2"),
deriv=eval(substitute(expression({
NOS = ncol(eta) / 2
- mymu = eta2theta(eta[,2*(1:NOS)-1], .lmu)
- shape = eta2theta(eta[,2*(1:NOS)], .lshape)
+ mymu = eta2theta(eta[,2*(1:NOS)-1], .lmu, earg=.emu )
+ shape = eta2theta(eta[,2*(1:NOS)], .lshape, earg=.eshape )
dl.dmu = shape * (y / mymu - 1) / mymu
dl.dshape = log(y) + log(shape) - log(mymu) + 1 - digamma(shape) -
y / mymu
- dmu.deta = dtheta.deta(mymu, .lmu)
- dshape.deta = dtheta.deta(shape, .lshape)
+ dmu.deta = dtheta.deta(mymu, .lmu, earg=.emu )
+ dshape.deta = dtheta.deta(shape, .lshape, earg=.eshape )
myderiv = w * cbind(dl.dmu * dmu.deta, dl.dshape * dshape.deta)
myderiv[,interleave.VGAM(M, M=2)]
- }), list( .lmu=lmu, .lshape=lshape ))),
+ }), list( .lmu=lmu, .lshape=lshape,
+ .emu=emu, .eshape=eshape ))),
weight=eval(substitute(expression({
ed2l.dmu2 = shape / (mymu^2)
ed2l.dshape2 = trigamma(shape) - 1 / shape
@@ -1914,7 +2014,7 @@ gamma2 = function(lmu="loge", lshape="loge", method.init=1,
temp300[temp300 > bigval] = bigval
temp300[temp300 < -bigval] = -bigval
} else stop("can only handle the 'loge' link")
- shape = eta2theta(temp300, .lshape)
+ shape = eta2theta(temp300, .lshape, earg=.eshape )
devi = -2 * (log(y/mu) - y/mu + 1)
if(residuals) {
warning("not 100% sure about these deviance residuals!")
@@ -1926,17 +2026,18 @@ gamma2 = function(lmu="loge", lshape="loge", method.init=1,
}
-geometric =function(link="logit", expected=TRUE)
+geometric =function(link="logit", earg=list(), expected=TRUE)
{
if(!is.logical(expected) || length(expected) != 1)
stop("bad input for argument \"expected\"")
if(mode(link) != "character" && mode(link) != "name")
link = as.character(substitute(link))
+ if(!is.list(earg)) earg = list()
new("vglmff",
blurb=c("Geometric distribution (P[Y=y] = prob*(1-prob)^y, y=0,1,2,...)\n",
"Link: ",
- namesof("prob", link), "\n",
+ namesof("prob", link, earg=earg), "\n",
"Mean: mu = (1-prob)/prob\n",
"Variance: mu*(1+mu) = (1-prob)/prob^2"),
initialize=eval(substitute(expression({
@@ -1944,42 +2045,43 @@ geometric =function(link="logit", expected=TRUE)
stop("response must be a vector or a 1-column matrix")
if(any(y < 0)) stop("all responses must be >= 0")
if(any(y!=round(y ))) stop("response should be integer-valued")
- predictors.names = c(namesof("prob", .link, tag= FALSE))
+ predictors.names = namesof("prob", .link, earg=.earg, tag=FALSE)
if(!length(etastart)) {
prob.init = 1 / (1 + y + 1/16)
- etastart = theta2eta(prob.init, .link)
+ etastart = theta2eta(prob.init, .link, earg= .earg)
}
- }), list( .link=link ))),
+ }), list( .link=link, .earg=earg ))),
inverse=eval(substitute(function(eta, extra=NULL) {
- prob = eta2theta(eta, .link)
+ prob = eta2theta(eta, .link, earg= .earg)
(1-prob)/prob
- }, list( .link=link ))),
+ }, list( .link=link, .earg=earg ))),
last=eval(substitute(expression({
misc$link = c(prob= .link)
+ misc$earg = list(prob= .earg )
misc$expected = .expected
- }), list( .link=link, .expected=expected ))),
+ }), list( .link=link, .earg=earg, .expected=expected ))),
loglikelihood=eval(substitute(
function(mu, y, w, residuals= FALSE,eta, extra=NULL) {
- prob = eta2theta(eta, .link)
+ prob = eta2theta(eta, .link, earg= .earg)
if(residuals) stop("loglikelihood residuals not implemented yet") else {
if(is.R()) sum(w * dgeom(x=y, prob=prob, log=TRUE)) else
sum(w*(y * log(1.0-prob) + log(prob )))
}
- }, list( .link=link ))),
+ }, list( .link=link, .earg=earg ))),
vfamily=c("geometric"),
deriv=eval(substitute(expression({
- prob = eta2theta(eta, .link)
+ prob = eta2theta(eta, .link, earg= .earg)
dl.dprob = -y/(1-prob) + 1/prob
- dprobdeta = dtheta.deta(prob, .link)
+ dprobdeta = dtheta.deta(prob, .link, earg= .earg)
w * cbind(dl.dprob * dprobdeta)
- }), list( .link=link, .expected=expected ))),
+ }), list( .link=link, .earg=earg, .expected=expected ))),
weight=eval(substitute(expression({
ed2l.dprob2 = if( .expected ) 1 / (prob^2 * (1-prob)) else
y / (1-prob)^2 + 1 / prob^2
wz = ed2l.dprob2 * dprobdeta^2
- if( !( .expected )) wz = wz - dl.dprob * d2theta.deta2(prob, .link)
+ if( !( .expected )) wz = wz - dl.dprob * d2theta.deta2(prob, .link, earg= .earg)
w * wz
- }), list( .link=link, .expected=expected ))))
+ }), list( .link=link, .earg=earg, .expected=expected ))))
}
@@ -2036,7 +2138,7 @@ rbetageom = function(n, shape1, shape2) {
tobit = function(Lower = 0, Upper = Inf, lmu="identity",
- lsd="loge", imethod=1, zero=2)
+ lsd="loge", emu=list(), esd=list(), imethod=1, zero=2)
{
if(mode(lmu) != "character" && mode(lmu) != "name")
lmu = as.character(substitute(lmu))
@@ -2049,18 +2151,20 @@ tobit = function(Lower = 0, Upper = Inf, lmu="identity",
stop("Lower and Upper must have length 1 and be numeric with Lower < Upper")
if(length(zero) && !is.Numeric(zero, integer=TRUE, posit=TRUE))
stop("bad input for argument \"zero\"")
+ if(!is.list(emu)) emu = list()
+ if(!is.list(esd)) esd = list()
new("vglmff",
blurb=c("Tobit model\n\n",
- "Links: ", namesof("mu", lmu, tag= TRUE), "; ",
- namesof("sd", lsd, tag= TRUE), "\n",
+ "Links: ", namesof("mu", lmu, earg=emu, tag= TRUE), "; ",
+ namesof("sd", lsd, earg=esd, tag= TRUE), "\n",
"Conditional variance: sd^2"),
constraints=eval(substitute(expression({
constraints = cm.zero.vgam(constraints, x, .zero, M)
}), list( .zero=zero ))),
initialize=eval(substitute(expression({
y = cbind(y)
- if(ncol(y)>1) stop("the response must be a vector or a 1-column matrix")
+ if(ncol(y)!=1)stop("the response must be a vector or a 1-column matrix")
extra$censoredL = (y <= .Lower)
extra$censoredU = (y >= .Upper)
if(min(y) < .Lower) {
@@ -2073,51 +2177,57 @@ tobit = function(Lower = 0, Upper = Inf, lmu="identity",
.Upper, "by", .Upper))
y[y > .Upper] = .Upper
}
- predictors.names = c(namesof("mu", .lmu, tag= FALSE),
- namesof("sd", .lsd, tag= FALSE))
+ predictors.names = c(namesof("mu", .lmu, earg=.emu, tag=FALSE),
+ namesof("sd", .lsd, earg=.esd, tag=FALSE))
if(!length(etastart)) {
anyc = extra$censoredL | extra$censoredU
i11 = if( .imethod == 1) anyc else FALSE # can be all data
junk=if(is.R()) lm.wfit(x=cbind(x[!i11,]),y=y[!i11],w=w[!i11]) else
lm.wfit(x=cbind(x[!i11,]), y=y[!i11], w=w[!i11],method="qr")
sd.y.est = sqrt( sum(w[!i11] * junk$resid^2) / junk$df.residual )
- etastart = cbind(mu=y, rep(theta2eta(sd.y.est, .lsd), length=n))
+ etastart = cbind(mu=y, rep(theta2eta(sd.y.est, .lsd, earg= .esd), length=n))
if(any(anyc)) etastart[anyc,1] = x[anyc,,drop=FALSE] %*% junk$coeff
}
- }), list( .Lower=Lower, .Upper=Upper, .lmu=lmu, .lsd=lsd, .imethod=imethod ))),
+ }), list( .Lower=Lower, .Upper=Upper, .lmu=lmu, .lsd=lsd,
+ .emu=emu, .esd=esd, .imethod=imethod ))),
inverse=eval(substitute( function(eta, extra=NULL) {
- eta2theta(eta[,1], .lmu)
- }, list( .lmu=lmu ))),
+ eta2theta(eta[,1], .lmu, earg= .emu)
+ }, list( .lmu=lmu, .emu=emu ))),
last=eval(substitute(expression({
misc$link = c("mu"= .lmu, "sd"= .lsd)
+ misc$earg = list("mu"= .emu, "sd"= .esd)
misc$expected = TRUE
misc$Lower = .Lower
misc$Upper = .Upper
- }), list( .lmu=lmu, .lsd=lsd, .Lower=Lower, .Upper=Upper ))),
+ }), list( .lmu=lmu, .lsd=lsd,
+ .emu=emu, .esd=esd,
+ .Lower=Lower, .Upper=Upper ))),
loglikelihood=eval(substitute(
function(mu,y,w,residuals= FALSE,eta, extra=NULL) {
cenL = extra$censoredL
cenU = extra$censoredU
cen0 = !cenL & !cenU # uncensored obsns
- mum = eta2theta(eta[,1], .lmu)
- sd = eta2theta(eta[,2], .lsd)
+ mum = eta2theta(eta[,1], .lmu, earg= .emu)
+ sd = eta2theta(eta[,2], .lsd, earg= .esd)
ell1 = -log(sd[cen0]) - 0.5 * ((y[cen0] - mum[cen0])/sd[cen0])^2
ell2 = log(1 - pnorm((mum[cenL] - .Lower)/sd[cenL]))
ell3 = log(1 - pnorm(( .Upper - mum[cenU])/sd[cenU]))
if(residuals) stop("loglikelihood residuals not implemented yet") else
sum(w[cen0] * ell1) + sum(w[cenL] * ell2) + sum(w[cenU] * ell3)
- }, list( .lmu=lmu, .lsd=lsd, .Lower=Lower, .Upper=Upper ))),
+ }, list( .lmu=lmu, .lsd=lsd,
+ .emu=emu, .esd=esd,
+ .Lower=Lower, .Upper=Upper ))),
vfamily=c("tobit"),
deriv=eval(substitute(expression({
cenL = extra$censoredL
cenU = extra$censoredU
cen0 = !cenL & !cenU # uncensored obsns
- mum = eta2theta(eta[,1], .lmu)
- sd = eta2theta(eta[,2], .lsd)
+ mum = eta2theta(eta[,1], .lmu, earg= .emu)
+ sd = eta2theta(eta[,2], .lsd, earg= .esd)
dl.dmu = (y-mum) / sd^2
dl.dsd = (((y-mum)/sd)^2 - 1) / sd
- dmu.deta = dtheta.deta(mum, .lmu)
- dsd.deta = dtheta.deta(sd, .lsd)
+ dmu.deta = dtheta.deta(mum, .lmu, earg= .emu)
+ dsd.deta = dtheta.deta(sd, .lsd, earg= .esd)
if(any(cenL)) {
mumL = mum - .Lower
temp21L = mumL[cenL] / sd[cenL]
@@ -2139,7 +2249,9 @@ tobit = function(Lower = 0, Upper = Inf, lmu="identity",
rm(fred21)
}
w * cbind(dl.dmu * dmu.deta, dl.dsd * dsd.deta)
- }), list( .lmu=lmu, .lsd=lsd, .Lower=Lower, .Upper=Upper ))),
+ }), list( .lmu=lmu, .lsd=lsd,
+ .emu=emu, .esd=esd,
+ .Lower=Lower, .Upper=Upper ))),
weight=eval(substitute(expression({
A1 = 1 - pnorm((mum - .Lower) / sd) # Lower
A3 = 1 - pnorm(( .Upper - mum) / sd) # Upper
@@ -2187,7 +2299,8 @@ tobit = function(Lower = 0, Upper = Inf, lmu="identity",
-normal1 = function(lmean="identity", lsd="loge", zero=NULL)
+normal1 = function(lmean="identity", lsd="loge",
+ emean=list(), esd=list(), zero=NULL)
{
if(mode(lmean) != "character" && mode(lmean) != "name")
@@ -2196,20 +2309,22 @@ normal1 = function(lmean="identity", lsd="loge", zero=NULL)
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()
new("vglmff",
blurb=c("Univariate Normal distribution\n\n",
"Links: ",
- namesof("mean", lmean, tag= TRUE), "; ",
- namesof("sd", lsd, tag= TRUE),
+ namesof("mean", lmean, earg=emean, tag= TRUE), "; ",
+ namesof("sd", lsd, earg=esd, tag= TRUE),
"\n",
"Variance: sd^2"),
constraints=eval(substitute(expression({
constraints = cm.zero.vgam(constraints, x, .zero, M)
}), list( .zero=zero ))),
initialize=eval(substitute(expression({
- predictors.names = c(namesof("mean", .lmean, tag= FALSE),
- namesof("sd", .lsd, tag= FALSE))
+ predictors.names = c(namesof("mean", .lmean, earg=.emean, tag=FALSE),
+ namesof("sd", .lsd, earg=.esd, tag=FALSE))
if(ncol(y <- cbind(y)) != 1)
stop("response must be a vector or a one-column matrix")
if(!length(etastart)) {
@@ -2217,36 +2332,37 @@ normal1 = function(lmean="identity", lsd="loge", zero=NULL)
lm.wfit(x=x, y=y, w=w, method="qr")
sd.y.est = sqrt( sum(w * junk$resid^2) / junk$df.residual )
mean.init = if( .lmean == "loge") pmax(1/1024, y) else y
- etastart = cbind(theta2eta(mean.init, .lmean),
- theta2eta(sd.y.est, .lsd))
+ etastart = cbind(theta2eta(mean.init, .lmean, earg= .emean),
+ theta2eta(sd.y.est, .lsd, earg= .esd))
}
- }), list( .lmean=lmean, .lsd=lsd ))),
+ }), list( .lmean=lmean, .lsd=lsd, .emean=emean, .esd=esd ))),
inverse=eval(substitute(function(eta, extra=NULL) {
- eta2theta(eta[,1], .lmean)
- }, list( .lmean=lmean ))),
+ eta2theta(eta[,1], .lmean, earg= .emean)
+ }, list( .lmean=lmean, .emean=emean, .esd=esd ))),
last=eval(substitute(expression({
misc$link = c("mu"= .lmean, "sd"= .lsd)
+ misc$earg = list("mu"= .emean, "sd"= .esd)
misc$expected = TRUE
- }), list( .lmean=lmean, .lsd=lsd ))),
+ }), list( .lmean=lmean, .lsd=lsd, .emean=emean, .esd=esd ))),
loglikelihood=eval(substitute(
function(mu,y,w,residuals= FALSE,eta, extra=NULL) {
- sd = eta2theta(eta[,2], .lsd)
+ sd = eta2theta(eta[,2], .lsd, earg= .esd)
if(residuals) stop("loglikelihood residuals not implemented yet") else {
if(is.R())
sum(w*dnorm(y, m=mu, sd=sd, log=TRUE)) else
sum(w * (-log(sd*sqrt(2*pi)) - 0.5 * ((y - mu)/sd)^2))
}
- }, list( .lsd=lsd ))),
+ }, list( .lsd=lsd, .emean=emean, .esd=esd ))),
vfamily=c("normal1"),
deriv=eval(substitute(expression({
- mymu = eta2theta(eta[,1], .lmean)
- sd = eta2theta(eta[,2], .lsd)
+ mymu = eta2theta(eta[,1], .lmean, earg= .emean)
+ sd = eta2theta(eta[,2], .lsd, earg= .esd)
dl.dmu = (y-mymu) / sd^2
dl.dsd = -1/sd + (y-mymu)^2 / sd^3
- dmu.deta = dtheta.deta(mymu, .lmean)
- dsd.deta = dtheta.deta(sd, .lsd)
+ dmu.deta = dtheta.deta(mymu, .lmean, earg= .emean)
+ dsd.deta = dtheta.deta(sd, .lsd, earg= .esd)
cbind(w * dl.dmu * dmu.deta, w * dl.dsd * dsd.deta)
- }), list( .lmean=lmean, .lsd=lsd ))),
+ }), 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
ed2l.dmu2 = -1 / sd^2
@@ -2261,7 +2377,8 @@ normal1 = function(lmean="identity", lsd="loge", zero=NULL)
-lognormal = function(lmeanlog="identity", lsdlog="loge", zero=NULL)
+lognormal = function(lmeanlog="identity", lsdlog="loge",
+ emeanlog=list(), esdlog=list(), zero=NULL)
{
if(mode(lmeanlog) != "character" && mode(lmeanlog) != "name")
lmeanlog = as.character(substitute(lmeanlog))
@@ -2269,11 +2386,13 @@ lognormal = function(lmeanlog="identity", lsdlog="loge", zero=NULL)
lsdlog = as.character(substitute(lsdlog))
if(length(zero) && (!is.Numeric(zero, integer=TRUE, posit=TRUE) ||
zero > 2)) stop("bad input for argument argument \"zero\"")
+ if(!is.list(emeanlog)) emeanlog = list()
+ if(!is.list(esdlog)) esdlog = list()
new("vglmff",
blurb=c("Two-parameter (univariate) lognormal distribution\n\n",
- "Links: ", namesof("meanlog", lmeanlog, tag= TRUE), ", ",
- namesof("sdlog", lsdlog, tag= TRUE)),
+ "Links: ", namesof("meanlog", lmeanlog, earg=emeanlog, tag= TRUE), ", ",
+ namesof("sdlog", lsdlog, earg=esdlog, tag= TRUE)),
constraints=eval(substitute(expression({
constraints = cm.zero.vgam(constraints, x, .zero, M)
}), list( .zero=zero ))),
@@ -2281,47 +2400,54 @@ lognormal = function(lmeanlog="identity", lsdlog="loge", zero=NULL)
if(ncol(cbind(y)) != 1)
stop("response must be a vector or a one-column matrix")
if(min(y) <= 0) stop("response must be positive")
- predictors.names = c(namesof("meanlog", .lmeanlog, tag= FALSE),
- namesof("sdlog", .lsdlog, tag= FALSE))
+ predictors.names = c(namesof("meanlog", .lmeanlog, earg=.emeanlog, tag=FALSE),
+ namesof("sdlog", .lsdlog, earg=.esdlog, tag=FALSE))
if(!length(etastart)) {
junk = if(is.R()) lm.wfit(x=x, y=log(y), w=w) else
lm.wfit(x=x, y=log(y), w=w, method="qr")
sdlog.y.est = sqrt( sum(w * junk$resid^2) / junk$df.residual )
- etastart = cbind(meanlog= rep(theta2eta(log(median(y)), .lmeanlog), length=n),
- sdlog= rep(theta2eta(sdlog.y.est, .lsdlog), length=n))
+ etastart = cbind(
+ meanlog= rep(theta2eta(log(median(y)), .lmeanlog, earg= .emeanlog), length=n),
+ sdlog= rep(theta2eta(sdlog.y.est, .lsdlog, earg= .esdlog), length=n))
}
- }), list( .lmeanlog = lmeanlog, .lsdlog=lsdlog ))),
+ }), list( .lmeanlog = lmeanlog, .lsdlog=lsdlog,
+ .emeanlog = emeanlog, .esdlog=esdlog ))),
inverse=eval(substitute(function(eta, extra=NULL) {
- mulog = eta2theta(eta[,1], .lmeanlog)
- sdlog = eta2theta(eta[,2], .lsdlog)
+ mulog = eta2theta(eta[,1], .lmeanlog, earg= .emeanlog)
+ sdlog = eta2theta(eta[,2], .lsdlog, earg= .esdlog)
exp(mulog + 0.5 * sdlog^2)
- }, list( .lmeanlog = lmeanlog, .lsdlog=lsdlog ))),
+ }, list( .lmeanlog = lmeanlog, .lsdlog=lsdlog,
+ .emeanlog = emeanlog, .esdlog=esdlog ))),
last=eval(substitute(expression({
misc$link = c("meanlog"= .lmeanlog, "sdlog"= .lsdlog)
+ misc$earg = list("meanlog"= .emeanlog, "sdlog"= .esdlog)
misc$expected = TRUE
- }), list( .lmeanlog = lmeanlog, .lsdlog=lsdlog ))),
+ }), list( .lmeanlog = lmeanlog, .lsdlog=lsdlog,
+ .emeanlog = emeanlog, .esdlog=esdlog ))),
loglikelihood=eval(substitute(
function(mu,y,w,residuals= FALSE,eta, extra=NULL) {
- mulog = eta2theta(eta[,1], .lmeanlog)
- sdlog = eta2theta(eta[,2], .lsdlog)
+ mulog = eta2theta(eta[,1], .lmeanlog, earg= .emeanlog)
+ sdlog = eta2theta(eta[,2], .lsdlog, earg= .esdlog)
if(residuals) stop("loglikelihood residuals not implemented yet") else {
if(is.R())
sum(w*dlnorm(y, meanlog=mulog, sdlog=sdlog, log=TRUE)) else
sum(w * (-log(y*sdlog*sqrt(2*pi)) - 0.5 * ((log(y) - mulog)/sdlog)^2))
}
- }, list( .lmeanlog = lmeanlog, .lsdlog=lsdlog ))),
+ }, list( .lmeanlog = lmeanlog, .lsdlog=lsdlog,
+ .emeanlog = emeanlog, .esdlog=esdlog ))),
vfamily=c("lognormal"),
deriv=eval(substitute(expression({
- mulog = eta2theta(eta[,1], .lmeanlog)
- sdlog = eta2theta(eta[,2], .lsdlog)
+ mulog = eta2theta(eta[,1], .lmeanlog, earg= .emeanlog)
+ sdlog = eta2theta(eta[,2], .lsdlog, earg= .esdlog)
dl.dmulog = (log(y)-mulog) / sdlog^2
dl.dsdlog = -1/sdlog + (log(y)-mulog)^2 / sdlog^3
dl.dlambda = (1 + (log(y)-mulog) / sdlog^2) / y
- dmulog.deta = dtheta.deta(mulog, .lmeanlog)
- dsdlog.deta = dtheta.deta(sdlog, .lsdlog)
+ dmulog.deta = dtheta.deta(mulog, .lmeanlog, earg= .emeanlog)
+ dsdlog.deta = dtheta.deta(sdlog, .lsdlog, earg= .esdlog)
w * cbind(dl.dmulog * dmulog.deta,
dl.dsdlog * dsdlog.deta)
- }), list( .lmeanlog = lmeanlog, .lsdlog=lsdlog ))),
+ }), list( .lmeanlog = lmeanlog, .lsdlog=lsdlog,
+ .emeanlog = emeanlog, .esdlog=esdlog ))),
weight=expression({
wz = matrix(as.numeric(NA), n, 2) # Diagonal!
ed2l.dmulog2 = 1 / sdlog^2
@@ -2353,6 +2479,7 @@ if(!is.R()) {
lognormal3 = function(lmeanlog="identity", lsdlog="loge",
+ emeanlog=list(), esdlog=list(),
powers.try = (-3):3,
delta=NULL, zero=NULL)
{
@@ -2365,21 +2492,24 @@ lognormal3 = function(lmeanlog="identity", lsdlog="loge",
if(length(zero) && (!is.Numeric(zero, integer=TRUE, posit=TRUE) ||
zero > 3))
stop("bad input for argument argument \"zero\"")
+ if(!is.list(emeanlog)) emeanlog = list()
+ if(!is.list(esdlog)) esdlog = list()
new("vglmff",
blurb=c("Three-parameter (univariate) lognormal distribution\n\n",
"Links: ",
- namesof("meanlog", lmeanlog, tag= TRUE),
- "; ", namesof("sdlog", lsdlog, tag= TRUE),
- "; ", namesof("lambda", "identity", tag= TRUE)),
+ namesof("meanlog", lmeanlog, earg=emeanlog, tag= TRUE),
+ "; ", namesof("sdlog", lsdlog, earg=esdlog, tag= TRUE),
+ "; ", namesof("lambda", "identity", earg=list(), tag= TRUE)),
constraints=eval(substitute(expression({
constraints = cm.zero.vgam(constraints, x, .zero, M)
}), list( .zero=zero ))),
initialize=eval(substitute(expression({
if(ncol(cbind(y)) != 1)
stop("response must be a vector or a one-column matrix")
- predictors.names = c(namesof("meanlog", .lmeanlog, tag= FALSE),
- namesof("sdlog", .lsdlog, tag= FALSE), "lambda")
+ predictors.names =
+ c(namesof("meanlog", .lmeanlog, earg=.emeanlog, tag=FALSE),
+ namesof("sdlog", .lsdlog, earg=.esdlog, tag=FALSE), "lambda")
if(!length(etastart)) {
miny = min(y)
@@ -2400,26 +2530,31 @@ lognormal3 = function(lmeanlog="identity", lsdlog="loge",
lm.wfit(x=x, y=log(y-lambda.init), w=w, method="qr")
sdlog.y.est = sqrt( sum(w * junk$resid^2) / junk$df.residual )
etastart = cbind(mu=log(median(y - lambda.init)),
- sdlog=rep(theta2eta(sdlog.y.est, .lsdlog), length=n),
- lambda = lambda.init)
+ sdlog=rep(theta2eta(sdlog.y.est, .lsdlog, earg= .esdlog), length=n),
+ lambda = lambda.init)
}
}), list( .lmeanlog=lmeanlog, .lsdlog=lsdlog,
+ .emeanlog = emeanlog, .esdlog=esdlog,
.delta = delta, .powers.try=powers.try ))),
inverse=eval(substitute(function(eta, extra=NULL) {
- mymu = eta2theta(eta[,1], .lmeanlog)
- sdlog = eta2theta(eta[,2], .lsdlog)
- lambda = eta2theta(eta[,3], "identity")
+ mymu = eta2theta(eta[,1], .lmeanlog, earg= .emeanlog)
+ sdlog = eta2theta(eta[,2], .lsdlog, earg= .esdlog)
+ lambda = eta2theta(eta[,3], "identity", earg=list())
lambda + exp(mymu + 0.5 * sdlog^2)
- }, list( .lmeanlog=lmeanlog, .lsdlog=lsdlog ))),
+ }, list( .lmeanlog=lmeanlog, .lsdlog=lsdlog,
+ .emeanlog = emeanlog, .esdlog=esdlog ))),
last=eval(substitute(expression({
misc$link = c("meanlog"= .lmeanlog,"sdlog"= .lsdlog,"lambda"="identity")
+ misc$earg = list("meanlog"= .emeanlog, "sdlog"= .esdlog,
+ "lambda"=list())
misc$expected = TRUE
- }), list( .lmeanlog=lmeanlog, .lsdlog=lsdlog ))),
+ }), list( .lmeanlog=lmeanlog, .lsdlog=lsdlog,
+ .emeanlog = emeanlog, .esdlog=esdlog ))),
loglikelihood=eval(substitute(
function(mu,y,w,residuals= FALSE,eta, extra=NULL) {
- mymu = eta2theta(eta[,1], .lmeanlog)
- sdlog = eta2theta(eta[,2], .lsdlog)
- lambda = eta2theta(eta[,3], "identity")
+ mymu = eta2theta(eta[,1], .lmeanlog, earg= .emeanlog)
+ sdlog = eta2theta(eta[,2], .lsdlog, earg= .esdlog)
+ lambda = eta2theta(eta[,3], "identity", earg=list())
if(any(y < lambda))
cat("warning: bad y\n")
if(residuals) stop("loglikelihood residuals not implemented yet") else {
@@ -2428,24 +2563,26 @@ lognormal3 = function(lmeanlog="identity", lsdlog="loge",
sum(w * (-log((y-lambda)*sdlog*sqrt(2*pi)) -
0.5 * ((log(y-lambda) - mymu)/sdlog)^2))
}
- }, list( .lmeanlog=lmeanlog, .lsdlog=lsdlog ))),
+ }, list( .lmeanlog=lmeanlog, .lsdlog=lsdlog,
+ .emeanlog = emeanlog, .esdlog=esdlog ))),
vfamily=c("lognormal3"),
deriv=eval(substitute(expression({
- mymu = eta2theta(eta[,1], .lmeanlog)
- sdlog = eta2theta(eta[,2], .lsdlog)
- lambda = eta2theta(eta[,3], "identity")
+ mymu = eta2theta(eta[,1], .lmeanlog, earg= .emeanlog)
+ sdlog = eta2theta(eta[,2], .lsdlog, earg= .esdlog)
+ lambda = eta2theta(eta[,3], "identity", earg=list())
if(any(y < lambda))
cat("warning: bad y\n")
dl.dmymu = (log(y-lambda)-mymu) / sdlog^2
dl.dsdlog = -1/sdlog + (log(y-lambda)-mymu)^2 / sdlog^3
dl.dlambda = (1 + (log(y-lambda)-mymu) / sdlog^2) / (y-lambda)
- dmymu.deta = dtheta.deta(mymu, .lmeanlog)
- dsdlog.deta = dtheta.deta(sdlog, .lsdlog)
- dlambda.deta = dtheta.deta(lambda, "identity")
+ dmymu.deta = dtheta.deta(mymu, .lmeanlog, earg= .emeanlog)
+ dsdlog.deta = dtheta.deta(sdlog, .lsdlog, earg= .esdlog)
+ dlambda.deta = dtheta.deta(lambda, "identity", earg=list())
w * cbind(dl.dmymu * dmymu.deta,
dl.dsdlog * dsdlog.deta,
dl.dlambda * dlambda.deta)
- }), list( .lmeanlog=lmeanlog, .lsdlog=lsdlog ))),
+ }), list( .lmeanlog=lmeanlog, .lsdlog=lsdlog,
+ .emeanlog = emeanlog, .esdlog=esdlog ))),
weight=expression({
wz = matrix(0, n, dimm(M))
ed2l.dmymu2 = 1 / sdlog^2
@@ -2472,6 +2609,7 @@ lognormal3 = function(lmeanlog="identity", lsdlog="loge",
interleave.VGAM = function(L, M) c(matrix(1:L, nrow=M, byrow=TRUE))
negbinomial = function(lmu = "loge", lk = "loge",
+ emu =list(), ek=list(),
ik = NULL, cutoff = 0.995, Maxiter=5000,
deviance.arg=FALSE, method.init=1,
zero = -2)
@@ -2491,13 +2629,15 @@ negbinomial = function(lmu = "loge", lk = "loge",
lmu = as.character(substitute(lmu))
if(mode(lk) != "character" && mode(lk) != "name")
lk = as.character(substitute(lk))
+ if(!is.list(emu)) emu = list()
+ if(!is.list(ek)) ek = list()
ans =
new("vglmff",
blurb=c("Negative-binomial distribution\n\n",
"Links: ",
- namesof("mu", lmu), ", ",
- namesof("k", lk), "\n",
+ namesof("mu", lmu, earg=emu), ", ",
+ namesof("k", lk, earg=ek), "\n",
"Mean: mu\n",
"Variance: mu * (1 + mu/k)"),
constraints=eval(substitute(expression({
@@ -2519,9 +2659,9 @@ negbinomial = function(lmu = "loge", lk = "loge",
M = 2 * ncol(y)
NOS = ncoly = ncol(y) # Number of species
predictors.names = c(namesof(if(NOS==1) "mu" else
- paste("mu", 1:NOS, sep=""), .lmu, tag= FALSE),
- namesof(if(NOS==1) "k" else paste("k", 1:NOS, sep=""), .lk,
- tag= FALSE))
+ paste("mu", 1:NOS, sep=""), .lmu, earg=.emu, tag=FALSE),
+ namesof(if(NOS==1) "k" else paste("k", 1:NOS, sep=""), .lk, earg=.ek,
+ tag=FALSE))
predictors.names = predictors.names[interleave.VGAM(M, M=2)]
if(!length(etastart)) {
if( .method.init >= 4) {
@@ -2559,16 +2699,17 @@ negbinomial = function(lmu = "loge", lk = "loge",
kay.init[,spp.] = try.this
}
}
- etastart = cbind(theta2eta(mu.init, .lmu),
- theta2eta(kay.init, .lk))
+ etastart = cbind(theta2eta(mu.init, .lmu, earg= .emu),
+ theta2eta(kay.init, .lk, earg= .ek))
etastart = etastart[,interleave.VGAM(M, M=2),drop=FALSE]
}
}), list( .lmu=lmu, .lk=lk, .k.init=ik, .zero=zero,
+ .emu=emu, .ek=ek,
.method.init=method.init ))),
inverse=eval(substitute(function(eta, extra=NULL) {
NOS = ncol(eta) / 2
- eta2theta(eta[,2*(1:NOS)-1,drop=FALSE], .lmu)
- }, list( .lmu=lmu ))),
+ eta2theta(eta[,2*(1:NOS)-1,drop=FALSE], .lmu, earg= .emu)
+ }, list( .lmu=lmu, .emu=emu, .ek=ek ))),
last=eval(substitute(expression({
if(is.R()) {
if(exists("CQO.FastAlgorithm", envir = VGAMenv))
@@ -2582,15 +2723,22 @@ negbinomial = function(lmu = "loge", lk = "loge",
if(NOS==1) "k" else paste("k", 1:NOS, sep=""))
temp0303 = temp0303[interleave.VGAM(M, M=2)]
misc$link = temp0303 # Already named
+ misc$earg = vector("list", M)
+ names(misc$earg) = names(misc$link)
+ for(ii in 1:NOS) {
+ misc$earg[[2*ii-1]] = .emu
+ misc$earg[[2*ii ]] = .ek
+ }
misc$cutoff = .cutoff
misc$method.init = .method.init
}), list( .lmu=lmu, .lk=lk, .cutoff=cutoff,
+ .emu=emu, .ek=ek,
.method.init=method.init ))),
link=eval(substitute(function(mu, extra=NULL) {
- temp = theta2eta(mu, .lmu)
+ temp = theta2eta(mu, .lmu, earg= .emu)
temp = cbind(temp, NA * temp)
temp[,interleave.VGAM(ncol(temp), M=2),drop=FALSE]
- }, list( .lmu=lmu ))),
+ }, list( .lmu=lmu, .emu=emu, .ek=ek ))),
loglikelihood=eval(substitute(
function(mu,y,w,residuals= FALSE,eta, extra=NULL) {
NOS = ncol(eta) / 2
@@ -2600,13 +2748,13 @@ negbinomial = function(lmu = "loge", lk = "loge",
temp300 = ifelse(temp300 > bigval, bigval, temp300)
temp300 = ifelse(temp300 < -bigval, -bigval, temp300)
}
- kmat = eta2theta(temp300, .lk)
+ kmat = eta2theta(temp300, .lk, earg= .ek)
ans =
sum(w * (y * log(mu/(mu+kmat)) + kmat*log(kmat/(mu+kmat)) +
lgamma(y+kmat) - lgamma(kmat) - lgamma(y+1 )))
if(residuals) stop("loglikelihood residuals not implemented yet") else
ans
- }, list( .lk=lk ))),
+ }, list( .lk=lk, .emu=emu, .ek=ek ))),
vfamily=c("negbinomial"),
deriv=eval(substitute(expression({
NOS = ncol(eta) / 2
@@ -2615,15 +2763,15 @@ negbinomial = function(lmu = "loge", lk = "loge",
bigval = 28
temp3 = ifelse(temp3 > bigval, bigval, temp3)
temp3 = ifelse(temp3 < -bigval, -bigval, temp3)
- kmat = eta2theta(temp3, .lk)
+ kmat = eta2theta(temp3, .lk, earg= .ek)
dl.dmu = y/mu - (y+kmat)/(kmat+mu)
dl.dk = digamma(y+kmat) - digamma(kmat) - (y+kmat)/(mu+kmat) + 1 +
log(kmat/(kmat+mu))
- dmu.deta = dtheta.deta(mu, .lmu)
- dk.deta = dtheta.deta(kmat, .lk)
+ dmu.deta = dtheta.deta(mu, .lmu, earg= .emu)
+ dk.deta = dtheta.deta(kmat, .lk, earg= .ek)
myderiv = w * cbind(dl.dmu * dmu.deta, dl.dk * dk.deta)
myderiv[,interleave.VGAM(M, M=2)]
- }), list( .lmu=lmu, .lk=lk ))),
+ }), list( .lmu=lmu, .lk=lk, .emu=emu, .ek=ek ))),
weight=eval(substitute(expression({
wz = matrix(as.numeric(NA), n, M) # wz is 'diagonal'
ed2l.dmu2 = 1/mu - 1/(mu+kmat)
@@ -2651,16 +2799,18 @@ negbinomial = function(lmu = "loge", lk = "loge",
temp300[temp300 > bigval] = bigval
temp300[temp300 < -bigval] = -bigval
} else stop("can only handle the 'loge' link")
- k = eta2theta(temp300, .lk)
+ k = eta2theta(temp300, .lk, earg= .ek)
devi = 2 * (y*log(ifelse(y<1, 1, y)/mu) + (y+k)*log((mu+k)/(k+y )))
if(residuals)
sign(y - mu) * sqrt(abs(devi) * w) else
sum(w * devi)
- }, list( .lk=lk )))
+ }, list( .lk=lk, .emu=emu, .ek=ek,)))
ans
}
+
negbin.ab = function(link.alpha ="loge", link.k ="loge",
+ ealpha=list(), ek=list(),
k.init=1,
zero=2,
cutoff=0.995)
@@ -2677,12 +2827,14 @@ negbin.ab = function(link.alpha ="loge", link.k ="loge",
link.alpha = as.character(substitute(link.alpha))
if(mode(link.k) != "character" && mode(link.k) != "name")
link.k = as.character(substitute(link.k))
+ if(!is.list(ealpha)) ealpha = list()
+ if(!is.list(ek)) ek = list()
new("vglmff",
blurb=c("Negative-binomial distribution\n\n",
"Links: ",
- namesof("alpha", link.alpha), ", ",
- namesof("k", link.k),
+ namesof("alpha", link.alpha, earg=ealpha), ", ",
+ namesof("k", link.k, earg=ek),
"\n",
"Mean: alpha * k",
"\n",
@@ -2691,40 +2843,50 @@ negbin.ab = function(link.alpha ="loge", link.k ="loge",
constraints = cm.zero.vgam(constraints, x, .zero, M)
}), list( .zero=zero ))),
initialize=eval(substitute(expression({
- predictors.names = c(namesof("alpha", .link.alpha, tag= FALSE),
- namesof("k", .link.k, tag= FALSE))
+ if(ncol(cbind(y)) != 1)
+ stop("response must be a vector or a one-column matrix")
+ predictors.names =
+ c(namesof("alpha", .link.alpha, earg=.ealpha, tag=FALSE),
+ namesof("k", .link.k, earg=.ek, tag=FALSE))
if(!length(etastart)) {
- etastart = cbind(theta2eta((y + 0.16667)/.k.init, .link.alpha),
- theta2eta( .k.init, .link.k))
+ etastart = cbind(
+ theta2eta((y + 1/8) / .k.init, .link.alpha, earg= .ealpha),
+ theta2eta( .k.init, .link.k, earg= .ek))
}
- }), list( .link.alpha=link.alpha, .link.k=link.k, .k.init=k.init ))),
+ }), list( .link.alpha=link.alpha, .link.k=link.k, .k.init=k.init,
+ .ealpha=ealpha, .ek=ek ))),
inverse=eval(substitute(function(eta, extra=NULL) {
- alpha = eta2theta(eta[,1], .link.alpha)
- k = eta2theta(eta[,2], .link.k)
+ alpha = eta2theta(eta[,1], .link.alpha, earg= .ealpha)
+ k = eta2theta(eta[,2], .link.k, earg= .ek)
alpha * k
- }, list( .link.alpha=link.alpha, .link.k=link.k ))),
+ }, list( .link.alpha=link.alpha, .link.k=link.k,
+ .ealpha=ealpha, .ek=ek ))),
last=eval(substitute(expression({
misc$link = c(alpha= .link.alpha, k= .link.k)
- }), list( .link.alpha=link.alpha, .link.k=link.k ))),
+ misc$earg = list(alpha= .ealpha, k= .ek )
+ }), list( .link.alpha=link.alpha, .link.k=link.k,
+ .ealpha=ealpha, .ek=ek ))),
loglikelihood=eval(substitute(
function(mu,y,w,residuals= FALSE,eta, extra=NULL) {
- alpha = eta2theta(eta[,1], .link.alpha)
- k = eta2theta(eta[,2], .link.k)
+ 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) -
lgamma(k) - lgamma(y+1 )))
- }, list( .link.alpha=link.alpha, .link.k=link.k ))),
+ }, list( .link.alpha=link.alpha, .link.k=link.k,
+ .ealpha=ealpha, .ek=ek ))),
vfamily=c("negbin.ab"),
deriv=eval(substitute(expression({
- alpha = eta2theta(eta[,1], .link.alpha)
- k = eta2theta(eta[,2], .link.k)
+ alpha = eta2theta(eta[,1], .link.alpha, earg= .ealpha)
+ k = eta2theta(eta[,2], .link.k, earg= .ek)
dl.dalpha = (y/alpha - k)/(1+alpha)
dl.dk = digamma(y+k) - digamma(k) - log(1+alpha)
- dalpha.deta = dtheta.deta(alpha, .link.alpha)
- dk.deta = dtheta.deta(k, .link.k)
+ dalpha.deta = dtheta.deta(alpha, .link.alpha, earg= .ealpha)
+ dk.deta = dtheta.deta(k, .link.k, earg= .ek)
cbind(w * dl.dalpha * dalpha.deta, w * dl.dk * dk.deta)
- }), list( .link.alpha=link.alpha, .link.k=link.k ))),
+ }), list( .link.alpha=link.alpha, .link.k=link.k,
+ .ealpha=ealpha, .ek=ek ))),
weight=eval(substitute(expression({
wz = matrix(as.numeric(NA), n, dimm(M)) # 3==dimm(M)
ed2l.dalpha2 = k/(alpha*(1+alpha))
@@ -2746,7 +2908,8 @@ negbin.ab = function(link.alpha ="loge", link.k ="loge",
wz[,iam(1,2,M)] = dk.deta * dalpha.deta * ed2l.dalphak
w * wz
- }), list( .cutoff=cutoff ))))
+ }), list( .cutoff=cutoff,
+ .ealpha=ealpha, .ek=ek ))))
}
@@ -2769,7 +2932,11 @@ nbmud = function(lmu = c("loge","identity","reciprocal"),
}
+
+
+if(FALSE)
neg.binomial = function(link.p="logit", link.k="loge",
+ ep=list(), ek=list(),
zero=2,
ik=NULL,
cutoff=0.995)
@@ -2786,26 +2953,31 @@ neg.binomial = function(link.p="logit", link.k="loge",
link.p = "logc"
if(mode(link.k) != "character" && mode(link.k) != "name")
link.k = as.character(substitute(link.k))
+ if(!is.list(ep)) ep = list()
+ if(!is.list(ek)) ek = list()
new("vglmff",
blurb=c("Negative-binomial distribution\n\n",
"Links: ",
- namesof("p", link.p), ", ",
- namesof("k", link.k), "; mu=k*(1-p)/p",
+ namesof("p", link.p, earg=ep), ", ",
+ namesof("k", link.k, earg=ek), "; mu=k*(1-p)/p",
"\n",
"Variance: mu(1 + mu/k)"),
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")
y = as.numeric(y)
if(any(y < 0))
stop("response must be non-negative")
if(max(abs(y - round(y )))>0.00001)
stop("response must be integer-valued")
- predictors.names = c(namesof("p", .link.p, tag= FALSE),
- namesof("k", .link.k, tag= FALSE))
+ predictors.names =
+ c(namesof("p", .link.p, earg=.ep, tag=FALSE),
+ namesof("k", .link.k, earg=.ek, tag=FALSE))
@@ -2833,36 +3005,42 @@ neg.binomial = function(link.p="logit", link.k="loge",
if(!length(etastart)) {
prob = k / (k + mu)
- etastart = cbind(theta2eta(prob, .link.p),
- theta2eta(k, .link.k))
+ etastart = cbind(theta2eta(prob, .link.p, earg= .ep),
+ theta2eta(k, .link.k, earg= .ek))
}
- }), list( .link.p=link.p, .link.k=link.k, .ik=ik ))),
+ }), list( .link.p=link.p, .link.k=link.k, .ik=ik,
+ .ep=ep, .ek=ek ))),
inverse=eval(substitute(function(eta, extra=NULL) {
- prob = eta2theta(eta[,1], .link.p)
- k = eta2theta(eta[,2], .link.k)
+ prob = eta2theta(eta[,1], .link.p, earg= .ep)
+ k = eta2theta(eta[,2], .link.k, earg= .ek)
k * (1 - prob) / prob
- }, list( .link.p=link.p, .link.k=link.k ))),
+ }, list( .link.p=link.p, .link.k=link.k,
+ .ep=ep, .ek=ek ))),
last=eval(substitute(expression({
- misc$link = c(p= .link.p, k= .link.k)
- }), list( .link.p=link.p, .link.k=link.k ))),
+ misc$link = c(p= .link.p, k= .link.k )
+ misc$earg = list(p= .ep, k= .ek )
+ }), list( .link.p=link.p, .link.k=link.k,
+ .ep=ep, .ek=ek ))),
loglikelihood=eval(substitute(
function(mu,y,w,residuals= FALSE,eta, extra=NULL) {
- prob = eta2theta(eta[,1], .link.p)
- k = eta2theta(eta[,2], .link.k)
+ prob = eta2theta(eta[,1], .link.p, earg= .ep)
+ k = eta2theta(eta[,2], .link.k, earg= .ek)
if(residuals) stop("loglikelihood residuals not implemented yet") else
sum(w * (y * log(1-prob) + k * log(prob) + lgamma(y+k) -
lgamma(k) - lgamma(y+1 )))
- }, list( .link.p=link.p, .link.k=link.k ))),
+ }, list( .link.p=link.p, .link.k=link.k,
+ .ep=ep, .ek=ek ))),
vfamily=c("neg.binomial"),
deriv=eval(substitute(expression({
- prob = eta2theta(eta[,1], .link.p)
- k = eta2theta(eta[,2], .link.k)
+ prob = eta2theta(eta[,1], .link.p, earg= .ep)
+ k = eta2theta(eta[,2], .link.k, earg= .ek)
dl.dp = k/prob - y/(1-prob)
dl.dk = log(prob) + digamma(y+k) - digamma(k)
- dp.deta = dtheta.deta(prob, .link.p)
- dk.deta = dtheta.deta(k, .link.k)
+ dp.deta = dtheta.deta(prob, .link.p, earg= .ep)
+ dk.deta = dtheta.deta(k, .link.k, earg= .ek)
w * cbind(dl.dp * dp.deta, dl.dk * dk.deta)
- }), list( .link.p=link.p, .link.k=link.k ))),
+ }), list( .link.p=link.p, .link.k=link.k,
+ .ep=ep, .ek=ek ))),
weight=eval(substitute(expression({
wz = matrix(as.numeric(NA), n, dimm(M)) # 3==dimm(M)
d2l.dpk = 1/prob
@@ -2886,28 +3064,28 @@ neg.binomial = function(link.p="logit", link.k="loge",
wz[,iam(2,2,M)] = dk.deta^2 * ed2l.dk2
wz = -w * wz
wz
- }), list( .cutoff=cutoff ))))
+ }), list( .cutoff=cutoff,
+ .ep=ep, .ek=ek ))))
}
-
-
-
-neg.binomial.k = function(k, link="logit", expected=TRUE, ...)
+if(FALSE)
+neg.binomial.k = function(k, link="logit", earg=list(), expected=TRUE, ...)
{
if(!is.Numeric(k, allow=1, posit=TRUE))
stop("bad input for argument argument \"k\"")
if(mode(link) != "character" && mode(link) != "name")
link = as.character(substitute(link))
+ if(!is.list(earg)) earg = list()
new("vglmff",
blurb=c("Negative-binomial distribution with k known and p unknown\n",
"(k=", k, ") ",
if(k==1) "Geometric\n\n" else "\n\n",
"Links: ",
- namesof("p", link), "; p=",k,"/(",k,"+mu)",
+ namesof("p", link, earg=earg), "; p=",k,"/(",k,"+mu)",
"\n",
"Variance: ",
if(k==1) "Geometric: mu(1+mu)" else
@@ -2923,45 +3101,45 @@ neg.binomial.k = function(k, link="logit", expected=TRUE, ...)
if(residuals)
sign(y - mu) * sqrt(abs(devi) * w) else
sum(w * devi)
- }, list( .link=link, .k=k ))),
+ }, list( .link=link, .earg=earg, .k=k ))),
initialize=eval(substitute(expression({
- predictors.names = namesof("p", .link, tag= FALSE)
+ predictors.names = namesof("p", .link, earg=.ep, tag=FALSE)
mu = y + 0.167 * (y == 0)
if(!length(etastart)) {
prob = .k / ( .k + mu)
- etastart = theta2eta(prob, .link)
+ etastart = theta2eta(prob, .link, earg= .earg)
}
- }), list( .link=link, .k=k ))),
+ }), list( .link=link, .earg=earg, .k=k ))),
inverse=eval(substitute(function(eta, extra=NULL) {
- prob = eta2theta(eta, .link)
+ prob = eta2theta(eta, .link, earg= .earg)
.k * (1 - prob) / prob
- }, list( .link=link, .k=k ))),
+ }, list( .link=link, .earg=earg, .k=k ))),
last=eval(substitute(expression({
misc$link = c(p = .link)
misc$k = .k
- }), list( .link=link, .k=k ))),
+ }), list( .link=link, .earg=earg, .k=k ))),
loglikelihood=eval(substitute(
function(mu,y,w,residuals= FALSE,eta, extra=NULL) {
- prob = eta2theta(eta, .link)
+ prob = eta2theta(eta, .link, earg= .earg)
if(residuals) stop("loglikelihood residuals not implemented yet") else
sum(w * (y * log(1-prob) + .k * log(prob) + lgamma(y+ .k) -
lgamma( .k ) - lgamma(y+1 )))
- }, list( .link=link, .k=k ))),
+ }, list( .link=link, .earg=earg, .k=k ))),
vfamily=c("neg.binomial.k"),
deriv=eval(substitute(expression({
prob = .k / ( .k + mu)
- dp.deta = dtheta.deta(prob, .link)
+ dp.deta = dtheta.deta(prob, .link, earg= .earg)
w * ( .k/prob - y/(1-prob)) * dp.deta
- }), list( .link=link, .k=k ))),
+ }), list( .link=link, .earg=earg, .k=k ))),
weight=eval(substitute(expression({
wz = dp.deta^2 * (y/(1 - prob)^2 + .k/prob^2)
if(! .expected) {
- d2pdeta2 = d2theta.deta2(prob, .link)
+ d2pdeta2 = d2theta.deta2(prob, .link, earg= .earg)
wz = wz - d2pdeta2 * ( .k/prob - y/(1-prob))
}
w * wz
- }), list( .link=link, .k=k, .expected=expected ))))
+ }), list( .link=link, .earg=earg, .k=k, .expected=expected ))))
}
@@ -2983,6 +3161,8 @@ simple.poisson = function()
2 * sum(w * devi)
},
initialize=expression({
+ if(ncol(cbind(y)) != 1)
+ stop("response must be a vector or a one-column matrix")
predictors.names = "log(lambda)"
mu = y + 0.167 * (y == 0)
if(!length(etastart))
@@ -2992,6 +3172,7 @@ simple.poisson = function()
exp(eta),
last=expression({
misc$link = c(lambda = "loge")
+ misc$earg = list(lambda = list())
}),
link=function(mu, extra=NULL)
log(mu),
@@ -2999,7 +3180,7 @@ simple.poisson = function()
deriv=expression({
lambda = mu
dl.dlambda = -1 + y/lambda
- dlambda.deta = dtheta.deta(theta=lambda, link="loge")
+ dlambda.deta = dtheta.deta(theta=lambda, link="loge", earg= list())
w * dl.dlambda * dlambda.deta
}),
weight=expression({
@@ -3010,112 +3191,122 @@ simple.poisson = function()
-studentt = function(link.df="loglog")
+studentt = function(link.df="loglog", earg=list())
{
if(mode(link.df) != "character" && mode(link.df) != "name")
link.df = as.character(substitute(link.df))
+ if(!is.list(earg)) earg = list()
new("vglmff",
blurb=c("Student t-distribution\n\n",
"Link: ",
- namesof("df", link.df),
+ namesof("df", link.df, earg=earg),
"\n",
"Variance: df/(df-2) if df > 2\n"),
initialize=eval(substitute(expression({
- predictors.names = namesof("df", .link.df, tag= FALSE)
+ if(ncol(cbind(y)) != 1)
+ stop("response must be a vector or a one-column matrix")
+ predictors.names = namesof("df", .link.df, earg=.earg, tag=FALSE)
if(!length(etastart)) {
init.df = (2*var(y)/(var(y)-1))
if(is.na(init.df) || init.df<1)
init.df = 4
- etastart = rep(theta2eta(init.df, .link.df), len=length(y))
+ etastart = rep(theta2eta(init.df, .link.df, earg= .earg),
+ len=length(y))
}
- }), list( .link.df=link.df ))),
+ }), list( .link.df=link.df, .earg=earg ))),
inverse=eval(substitute(function(eta, extra=NULL) {
- df = eta2theta(eta, .link.df)
+ df = eta2theta(eta, .link.df, earg= .earg)
ifelse(df > 1, 0, NA)
- }, list( .link.df=link.df ))),
+ }, list( .link.df=link.df, .earg=earg ))),
last=eval(substitute(expression({
- misc$link = c(df = .plink)
- }), list( .plink=link.df ))),
+ 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)
- }, list( .plink=link.df ))),
+ theta2eta(alpha, .plink, earg= .earg)
+ }, list( .plink=link.df, .earg=earg ))),
loglikelihood=eval(substitute(function(mu, y, w, residuals = FALSE, eta,
extra=NULL) {
- df = eta2theta(eta, .link.df)
+ 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)*log(1+temp1)/2 +
lgamma((df+1)/2) - lgamma(df/2 )))
}
- }, list( .link.df=link.df ))),
+ }, list( .link.df=link.df, .earg=earg ))),
vfamily=c("studentt"),
deriv=eval(substitute(expression({
- df = eta2theta(eta, .link.df)
+ df = eta2theta(eta, .link.df, earg= .earg)
temp = 1/df
temp1 = y^2 * temp
dl.ddf = 0.5*(-temp -log(1+temp1) +(df+1)*y^2/(df^2 * (1+temp1)) +
digamma((df+1)/2)-digamma(df/2))
- ddf.deta = dtheta.deta(theta=df, .link.df)
+ ddf.deta = dtheta.deta(theta=df, .link.df, earg= .earg)
w * dl.ddf * ddf.deta
- }), list( .link.df=link.df ))),
+ }), list( .link.df=link.df, .earg=earg ))),
weight=eval(substitute(expression({
temp2 = (df+1)/2
- d2df.deta2 = d2theta.deta2(theta=df, .link.df)
+ 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 ))))
+ }), list( .link.df=link.df, .earg=earg ))))
}
-chisq = function(link = "loge")
+chisq = function(link = "loge", earg=list())
{
if(mode(link) != "character" && mode(link) != "name")
link = as.character(substitute(link))
+ if(!is.list(earg)) earg = list()
new("vglmff",
blurb=c("Chi-squared distribution\n\n",
"Link: ",
- namesof("df", link)),
+ namesof("df", link, earg=earg)),
inverse =eval(substitute(function(eta,extra=NULL) {
- eta2theta(eta, .link)
- }, list( .link = link ))),
+ eta2theta(eta, .link, earg= .earg)
+ }, list( .link = link, .earg=earg ))),
initialize =eval(substitute(expression({
- predictors.names = namesof("df", .link, tag = FALSE)
+ if(ncol(cbind(y)) != 1)
+ stop("response must be a vector or a one-column matrix")
+ predictors.names = namesof("df", .link, earg=.earg, tag = FALSE)
mu = y + 0.167 * (y == 0)
- }), list( .link = link ))),
+ }), list( .link = link, .earg=earg ))),
last =eval(substitute(expression({
misc$link = c(df = .link)
- }), list( .link = link ))),
+ misc$earg = list(df = .earg )
+ }), list( .link = link, .earg=earg ))),
link=eval(substitute(function(mu, extra = NULL) {
- theta2eta(mu, .link)
- }, list( .link = link ))),
- loglikelihood =eval(substitute(function(mu,y,w,residuals= FALSE,eta,extra=NULL) {
- df = eta2theta(eta, .link)
+ theta2eta(mu, .link, earg= .earg)
+ }, list( .link = link, .earg=earg ))),
+ loglikelihood =eval(substitute(
+ function(mu,y,w,residuals= FALSE,eta,extra=NULL) {
+ df = eta2theta(eta, .link, earg= .earg)
if(residuals) stop("loglikelihood residuals not implemented yet") else
sum(w * (df*log(0.5)/2 + (df/2 - 1)*log(y) - y/2 -
lgamma(df/2 )))
- }, list( .link = link ))),
+ }, list( .link = link, .earg=earg ))),
vfamily="chisq",
deriv=eval(substitute(expression({
- df = eta2theta(eta, .link)
+ df = eta2theta(eta, .link, earg= .earg)
dl.dv = (log(y/2) - digamma(df/2)) / 2
- dv.deta = dtheta.deta(df, .link)
+ dv.deta = dtheta.deta(df, .link, earg= .earg)
w * dl.dv * dv.deta
- }), list( .link = link ))),
+ }), list( .link = link, .earg=earg ))),
weight =eval(substitute(expression({
ed2l.dv2 = -trigamma(df/2) / 4
wz = -ed2l.dv2 * dv.deta^2
wz * w
- }), list( .link = link ))))
+ }), list( .link = link, .earg=earg ))))
}
@@ -3124,13 +3315,16 @@ chisq = function(link = "loge")
-simplex = function(lmu="logit", lsigma="loge", imu=NULL, isigma=NULL)
+simplex = function(lmu="logit", lsigma="loge",
+ emu=list(), esigma=list(), imu=NULL, isigma=NULL)
{
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(!is.list(emu)) emu = list()
+ if(!is.list(esigma)) esigma = list()
new("vglmff",
blurb=c("Univariate Simplex distribution \n",
@@ -3138,8 +3332,8 @@ simplex = function(lmu="logit", lsigma="loge", imu=NULL, isigma=NULL)
" exp[-0.5*(y-mu)^2 / (y*(1-y)*mu^2*(1-mu)^2)/sigma^2], ",
" 0 < y < 1,\n",
"Links: ",
- namesof("mu", lmu), ", ",
- namesof("sigma", lsigma), "\n\n",
+ namesof("mu", lmu, earg=emu), ", ",
+ namesof("sigma", lsigma, earg=esigma), "\n\n",
"Mean: mu\n",
"Variance: sigma^2"),
initialize=eval(substitute(expression({
@@ -3147,33 +3341,38 @@ simplex = function(lmu="logit", lsigma="loge", imu=NULL, isigma=NULL)
if(any(y <= 0 | y >= 1))
stop("all y values must be in (0,1)")
- predictors.names = c(namesof("mu", .lmu, tag= FALSE),
- namesof("sigma", .lsigma, tag= FALSE))
+ predictors.names = c(namesof("mu", .lmu, earg=.emu, tag=FALSE),
+ namesof("sigma", .lsigma, earg=.esigma, tag=FALSE))
if(!length(etastart)) {
mu.init = rep(if(length( .imu)) .imu else
median(y), length=n)
sigma.init = rep(if(length( .isigma)) .isigma else
sqrt(var(y)), length=n)
- etastart = cbind(theta2eta(mu.init, .lmu),
- theta2eta(sigma.init, .lsigma))
+ etastart = cbind(theta2eta(mu.init, .lmu, earg= .emu),
+ theta2eta(sigma.init, .lsigma, earg= .esigma))
}
}), list( .lmu=lmu, .lsigma=lsigma,
- .imu=imu, .isigma=isigma ))),
+ .emu=emu, .esigma=esigma,
+ .imu=imu, .isigma=isigma ))),
inverse=eval(substitute(function(eta, extra=NULL) {
- eta2theta(eta[,1], .lmu)
- }, list( .lmu=lmu ))),
+ eta2theta(eta[,1], .lmu, earg= .emu)
+ }, list( .lmu=lmu,
+ .emu=emu, .esigma=esigma ))),
last=eval(substitute(expression({
misc$d3 = d3 # because save.weights=F
misc$link = c(mu= .lmu, sigma= .lsigma)
+ misc$earg = list(mu= .emu, sigma= .esigma)
misc$pooled.weight = pooled.weight
- }), list( .lmu=lmu, .lsigma=lsigma ))),
+ }), list( .lmu=lmu, .lsigma=lsigma,
+ .emu=emu, .esigma=esigma ))),
loglikelihood=eval(substitute(function(mu,y,w,residuals= FALSE,eta, extra=NULL) {
- sigma = eta2theta(eta[,2], .lsigma)
+ sigma = eta2theta(eta[,2], .lsigma, earg= .esigma)
if(residuals) stop("loglikelihood residuals not implemented yet") else
sum(w * (-0.5*log(2*pi*sigma^2*(y*(1-y))^3) -
(0.5/sigma^2)*(y-mu)^2 / (y*(1-y)*mu^2*(1-mu)^2 )))
- }, list( .lsigma=lsigma ))),
+ }, list( .lsigma=lsigma,
+ .emu=emu, .esigma=esigma ))),
vfamily=c("simplex1"),
deriv=eval(substitute(expression({
if(iter==1) {
@@ -3182,17 +3381,18 @@ simplex = function(lmu="logit", lsigma="loge", imu=NULL, isigma=NULL)
c("mu", "sigma"), hessian= TRUE)
}
- sigma = eta2theta(eta[,2], .lsigma)
+ sigma = eta2theta(eta[,2], .lsigma, earg= .esigma)
eval.d3 = eval(d3)
dl.dthetas = attr(eval.d3, "gradient")
- dmu.deta = dtheta.deta(mu, .lmu)
- dsigma.deta = dtheta.deta(sigma, .lsigma)
+ dmu.deta = dtheta.deta(mu, .lmu, earg= .emu)
+ dsigma.deta = dtheta.deta(sigma, .lsigma, earg= .esigma)
dtheta.detas = cbind(dmu.deta, dsigma.deta)
dl.dthetas * dtheta.detas
- }), list( .lmu=lmu, .lsigma=lsigma ))),
+ }), list( .lmu=lmu, .lsigma=lsigma,
+ .emu=emu, .esigma=esigma ))),
weight=eval(substitute(expression({
d2l.dthetas2 = attr(eval.d3, "hessian")
@@ -3202,8 +3402,8 @@ simplex = function(lmu="logit", lsigma="loge", imu=NULL, isigma=NULL)
wz[,iam(1,2,M)] = -d2l.dthetas2[,1,2] * dtheta.detas[,1] *
dtheta.detas[,2]
if(!.expected) {
- d2mudeta2 = d2theta.deta2(mu, .lmu)
- d2sigmadeta2 = d2theta.deta2(sigma, .lsigma)
+ d2mudeta2 = d2theta.deta2(mu, .lmu, earg= .emu)
+ d2sigmadeta2 = d2theta.deta2(sigma, .lsigma, earg= .esigma)
wz[,iam(1,1,M)] = wz[,iam(1,1,M)] - dl.dthetas[,1] * d2mudeta2
wz[,iam(2,2,M)] = wz[,iam(2,2,M)] - dl.dthetas[,2] * d2sigmadeta2
}
@@ -3218,12 +3418,14 @@ simplex = function(lmu="logit", lsigma="loge", imu=NULL, isigma=NULL)
pooled.weight = FALSE
wz
- }), list( .lmu=lmu, .lsigma=lsigma, .expected=FALSE ))))
+ }), list( .lmu=lmu, .lsigma=lsigma, .expected=FALSE,
+ .emu=emu, .esigma=esigma ))))
}
-rig = function(lmu="identity", llambda="loge", imu=NULL, ilambda=1)
+rig = function(lmu="identity", llambda="loge",
+ emu=list(), elambda=list(), imu=NULL, ilambda=1)
{
if(mode(lmu) != "character" && mode(lmu) != "name")
@@ -3232,6 +3434,8 @@ rig = function(lmu="identity", llambda="loge", imu=NULL, ilambda=1)
llambda = as.character(substitute(llambda))
if(!is.Numeric(ilambda, posit=TRUE))
stop("bad input for \"ilambda\"")
+ if(!is.list(emu)) emu = list()
+ if(!is.list(elambda)) elambda = list()
new("vglmff",
blurb=c("Reciprocal inverse Gaussian distribution \n",
@@ -3239,39 +3443,47 @@ rig = function(lmu="identity", llambda="loge", imu=NULL, ilambda=1)
" exp[-0.5*(lambda/y) * (y-mu)^2], ",
" 0 < y,\n",
"Links: ",
- namesof("mu", lmu), ", ",
- namesof("lambda", llambda), "\n\n",
+ namesof("mu", lmu, earg=emu), ", ",
+ namesof("lambda", llambda, earg=elambda), "\n\n",
"Mean: mu"),
initialize=eval(substitute(expression({
+ if(ncol(cbind(y)) != 1)
+ stop("response must be a vector or a one-column matrix")
y = as.numeric(y)
if(any(y <= 0))
stop("all y values must be > 0")
- predictors.names = c(namesof("mu", .lmu, tag= FALSE),
- namesof("lambda", .llambda, tag= FALSE))
+ predictors.names =
+ c(namesof("mu", .lmu, earg=.emu, tag=FALSE),
+ namesof("lambda", .llambda, earg=.elambda, tag=FALSE))
if(!length(etastart)) {
mu.init = rep(if(length( .imu)) .imu else
median(y), length=n)
lambda.init = rep(if(length( .ilambda )) .ilambda else
sqrt(var(y)), length=n)
- etastart = cbind(theta2eta(mu.init, .lmu),
- theta2eta(lambda.init, .llambda))
+ etastart = cbind(theta2eta(mu.init, .lmu, earg= .emu),
+ theta2eta(lambda.init, .llambda, earg= .elambda))
}
}), list( .lmu=lmu, .llambda=llambda,
+ .emu=emu, .elambda=elambda,
.imu=imu, .ilambda=ilambda ))),
inverse=eval(substitute(function(eta, extra=NULL) {
- eta2theta(eta[,1], .lmu)
- }, list( .lmu=lmu ))),
+ eta2theta(eta[,1], .lmu, earg= .emu)
+ }, list( .lmu=lmu,
+ .emu=emu, .elambda=elambda ))),
last=eval(substitute(expression({
misc$d3 = d3 # because save.weights=FALSE
misc$link = c(mu= .lmu, lambda= .llambda)
+ misc$earg = list(mu= .emu, lambda= .elambda)
misc$pooled.weight = pooled.weight
- }), list( .lmu=lmu, .llambda=llambda ))),
+ }), list( .lmu=lmu, .llambda=llambda,
+ .emu=emu, .elambda=elambda ))),
loglikelihood=eval(substitute(
function(mu,y,w,residuals= FALSE,eta, extra=NULL) {
- lambda = eta2theta(eta[,2], .llambda)
+ lambda = eta2theta(eta[,2], .llambda, earg= .elambda)
if(residuals) stop("loglikelihood residuals not implemented yet") else
sum(w * (-0.5*log(y) + 0.5*log(lambda) - (0.5*lambda/y) * (y-mu)^2))
- }, list( .llambda=llambda ))),
+ }, list( .llambda=llambda,
+ .emu=emu, .elambda=elambda ))),
vfamily=c("rig"),
deriv=eval(substitute(expression({
if(iter==1) {
@@ -3280,17 +3492,18 @@ rig = function(lmu="identity", llambda="loge", imu=NULL, ilambda=1)
c("mu", "lambda"), hessian= TRUE)
}
- lambda = eta2theta(eta[,2], .llambda)
+ lambda = eta2theta(eta[,2], .llambda, earg= .elambda)
eval.d3 = eval(d3)
dl.dthetas = attr(eval.d3, "gradient")
- dmu.deta = dtheta.deta(mu, .lmu)
- dlambda.deta = dtheta.deta(lambda, .llambda)
+ dmu.deta = dtheta.deta(mu, .lmu, earg= .emu)
+ dlambda.deta = dtheta.deta(lambda, .llambda, earg= .elambda)
dtheta.detas = cbind(dmu.deta, dlambda.deta)
dl.dthetas * dtheta.detas
- }), list( .lmu=lmu, .llambda=llambda ))),
+ }), list( .lmu=lmu, .llambda=llambda,
+ .emu=emu, .elambda=elambda ))),
weight=eval(substitute(expression({
d2l.dthetas2 = attr(eval.d3, "hessian")
@@ -3300,8 +3513,8 @@ rig = function(lmu="identity", llambda="loge", imu=NULL, ilambda=1)
wz[,iam(1,2,M)] = -d2l.dthetas2[,1,2] * dtheta.detas[,1] *
dtheta.detas[,2]
if(!.expected) {
- d2mudeta2 = d2theta.deta2(mu, .lmu)
- d2lambda = d2theta.deta2(lambda, .llambda)
+ d2mudeta2 = d2theta.deta2(mu, .lmu, earg= .emu)
+ d2lambda = d2theta.deta2(lambda, .llambda, earg= .elambda)
wz[,iam(1,1,M)] = wz[,iam(1,1,M)] - dl.dthetas[,1] * d2mudeta2
wz[,iam(2,2,M)] = wz[,iam(2,2,M)] - dl.dthetas[,2] * d2lambda
}
@@ -3316,56 +3529,60 @@ rig = function(lmu="identity", llambda="loge", imu=NULL, ilambda=1)
pooled.weight = FALSE
wz
- }), list( .lmu=lmu, .llambda=llambda, .expected=FALSE ))))
+ }), list( .lmu=lmu, .llambda=llambda, .expected=FALSE,
+ .emu=emu, .elambda=elambda ))))
}
-hyper.secant = function(link.theta="identity", init.theta=NULL)
+hypersecant = function(link.theta="elogit",
+ earg=if(link.theta=="elogit") list(min=-pi/2, max=pi/2) else list(),
+ init.theta=NULL)
{
if(mode(link.theta) != "character" && mode(link.theta) != "name")
link.theta = as.character(substitute(link.theta))
+ if(!is.list(earg)) earg = list()
new("vglmff",
blurb=c("Hyperbolic Secant distribution \n",
"f(y) = exp(theta*y + log(cos(theta ))) / (2*cosh(pi*y/2))\n",
" for all y,\n",
"Link: ",
- namesof("theta", link.theta), "\n\n",
- "Mean: tan(theta)",
- "\n",
- "Variance: ???"),
+ namesof("theta", link.theta, earg=earg), "\n\n",
+ "Mean: tan(theta)"),
initialize=eval(substitute(expression({
- predictors.names = c(namesof("theta", .link.theta, tag= FALSE))
-
+ if(ncol(cbind(y)) != 1)
+ stop("response must be a vector or a one-column matrix")
+ predictors.names = namesof("theta", .link.theta, earg=.earg, tag=FALSE)
if(!length(etastart)) {
theta.init = rep(if(length( .init.theta)) .init.theta else
- median(y), length=n)
-
- etastart = theta2eta(theta.init, .link.theta)
+ median(y), length=n)
+ etastart = theta2eta(theta.init, .link.theta, earg= .earg)
}
- }), list( .link.theta=link.theta,
- .init.theta=init.theta ))),
+ }), list( .link.theta=link.theta, .earg=earg,
+ .init.theta=init.theta ))),
inverse=eval(substitute(function(eta, extra=NULL) {
- theta = eta2theta(eta, .link.theta)
+ theta = eta2theta(eta, .link.theta, earg= .earg)
tan(theta)
- }, list( .link.theta=link.theta ))),
+ }, list( .link.theta=link.theta, .earg=earg ))),
last=eval(substitute(expression({
- misc$link = c(theta= .link.theta)
- }), list( .link.theta=link.theta ))),
+ misc$link = c(theta= .link.theta )
+ misc$earg = list(theta= .earg )
+ misc$expected = TRUE
+ }), list( .link.theta=link.theta, .earg=earg ))),
loglikelihood=eval(substitute(function(mu,y,w,residuals= FALSE,eta, extra=NULL) {
- theta = eta2theta(eta, .link.theta)
+ theta = eta2theta(eta, .link.theta, earg= .earg)
if(residuals) stop("loglikelihood residuals not implemented yet") else
sum(w * (theta*y + log(cos(theta)) - log(cosh(pi*y/2 ))))
- }, list( .link.theta=link.theta ))),
- vfamily=c("hyper.secant"),
+ }, list( .link.theta=link.theta, .earg=earg ))),
+ vfamily=c("hypersecant"),
deriv=eval(substitute(expression({
- theta = eta2theta(eta, .link.theta)
+ theta = eta2theta(eta, .link.theta, earg= .earg)
dl.dthetas = y - tan(theta)
- dparam.deta = dtheta.deta(theta, .link.theta)
+ dparam.deta = dtheta.deta(theta, .link.theta, earg= .earg)
w * dl.dthetas * dparam.deta
- }), list( .link.theta=link.theta ))),
+ }), list( .link.theta=link.theta, .earg=earg ))),
weight=expression({
d2l.dthetas2 = 1 / cos(theta)^2
wz = w * d2l.dthetas2 * dparam.deta^2
@@ -3375,62 +3592,61 @@ hyper.secant = function(link.theta="identity", init.theta=NULL)
-hyper.secant.1 = function(link.theta="identity", init.theta=NULL)
+hypersecant.1 = function(link.theta="elogit",
+ earg=if(link.theta=="elogit") list(min=-pi/2, max=pi/2) else list(),
+ init.theta=NULL)
{
- # # This is NOT based on deriv3()
- # # p.101, (3.38), Jorgensen, 1997, The Theory of Dispersion Models
- # # 19/3/02; N-R is same as Fisher scoring here
- # # works well , but need a link that restricts theta to \pm pi/2
- # # See also hyper.secant() for another parameterization
if(mode(link.theta) != "character" && mode(link.theta) != "name")
link.theta = as.character(substitute(link.theta))
+ if(!is.list(earg)) earg = list()
new("vglmff",
blurb=c("Hyperbolic Secant distribution \n",
"f(y) = (cos(theta)/pi) * y^(-0.5+theta/pi) * \n",
- " (1-y)^(-0.5-theta/pi)], ",
+ " (1-y)^(-0.5-theta/pi), ",
" 0 < y < 1,\n",
"Link: ",
- namesof("theta", link.theta), "\n\n",
- "Mean: 0.5 + theta/pi",
- "\n",
+ namesof("theta", link.theta, earg=earg), "\n\n",
+ "Mean: 0.5 + theta/pi", "\n",
"Variance: (pi^2 - 4*theta^2) / (8*pi^2)"),
initialize=eval(substitute(expression({
+ if(ncol(cbind(y)) != 1)
+ stop("response must be a vector or a one-column matrix")
y = as.numeric(y)
if(any(y <= 0 | y >= 1))
stop("all y values must be in (0,1)")
-
- predictors.names = c(namesof("theta", .link.theta, tag= FALSE))
-
+ predictors.names = namesof("theta", .link.theta, earg=.earg, tag=FALSE)
if(!length(etastart)) {
theta.init = rep(if(length( .init.theta)) .init.theta else
median(y), length=n)
- etastart = theta2eta(theta.init, .link.theta)
+ etastart = theta2eta(theta.init, .link.theta, earg= .earg)
}
- }), list( .link.theta=link.theta,
- .init.theta=init.theta ))),
+ }), list( .link.theta=link.theta, .earg=earg,
+ .init.theta=init.theta ))),
inverse=eval(substitute(function(eta, extra=NULL) {
- theta = eta2theta(eta, .link.theta)
+ theta = eta2theta(eta, .link.theta, earg= .earg)
0.5 + theta/pi
- }, list( .link.theta=link.theta ))),
+ }, list( .link.theta=link.theta, .earg=earg ))),
last=eval(substitute(expression({
misc$link = c(theta= .link.theta)
- }), list( .link.theta=link.theta ))),
+ misc$earg = list(theta= .earg )
+ misc$expected = TRUE
+ }), list( .link.theta=link.theta, .earg=earg ))),
loglikelihood=eval(substitute(function(mu,y,w,residuals= FALSE,eta, extra=NULL) {
- theta = eta2theta(eta, .link.theta)
+ theta = eta2theta(eta, .link.theta, earg= .earg)
if(residuals) stop("loglikelihood residuals not implemented yet") else
sum(w * (log(cos(theta)) + (-0.5+theta/pi)*log(y) +
(-0.5-theta/pi)*log(1-y )))
- }, list( .link.theta=link.theta ))),
- vfamily=c("hyper.secant.1"),
+ }, list( .link.theta=link.theta, .earg=earg ))),
+ vfamily=c("hypersecant.1"),
deriv=eval(substitute(expression({
- theta = eta2theta(eta, .link.theta)
+ theta = eta2theta(eta, .link.theta, earg= .earg)
dl.dthetas = -tan(theta) + log(y/(1-y)) / pi
- dparam.deta = dtheta.deta(theta, .link.theta)
+ dparam.deta = dtheta.deta(theta, .link.theta, earg= .earg)
w * dl.dthetas * dparam.deta
- }), list( .link.theta=link.theta ))),
+ }), list( .link.theta=link.theta, .earg=earg ))),
weight=expression({
d2l.dthetas2 = 1 / cos(theta)^2
wz = w * d2l.dthetas2 * dparam.deta^2
@@ -3440,7 +3656,8 @@ hyper.secant.1 = function(link.theta="identity", init.theta=NULL)
-leipnik = function(lmu="logit", llambda="loge", imu=NULL, ilambda=NULL)
+leipnik = function(lmu="logit", llambda="loge",
+ emu=list(), elambda=list(), imu=NULL, ilambda=NULL)
{
@@ -3450,6 +3667,8 @@ leipnik = function(lmu="logit", llambda="loge", imu=NULL, ilambda=NULL)
llambda = as.character(substitute(llambda))
if(is.Numeric(ilambda) && any(ilambda <= -1))
stop("ilambda must be > -1")
+ if(!is.list(emu)) emu = list()
+ if(!is.list(elambda)) elambda = list()
new("vglmff",
blurb=c("Leipnik's distribution \n",
@@ -3457,48 +3676,54 @@ leipnik = function(lmu="logit", llambda="loge", imu=NULL, ilambda=NULL)
" Beta[(lambda+1)/2, 1/2], ",
" 0 < y < 1, lambda > -1\n",
"Links: ",
- namesof("mu", lmu), ", ",
- namesof("lambda", llambda), "\n\n",
+ namesof("mu", lmu, earg=emu), ", ",
+ namesof("lambda", llambda, earg=elambda), "\n\n",
"Mean: mu\n",
"Variance: mu*(1-mu)"),
initialize=eval(substitute(expression({
+ if(ncol(cbind(y)) != 1)
+ stop("response must be a vector or a one-column matrix")
y = as.numeric(y)
if(any(y <= 0 | y >= 1))
stop("all y values must be in (0,1)")
-
- predictors.names = c(namesof("mu", .lmu, tag= FALSE),
- namesof("lambda", .llambda, tag= FALSE))
-
+ predictors.names =
+ c(namesof("mu", .lmu, earg=.emu, tag=FALSE),
+ namesof("lambda", .llambda, earg=.elambda, tag=FALSE))
if(!length(etastart)) {
mu.init = rep(if(length( .imu)) .imu else
(y), length=n)
lambda.init = rep(if(length( .ilambda)) .ilambda else
1/var(y), length=n)
- etastart = cbind(theta2eta(mu.init, .lmu),
- theta2eta(lambda.init, .llambda))
+ etastart = cbind(theta2eta(mu.init, .lmu, earg= .emu),
+ theta2eta(lambda.init, .llambda, earg= .elambda))
}
- }), list( .lmu=lmu, .llambda=llambda, .imu=imu, .ilambda=ilambda ))),
+ }), list( .lmu=lmu, .llambda=llambda, .imu=imu, .ilambda=ilambda,
+ .emu=emu, .elambda=elambda ))),
inverse=eval(substitute(function(eta, extra=NULL) {
- eta2theta(eta[,1], .lmu)
- }, list( .lmu=lmu ))),
+ eta2theta(eta[,1], .lmu, earg= .emu)
+ }, list( .lmu=lmu,
+ .emu=emu, .elambda=elambda ))),
last=eval(substitute(expression({
if(!is.R())
misc$d3 = d3 # because save.weights=FALSE
misc$link = c(mu= .lmu, lambda= .llambda)
+ misc$earg = list(mu= .emu, lambda= .elambda)
misc$pooled.weight = pooled.weight
misc$expected = FALSE
- }), list( .lmu=lmu, .llambda=llambda ))),
+ }), list( .lmu=lmu, .llambda=llambda,
+ .emu=emu, .elambda=elambda ))),
loglikelihood=eval(substitute(
function(mu,y,w,residuals= FALSE,eta, extra=NULL) {
- lambda = eta2theta(eta[,2], .llambda)
+ lambda = eta2theta(eta[,2], .llambda, earg= .elambda)
if(residuals) stop("loglikelihood residuals not implemented yet") else
sum(w * (-0.5*log(y*(1-y)) - 0.5 * lambda * log(1 +
(y-mu)^2 / (y*(1-y ))) - lgamma((lambda+1)/2) +
lgamma(1+ lambda/2 )))
- }, list( .llambda=llambda ))),
+ }, list( .llambda=llambda,
+ .emu=emu, .elambda=elambda ))),
vfamily=c("leipnik"),
deriv=eval(substitute(expression({
- lambda = eta2theta(eta[,2], .llambda)
+ lambda = eta2theta(eta[,2], .llambda, earg= .elambda)
if(is.R()) {
dl.dthetas = w * cbind(dl.dmu=lambda*(y-mu)/(y*(1-y)+(y-mu)^2),
dl.dlambda=-0.5*log(1+(y-mu)^2 / (y*(1-y ))) -
@@ -3514,11 +3739,12 @@ leipnik = function(lmu="logit", llambda="loge", imu=NULL, ilambda=NULL)
eval.d3 = eval(d3)
dl.dthetas = attr(eval.d3, "gradient")
}
- dmu.deta = dtheta.deta(mu, .lmu)
- dlambda.deta = dtheta.deta(lambda, .llambda)
+ dmu.deta = dtheta.deta(mu, .lmu, earg= .emu)
+ dlambda.deta = dtheta.deta(lambda, .llambda, earg= .elambda)
dtheta.detas = cbind(dmu.deta, dlambda.deta)
dl.dthetas * dtheta.detas
- }), list( .lmu=lmu, .llambda=llambda ))),
+ }), list( .lmu=lmu, .llambda=llambda,
+ .emu=emu, .elambda=elambda ))),
weight=eval(substitute(expression({
if(is.R()) {
denominator = y*(1-y) + (y-mu)^2
@@ -3538,8 +3764,8 @@ leipnik = function(lmu="logit", llambda="loge", imu=NULL, ilambda=NULL)
wz[,iam(1,2,M)] = -d2l.dthetas2[,1,2] * dtheta.detas[,1] *
dtheta.detas[,2]
if(!.expected) {
- d2mudeta2 = d2theta.deta2(mu, .lmu)
- d2lambda = d2theta.deta2(lambda, .llambda)
+ d2mudeta2 = d2theta.deta2(mu, .lmu, earg= .emu)
+ d2lambda = d2theta.deta2(lambda, .llambda, earg= .elambda)
wz[,iam(1,1,M)] = wz[,iam(1,1,M)] - dl.dthetas[,1] * d2mudeta2
wz[,iam(2,2,M)] = wz[,iam(2,2,M)] - dl.dthetas[,2] * d2lambda
}
@@ -3554,7 +3780,8 @@ leipnik = function(lmu="logit", llambda="loge", imu=NULL, ilambda=NULL)
pooled.weight = FALSE
wz
- }), list( .lmu=lmu, .llambda=llambda, .expected=FALSE ))))
+ }), list( .lmu=lmu, .llambda=llambda, .expected=FALSE,
+ .emu=emu, .elambda=elambda ))))
}
@@ -3562,6 +3789,7 @@ leipnik = function(lmu="logit", llambda="loge", imu=NULL, ilambda=NULL)
invbinomial = function(lrho="logit", llambda="loge",
+ erho=list(), elambda=list(),
irho=0.75,
ilambda=NULL,
zero=NULL)
@@ -3573,69 +3801,78 @@ invbinomial = function(lrho="logit", llambda="loge",
llambda = as.character(substitute(llambda))
if(length(zero) && !is.Numeric(zero, integer=TRUE, posit=TRUE))
stop("bad input for argument \"zero\"")
+ if(!is.list(erho)) erho = list()
+ if(!is.list(elambda)) elambda = list()
new("vglmff",
blurb=c("Inverse binomial distribution\n\n",
"Links: ",
- namesof("rho", lrho), ", ",
- namesof("lambda", llambda), "\n",
+ namesof("rho", lrho, earg=erho), ", ",
+ namesof("lambda", llambda, earg=elambda), "\n",
"Mean: lambda*(1-rho)/(2*rho-1)\n"),
constraints=eval(substitute(expression({
constraints = cm.zero.vgam(constraints, x, .zero, M)
}), list( .zero=zero ))),
initialize=eval(substitute(expression({
- predictors.names = c(namesof("rho", .lrho, tag= FALSE),
- namesof("lambda", .llambda, tag= FALSE))
-
+ if(ncol(cbind(y)) != 1)
+ stop("response must be a vector or a one-column matrix")
+ predictors.names =
+ c(namesof("rho", .lrho, earg=.erho, tag=FALSE),
+ namesof("lambda", .llambda, earg=.elambda, tag=FALSE))
if(!length(etastart)) {
- 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),
- theta2eta(lambda, .llambda))
+ 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))
}
}), list( .llambda=llambda, .lrho=lrho,
- .ilambda=ilambda, .irho=irho ))),
+ .elambda=elambda, .erho=erho,
+ .ilambda=ilambda, .irho=irho ))),
inverse=eval(substitute(function(eta, extra=NULL) {
- rho = eta2theta(eta[,1], .lrho)
- lambda = eta2theta(eta[,2], .llambda)
+ rho = eta2theta(eta[,1], .lrho, earg= .erho)
+ lambda = eta2theta(eta[,2], .llambda, earg= .elambda)
lambda*(1-rho)/(2*rho-1)
- }, list( .llambda=llambda, .lrho=lrho ))),
+ }, list( .llambda=llambda, .lrho=lrho,
+ .elambda=elambda, .erho=erho ))),
last=eval(substitute(expression({
misc$link = c(rho= .lrho, lambda= .llambda)
+ misc$earg = list(rho= .erho, lambda= .elambda)
misc$pooled.weight = pooled.weight
- }), list( .llambda=llambda, .lrho=lrho ))),
- loglikelihood=eval(substitute(function(mu, y, w, residuals= FALSE,eta, extra=NULL) {
- rho = eta2theta(eta[,1], .lrho)
- lambda = eta2theta(eta[,2], .llambda)
+ }), list( .llambda=llambda, .lrho=lrho,
+ .elambda=elambda, .erho=erho ))),
+ loglikelihood=eval(substitute(
+ function(mu, y, w, residuals= FALSE,eta, extra=NULL) {
+ rho = eta2theta(eta[,1], .lrho, earg= .erho)
+ lambda = eta2theta(eta[,2], .llambda, earg= .elambda)
if(residuals) stop("loglikelihood residuals not implemented yet") else
sum(w*(log(lambda) - lgamma(2*y+lambda) - lgamma(y+1) -
lgamma(y+lambda+1) + y*log(rho*(1-rho)) + lambda*log(rho )))
- }, list( .llambda=llambda, .lrho=lrho ))),
+ }, list( .llambda=llambda, .lrho=lrho,
+ .elambda=elambda, .erho=erho ))),
vfamily=c("invbinomial"),
deriv=eval(substitute(expression({
- rho = eta2theta(eta[,1], .lrho)
- lambda = eta2theta(eta[,2], .llambda)
+ 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.dlambda = 1/lambda - digamma(2*y+lambda) - digamma(y+lambda+1) +
log(rho)
- dlambda.deta = dtheta.deta(lambda, .llambda)
- drho.deta = dtheta.deta(rho, .lrho)
+ 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 ))),
+ }), 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
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.drho2 * drho.deta^2
+ 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
- d2lambda.deta2 = d2theta.deta2(lambda, .llambda)
- d2rhodeta2 = d2theta.deta2(rho, .lrho)
+ 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
@@ -3650,12 +3887,14 @@ invbinomial = function(lrho="logit", llambda="loge",
pooled.weight = FALSE
wz
- }), list( .llambda=llambda, .lrho=lrho ))))
+ }), list( .llambda=llambda, .lrho=lrho,
+ .elambda=elambda, .erho=erho ))))
}
genpoisson = function(llambda="logit", ltheta="loge",
+ elambda=list(), etheta=list(),
ilambda=0.5, itheta=NULL, zero=NULL)
{
@@ -3665,61 +3904,71 @@ genpoisson = function(llambda="logit", ltheta="loge",
ltheta = as.character(substitute(ltheta))
if(length(zero) && !is.Numeric(zero, integer=TRUE, posit=TRUE))
stop("bad input for argument \"zero\"")
+ if(!is.list(elambda)) elambda = list()
+ if(!is.list(etheta)) etheta = list()
new("vglmff",
blurb=c("Generalized Poisson distribution\n\n",
"Links: ",
- namesof("lambda", llambda), ", ",
- namesof("theta", ltheta), "\n",
+ namesof("lambda", llambda, earg=elambda), ", ",
+ namesof("theta", ltheta, earg=etheta), "\n",
"Mean: theta / (1-lambda)\n",
"Variance: theta / (1-lambda)^3"),
constraints=eval(substitute(expression({
constraints = cm.zero.vgam(constraints, x, .zero, M)
}), list( .zero=zero ))),
initialize=eval(substitute(expression({
- predictors.names = c(namesof("lambda", .llambda, tag= FALSE),
- namesof("theta", .ltheta, tag= FALSE))
-
+ if(ncol(cbind(y)) != 1)
+ stop("response must be a vector or a one-column matrix")
+ predictors.names =
+ c(namesof("lambda", .llambda, earg=.elambda, tag=FALSE),
+ namesof("theta", .ltheta, earg=.etheta, tag=FALSE))
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)
- etastart = cbind(theta2eta(lambda, .llambda),
- theta2eta(theta, .ltheta))
+ etastart = cbind(theta2eta(lambda, .llambda, earg= .elambda),
+ theta2eta(theta, .ltheta, earg= .etheta))
}
}), list( .ltheta=ltheta, .llambda=llambda,
+ .etheta=etheta, .elambda=elambda,
.itheta=itheta, .ilambda=ilambda )) ),
inverse=eval(substitute(function(eta, extra=NULL) {
- lambda = eta2theta(eta[,1], .llambda)
- theta = eta2theta(eta[,2], .ltheta)
+ lambda = eta2theta(eta[,1], .llambda, earg= .elambda)
+ theta = eta2theta(eta[,2], .ltheta, earg= .etheta)
theta/(1-lambda)
- }, list( .ltheta=ltheta, .llambda=llambda ))),
+ }, list( .ltheta=ltheta, .llambda=llambda,
+ .etheta=etheta, .elambda=elambda ))),
last=eval(substitute(expression({
misc$link = c(lambda=.llambda, theta=.ltheta)
+ misc$earg = list(lambda=.elambda, theta=.etheta)
misc$pooled.weight = pooled.weight
- }), list( .ltheta=ltheta, .llambda=llambda ))),
+ }), list( .ltheta=ltheta, .llambda=llambda,
+ .etheta=etheta, .elambda=elambda ))),
loglikelihood=eval(substitute(
function(mu, y, w, residuals= FALSE,eta, extra=NULL) {
- lambda = eta2theta(eta[,1], .llambda)
- theta = eta2theta(eta[,2], .ltheta)
+ lambda = eta2theta(eta[,1], .llambda, earg= .elambda)
+ theta = eta2theta(eta[,2], .ltheta, earg= .etheta)
index = y == 0
if(residuals) stop("loglikelihood residuals not implemented yet") else
sum(w[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] )))
- }, list( .ltheta=ltheta, .llambda=llambda ))),
+ }, list( .ltheta=ltheta, .llambda=llambda,
+ .etheta=etheta, .elambda=elambda ))),
vfamily=c("genpoisson"),
deriv=eval(substitute(expression({
- lambda = eta2theta(eta[,1], .llambda)
- theta = eta2theta(eta[,2], .ltheta)
+ lambda = eta2theta(eta[,1], .llambda, earg= .elambda)
+ theta = eta2theta(eta[,2], .ltheta, earg= .etheta)
dl.dlambda = -y + y*(y-1)/(theta+y*lambda)
dl.dtheta = -1 + (y-1)/(theta+y*lambda) + 1/theta
- dTHETA.deta = dtheta.deta(theta, .ltheta)
- dlambda.deta = dtheta.deta(lambda, .llambda)
+ dTHETA.deta = dtheta.deta(theta, .ltheta, earg= .etheta)
+ dlambda.deta = dtheta.deta(lambda, .llambda, earg= .elambda)
w * cbind( dl.dlambda * dlambda.deta, dl.dtheta * dTHETA.deta )
- }), list( .ltheta=ltheta, .llambda=llambda ))),
+ }), 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
@@ -3729,8 +3978,8 @@ genpoisson = function(llambda="logit", ltheta="loge",
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)
- d2lambdadeta2 = d2theta.deta2(lambda, .llambda)
+ 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
@@ -3746,56 +3995,61 @@ genpoisson = function(llambda="logit", ltheta="loge",
wz
- }), list( .ltheta=ltheta, .llambda=llambda ))))
+ }), list( .ltheta=ltheta, .llambda=llambda,
+ .etheta=etheta, .elambda=elambda ))))
}
-lgammaff = function(link="loge", init.k=NULL)
+lgammaff = function(link="loge", earg=list(), init.k=NULL)
{
if(mode(link) != "character" && mode(link) != "name")
link = as.character(substitute(link))
+ if(!is.list(earg)) earg = list()
new("vglmff",
blurb=c("Log-gamma distribution f(y) = exp(ky - e^y)/gamma(k)), k>0\n\n",
"Link: ",
- namesof("k", link), "\n", "\n",
+ namesof("k", link, earg=earg), "\n", "\n",
"Mean: digamma(k)", "\n"),
initialize=eval(substitute(expression({
- predictors.names = namesof("k", .link, tag= FALSE)
+ if(ncol(cbind(y)) != 1)
+ stop("response must be a vector or a one-column matrix")
+ predictors.names = namesof("k", .link, earg=.earg, tag=FALSE)
if(!length(etastart)) {
k.init = if(length( .init.k)) rep( .init.k, len=length(y)) else {
medy = median(y)
if(medy < 2) 5 else if(medy < 4) 20 else exp(0.7 * medy)
}
- etastart = theta2eta(k.init, .link)
+ etastart = theta2eta(k.init, .link, earg= .earg)
}
- }), list( .link=link, .init.k=init.k ))),
+ }), list( .link=link, .earg=earg, .init.k=init.k ))),
inverse=eval(substitute(function(eta, extra=NULL) {
- k = eta2theta(eta, .link)
+ k = eta2theta(eta, .link, earg= .earg)
digamma(k)
- }, list( .link=link ))),
+ }, list( .link=link, .earg=earg ))),
last=eval(substitute(expression({
- misc$link = c(k= .link)
- }), list( .link=link ))),
+ misc$link = c(k= .link )
+ misc$earg = list(k= .earg )
+ }), list( .link=link, .earg=earg ))),
loglikelihood=eval(substitute(
function(mu,y,w,residuals= FALSE,eta, extra=NULL) {
- k = eta2theta(eta, .link)
+ k = eta2theta(eta, .link, earg= .earg)
if(residuals) stop("loglikelihood residuals not implemented yet") else
sum(w * (k * y - exp(y) - lgamma(k )))
- }, list( .link=link ))),
+ }, list( .link=link, .earg=earg ))),
vfamily=c("lgammaff"),
deriv=eval(substitute(expression({
- k = eta2theta(eta, .link)
+ k = eta2theta(eta, .link, earg= .earg)
dl.dk = y - digamma(k)
- dk.deta = dtheta.deta(k, .link)
+ dk.deta = dtheta.deta(k, .link, earg= .earg)
w * dl.dk * dk.deta
- }), list( .link=link ))),
+ }), list( .link=link, .earg=earg ))),
weight=eval(substitute(expression({
ed2l.dk2 = trigamma(k)
wz = w * dk.deta^2 * ed2l.dk2
wz
- }), list( .link=link ))))
+ }), list( .link=link, .earg=earg ))))
}
@@ -3828,6 +4082,7 @@ rlgamma = function(n, location=0, scale=1, k=1) {
lgamma3ff = function(llocation="identity", lscale="loge", lshape="loge",
+ elocation=list(), escale=list(), eshape=list(),
ilocation=NULL, iscale=NULL, ishape=1, zero=NULL)
{
if(mode(llocation) != "character" && mode(llocation) != "name")
@@ -3838,23 +4093,29 @@ 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(!is.list(elocation)) elocation = list()
+ if(!is.list(escale)) escale = list()
+ if(!is.list(eshape)) eshape = list()
new("vglmff",
blurb=c("Log-gamma distribution",
" f(y) = exp(k(y-a)/b - e^((y-a)/b))/(b*gamma(k)), ",
"location=a, scale=b>0, shape=k>0\n\n",
"Links: ",
- namesof("location", llocation), ", ",
- namesof("scale", lscale), ", ",
- namesof("shape", lshape), "\n\n",
+ namesof("location", llocation, earg=elocation), ", ",
+ namesof("scale", lscale, earg=escale), ", ",
+ namesof("shape", lshape, earg=eshape), "\n\n",
"Mean: a + b*digamma(k)", "\n"),
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, tag= FALSE),
- namesof("scale", .lscale, tag= FALSE),
- namesof("shape", .lshape, tag= FALSE))
+ if(ncol(cbind(y)) != 1)
+ stop("response must be a vector or a one-column matrix")
+ predictors.names =
+ c(namesof("location", .llocation, earg=.elocation, tag=FALSE),
+ namesof("scale", .lscale, earg=.escale, tag=FALSE),
+ namesof("shape", .lshape, earg=.eshape, tag=FALSE))
if(!length(etastart)) {
k.init = if(length( .ishape)) rep( .ishape, len=length(y)) else {
rep(exp(median(y)), len=length(y))
@@ -3865,42 +4126,49 @@ lgamma3ff = function(llocation="identity", lscale="loge", lshape="loge",
loc.init = if(length( .iloc)) rep( .iloc, len=length(y)) else {
rep(median(y) - scale.init * digamma(k.init), len=length(y))
}
- etastart = cbind(theta2eta(loc.init, .llocation),
- theta2eta(scale.init, .lscale),
- theta2eta(k.init, .lshape))
+ etastart = cbind(theta2eta(loc.init, .llocation, earg= .elocation),
+ theta2eta(scale.init, .lscale, earg= .escale),
+ theta2eta(k.init, .lshape, earg= .eshape))
}
}), list( .llocation=llocation, .lscale=lscale, .lshape=lshape,
- .iloc=ilocation, .iscale=iscale, .ishape=ishape ))),
+ .elocation=elocation, .escale=escale, .eshape=eshape,
+ .iloc=ilocation, .iscale=iscale, .ishape=ishape ))),
inverse=eval(substitute(function(eta, extra=NULL) {
- eta2theta(eta[,1], .llocation) + eta2theta(eta[,2], .lscale) *
- digamma(eta2theta(eta[,3], .lshape))
- }, list( .llocation=llocation, .lscale=lscale, .lshape=lshape ))),
+ eta2theta(eta[,1], .llocation, earg= .elocation) +
+ eta2theta(eta[,2], .lscale, earg= .escale) *
+ digamma(eta2theta(eta[,3], .lshape, earg= .eshape))
+ }, list( .llocation=llocation, .lscale=lscale, .lshape=lshape,
+ .elocation=elocation, .escale=escale, .eshape=eshape ))),
last=eval(substitute(expression({
misc$link = c(location= .llocation, scale= .lscale, shape= .lshape)
- }), list( .llocation=llocation, .lscale=lscale, .lshape=lshape ))),
+ misc$earg = list(location= .elocation, scale= .escale, shape= .eshape)
+ }), list( .llocation=llocation, .lscale=lscale, .lshape=lshape,
+ .elocation=elocation, .escale=escale, .eshape=eshape ))),
loglikelihood=eval(substitute(
function(mu,y,w,residuals= FALSE,eta, extra=NULL) {
- a = eta2theta(eta[,1], .llocation)
- b = eta2theta(eta[,2], .lscale)
- k = eta2theta(eta[,3], .lshape)
+ a = eta2theta(eta[,1], .llocation, earg= .elocation)
+ b = eta2theta(eta[,2], .lscale, earg= .escale)
+ k = eta2theta(eta[,3], .lshape, earg= .eshape)
zedd = (y-a)/b
if(residuals) stop("loglikelihood residuals not implemented yet") else
sum(w * (k * zedd - exp(zedd) - lgamma(k) - log(b )))
- }, list( .llocation=llocation, .lscale=lscale, .lshape=lshape ))),
+ }, list( .llocation=llocation, .lscale=lscale, .lshape=lshape,
+ .elocation=elocation, .escale=escale, .eshape=eshape ))),
vfamily=c("lgamma3ff"),
deriv=eval(substitute(expression({
- a = eta2theta(eta[,1], .llocation)
- b = eta2theta(eta[,2], .lscale)
- k = eta2theta(eta[,3], .lshape)
+ a = eta2theta(eta[,1], .llocation, earg= .elocation)
+ b = eta2theta(eta[,2], .lscale, earg= .escale)
+ k = eta2theta(eta[,3], .lshape, earg= .eshape)
zedd = (y-a)/b
dl.da = (exp(zedd) - k) / b
dl.db = (zedd * (exp(zedd) - k) - 1) / b
dl.dk = zedd - digamma(k)
- da.deta = dtheta.deta(a, .llocation)
- db.deta = dtheta.deta(b, .lscale)
- dk.deta = dtheta.deta(k, .lshape)
+ da.deta = dtheta.deta(a, .llocation, earg= .elocation)
+ db.deta = dtheta.deta(b, .lscale, earg= .escale)
+ dk.deta = dtheta.deta(k, .lshape, earg= .eshape)
w * cbind(dl.da * da.deta, dl.db * db.deta, dl.dk * dk.deta)
- }), list( .llocation=llocation, .lscale=lscale, .lshape=lshape ))),
+ }), list( .llocation=llocation, .lscale=lscale, .lshape=lshape,
+ .elocation=elocation, .escale=escale, .eshape=eshape ))),
weight=eval(substitute(expression({
ed2l.da2 = k / b^2
ed2l.db2 = (1 + k*(trigamma(k+1) + (digamma(k+1))^2)) / b^2
@@ -3917,11 +4185,13 @@ lgamma3ff = function(llocation="identity", lscale="loge", lshape="loge",
wz[,iam(2,3,M)] = ed2l.dbdk * db.deta * dk.deta
wz = w * wz
wz
- }), list( .llocation=llocation, .lscale=lscale, .lshape=lshape ))))
+ }), list( .llocation=llocation, .lscale=lscale, .lshape=lshape,
+ .elocation=elocation, .escale=escale, .eshape=eshape ))))
}
prentice74 = function(llocation="identity", lscale="loge", lshape="identity",
- ilocation=NULL, iscale=NULL, ishape=NULL, zero=NULL)
+ elocation=list(), escale=list(), eshape=list(),
+ ilocation=NULL, iscale=NULL, ishape=NULL, zero=NULL)
{
if(mode(llocation) != "character" && mode(llocation) != "name")
llocation = as.character(substitute(llocation))
@@ -3931,23 +4201,29 @@ 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(!is.list(elocation)) elocation = list()
+ if(!is.list(escale)) escale = list()
+ if(!is.list(eshape)) eshape = list()
new("vglmff",
blurb=c("Log-gamma distribution (Prentice, 1974)",
" f(y) = |q| * exp(w/q^2 - e^w) / (b*gamma(1/q^2)) ,\n",
"w=(y-a)*q/b + digamma(1/q^2), location=a, scale=b>0, shape=q\n\n",
"Links: ",
- namesof("location", llocation), ", ",
- namesof("scale", lscale), ", ",
- namesof("shape", lshape), "\n", "\n",
+ namesof("location", llocation, earg=elocation), ", ",
+ namesof("scale", lscale, earg=escale), ", ",
+ namesof("shape", lshape, earg=eshape), "\n", "\n",
"Mean: a", "\n"),
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, tag= FALSE),
- namesof("scale", .lscale, tag= FALSE),
- namesof("shape", .lshape, tag= FALSE))
+ if(ncol(cbind(y)) != 1)
+ stop("response must be a vector or a one-column matrix")
+ predictors.names =
+ c(namesof("location", .llocation, earg=.elocation, tag=FALSE),
+ namesof("scale", .lscale, earg=.escale, tag=FALSE),
+ namesof("shape", .lshape, earg=.eshape, tag=FALSE))
if(!length(etastart)) {
sdy = sqrt(var(y))
k.init = if(length( .ishape)) rep( .ishape, len=length(y)) else {
@@ -3960,33 +4236,38 @@ prentice74 = function(llocation="identity", lscale="loge", lshape="identity",
loc.init = if(length( .iloc)) rep( .iloc, len=length(y)) else {
rep(median(y), len=length(y))
}
- etastart = cbind(theta2eta(loc.init, .llocation),
- theta2eta(scale.init, .lscale),
- theta2eta(k.init, .lshape))
+ etastart = cbind(theta2eta(loc.init, .llocation, earg= .elocation),
+ theta2eta(scale.init, .lscale, earg= .escale),
+ theta2eta(k.init, .lshape, earg= .eshape))
}
}), list( .llocation=llocation, .lscale=lscale, .lshape=lshape,
- .iloc=ilocation, .iscale=iscale, .ishape=ishape ))),
+ .elocation=elocation, .escale=escale, .eshape=eshape,
+ .iloc=ilocation, .iscale=iscale, .ishape=ishape ))),
inverse=eval(substitute(function(eta, extra=NULL) {
- eta2theta(eta[,1], .llocation)
- }, list( .llocation=llocation, .lscale=lscale, .lshape=lshape ))),
+ eta2theta(eta[,1], .llocation, earg= .elocation)
+ }, list( .llocation=llocation, .lscale=lscale, .lshape=lshape,
+ .elocation=elocation, .escale=escale, .eshape=eshape ))),
last=eval(substitute(expression({
misc$link = c(location= .llocation, scale= .lscale, shape= .lshape)
- }), list( .llocation=llocation, .lscale=lscale, .lshape=lshape ))),
+ misc$earg = list(location= .elocation, scale= .escale, shape= .eshape)
+ }), list( .llocation=llocation, .lscale=lscale, .lshape=lshape,
+ .elocation=elocation, .escale=escale, .eshape=eshape ))),
loglikelihood=eval(substitute(
function(mu,y,w,residuals= FALSE,eta, extra=NULL) {
- a = eta2theta(eta[,1], .llocation)
- b = eta2theta(eta[,2], .lscale)
- k = eta2theta(eta[,3], .lshape)
+ a = eta2theta(eta[,1], .llocation, earg= .elocation)
+ b = eta2theta(eta[,2], .lscale, earg= .escale)
+ k = eta2theta(eta[,3], .lshape, earg= .eshape)
tmp55 = k^(-2)
doubw = (y-a)*k/b + digamma(tmp55)
if(residuals) stop("loglikelihood residuals not implemented yet") else
sum(w*(log(abs(k)) -log(b) -lgamma(tmp55) + doubw*tmp55 -exp(doubw )))
- }, list( .llocation=llocation, .lscale=lscale, .lshape=lshape ))),
+ }, list( .llocation=llocation, .lscale=lscale, .lshape=lshape,
+ .elocation=elocation, .escale=escale, .eshape=eshape ))),
vfamily=c("prentice74"),
deriv=eval(substitute(expression({
- a = eta2theta(eta[,1], .llocation)
- b = eta2theta(eta[,2], .lscale)
- k = eta2theta(eta[,3], .lshape)
+ a = eta2theta(eta[,1], .llocation, earg= .elocation)
+ b = eta2theta(eta[,2], .lscale, earg= .escale)
+ k = eta2theta(eta[,3], .lshape, earg= .eshape)
tmp55 = k^(-2)
mustar = digamma(tmp55)
doubw = (y-a)*k/b + mustar
@@ -3995,11 +4276,12 @@ prentice74 = function(llocation="identity", lscale="loge", lshape="identity",
dl.db = ((doubw - mustar) * (exp(doubw) - tmp55) - 1) / b
dl.dk = 1/k - 2 * (doubw - mustar) / k^3 - (exp(doubw) - tmp55) *
((doubw - mustar) / k - 2 * sigmastar2 / k^3)
- da.deta = dtheta.deta(a, .llocation)
- db.deta = dtheta.deta(b, .lscale)
- dk.deta = dtheta.deta(k, .lshape)
+ da.deta = dtheta.deta(a, .llocation, earg= .elocation)
+ db.deta = dtheta.deta(b, .lscale, earg= .escale)
+ dk.deta = dtheta.deta(k, .lshape, earg= .eshape)
w * cbind(dl.da * da.deta, dl.db * db.deta, dl.dk * dk.deta)
- }), list( .llocation=llocation, .lscale=lscale, .lshape=lshape ))),
+ }), list( .llocation=llocation, .lscale=lscale, .lshape=lshape,
+ .elocation=elocation, .escale=escale, .eshape=eshape ))),
weight=eval(substitute(expression({
ed2l.da2 = 1 / b^2
ed2l.db2 = (1 + sigmastar2*tmp55) / b^2
@@ -4017,7 +4299,8 @@ prentice74 = function(llocation="identity", lscale="loge", lshape="identity",
wz[,iam(2,3,M)] = ed2l.dbdk * db.deta * dk.deta
wz = w * wz
wz
- }), list( .llocation=llocation, .lscale=lscale, .lshape=lshape ))))
+ }), list( .llocation=llocation, .lscale=lscale, .lshape=lshape,
+ .elocation=elocation, .escale=escale, .eshape=eshape ))))
}
@@ -4063,6 +4346,7 @@ rggamma = function(n, scale=1, d=1, k=1) {
}
ggamma = function(lscale="loge", ld="loge", lk="loge",
+ escale=list(), ed=list(), ek=list(),
iscale=NULL, id=NULL, ik=NULL, zero=NULL)
{
if(mode(lscale) != "character" && mode(lscale) != "name")
@@ -4073,24 +4357,30 @@ 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(!is.list(escale)) escale = list()
+ if(!is.list(ed)) ed = list()
+ if(!is.list(ek)) ek = list()
new("vglmff",
blurb=c("Generalized gamma distribution",
" f(y) = d * b^(-d*k) * y^(d*k-1) * exp(-(y/b)^d) / gamma(k),\n",
"scale=b>0, d>0, k>0, y>0\n\n",
"Links: ",
- namesof("scale", lscale), ", ",
- namesof("d", ld), ", ",
- namesof("k", lk), "\n", "\n",
+ namesof("scale", lscale, earg=escale), ", ",
+ namesof("d", ld, earg=ed), ", ",
+ namesof("k", lk, earg=ek), "\n", "\n",
"Mean: b*k", "\n"),
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")
if(any(y <= 0)) stop("response must be have positive values only")
- predictors.names = c(namesof("scale", .lscale, tag= FALSE),
- namesof("d", .ld, tag= FALSE),
- namesof("k", .lk, tag= FALSE))
+ predictors.names =
+ c(namesof("scale", .lscale, earg=.escale, tag=FALSE),
+ namesof("d", .ld, earg=.ed, tag=FALSE),
+ namesof("k", .lk, earg=.ek, tag=FALSE))
if(!length(etastart)) {
b.init = if(length( .iscale)) rep( .iscale, len=length(y)) else {
rep(mean(y^2) / mean(y), len=length(y))
@@ -4101,43 +4391,49 @@ ggamma = function(lscale="loge", ld="loge", lk="loge",
d.init = if(length( .id)) rep( .id, len=length(y)) else {
rep(digamma(k.init) / mean(log(y/b.init)), len=length(y))
}
- etastart = cbind(theta2eta(b.init, .lscale),
- theta2eta(d.init, .ld),
- theta2eta(k.init, .lk))
+ etastart = cbind(theta2eta(b.init, .lscale, earg= .escale),
+ theta2eta(d.init, .ld, earg= .ed),
+ theta2eta(k.init, .lk, earg= .ek))
}
}), list( .lscale=lscale, .ld=ld, .lk=lk,
- .iscale=iscale, .id=id, .ik=ik ))),
+ .escale=escale, .ed=ed, .ek=ek,
+ .iscale=iscale, .id=id, .ik=ik ))),
inverse=eval(substitute(function(eta, extra=NULL) {
- b = eta2theta(eta[,1], .lscale)
- k = eta2theta(eta[,3], .lk)
+ b = eta2theta(eta[,1], .lscale, earg= .escale)
+ k = eta2theta(eta[,3], .lk, earg= .ek)
b * k
- }, list( .ld=ld, .lscale=lscale, .lk=lk ))),
+ }, list( .ld=ld, .lscale=lscale, .lk=lk,
+ .escale=escale, .ed=ed, .ek=ek ))),
last=eval(substitute(expression({
misc$link = c(scale= .lscale, d= .ld, k= .lk)
- }), list( .lscale=lscale, .ld=ld, .lk=lk ))),
+ misc$earg = list(scale= .escale, d= .ed, k= .ek)
+ }), list( .lscale=lscale, .ld=ld, .lk=lk,
+ .escale=escale, .ed=ed, .ek=ek ))),
loglikelihood=eval(substitute(
function(mu,y,w,residuals= FALSE,eta, extra=NULL) {
- b = eta2theta(eta[,1], .lscale)
- d = eta2theta(eta[,2], .ld)
- k = eta2theta(eta[,3], .lk)
+ b = eta2theta(eta[,1], .lscale, earg= .escale)
+ d = eta2theta(eta[,2], .ld, earg= .ed)
+ k = eta2theta(eta[,3], .lk, earg= .ek)
if(residuals) stop("loglikelihood residuals not implemented yet") else
sum(w*(log(d) - lgamma(k) + (d*k-1) * log(y) - d*k*log(b) - (y/b)^d))
- }, list( .lscale=lscale, .ld=ld, .lk=lk ))),
+ }, list( .lscale=lscale, .ld=ld, .lk=lk,
+ .escale=escale, .ed=ed, .ek=ek ))),
vfamily=c("ggamma"),
deriv=eval(substitute(expression({
- b = eta2theta(eta[,1], .lscale)
- d = eta2theta(eta[,2], .ld)
- k = eta2theta(eta[,3], .lk)
+ b = eta2theta(eta[,1], .lscale, earg= .escale)
+ d = eta2theta(eta[,2], .ld, earg= .ed)
+ k = eta2theta(eta[,3], .lk, earg= .ek)
tmp22 = (y/b)^d
tmp33 = log(y/b)
dl.db = d * (tmp22 - k) / b
dl.dd = 1/d + tmp33 * (k - tmp22)
dl.dk = d * tmp33 - digamma(k)
- db.deta = dtheta.deta(b, .lscale)
- dd.deta = dtheta.deta(d, .ld)
- dk.deta = dtheta.deta(k, .lk)
+ db.deta = dtheta.deta(b, .lscale, earg= .escale)
+ dd.deta = dtheta.deta(d, .ld, earg= .ed)
+ dk.deta = dtheta.deta(k, .lk, earg= .ek)
w * cbind(dl.db * db.deta, dl.dd * dd.deta, dl.dk * dk.deta)
- }), list( .lscale=lscale, .ld=ld, .lk=lk ))),
+ }), list( .lscale=lscale, .ld=ld, .lk=lk,
+ .escale=escale, .ed=ed, .ek=ek ))),
weight=eval(substitute(expression({
ed2l.db2 = k * (d/b)^2
ed2l.dd2 = (1 + k * (trigamma(k+1) + (digamma(k+1))^2)) / d^2
@@ -4154,7 +4450,8 @@ ggamma = function(lscale="loge", ld="loge", lk="loge",
wz[,iam(2,3,M)] = ed2l.dddk * dd.deta * dk.deta
wz = w * wz
wz
- }), list( .lscale=lscale, .ld=ld, .lk=lk ))))
+ }), list( .lscale=lscale, .ld=ld, .lk=lk,
+ .escale=escale, .ed=ed, .ek=ek ))))
}
@@ -4232,23 +4529,24 @@ rlog = function(n, prob, Smallno=1.0e-6) {
}
-logff = function(link="logit", init.c=NULL)
+logff = function(link="logit", earg=list(), init.c=NULL)
{
if(length(init.c) &&
(!is.Numeric(init.c, posit=TRUE) || max(init.c) >= 1))
stop("init.c must be in (0,1)")
if(mode(link) != "character" && mode(link) != "name")
link = as.character(substitute(link))
+ if(!is.list(earg)) earg = list()
new("vglmff",
blurb=c("Logarithmic distribution f(y) = a * c^y / y, y=1,2,3,...,\n",
" 0 < c < 1, a = -1 / log(1-c) \n\n",
- "Link: ", namesof("c", link), "\n", "\n",
+ "Link: ", namesof("c", link, earg=earg), "\n", "\n",
"Mean: a * c / (1 - c)", "\n"),
initialize=eval(substitute(expression({
- predictors.names = namesof("c", .link, tag= FALSE)
if(ncol(cbind(y)) != 1)
stop("response must be a vector or a one-column matrix")
+ predictors.names = namesof("c", .link, earg=.earg, tag=FALSE)
if(!length(etastart)) {
llfun = function(cc, y, w) {
a = -1 / log(1-cc)
@@ -4257,41 +4555,43 @@ logff = function(link="logit", init.c=NULL)
c.init = if(length( .init.c )) .init.c else
getInitVals(gvals=seq(0.05, 0.95, len=9), llfun=llfun, y=y, w=w)
c.init = rep(c.init, length=length(y))
- etastart = theta2eta(c.init, .link)
+ etastart = theta2eta(c.init, .link, earg= .earg)
}
- }), list( .link=link, .init.c=init.c ))),
+ }), list( .link=link, .earg=earg, .init.c=init.c ))),
inverse=eval(substitute(function(eta, extra=NULL) {
- cc = eta2theta(eta, .link)
+ cc = eta2theta(eta, .link, earg= .earg)
a = -1 / log(1-cc)
a * cc / (1-cc)
- }, list( .link=link ))),
+ }, list( .link=link, .earg=earg ))),
last=eval(substitute(expression({
misc$link = c(c= .link)
- }), list( .link=link ))),
+ misc$earg = list(c= .earg)
+ }), list( .link=link, .earg=earg ))),
loglikelihood=eval(substitute(
function(mu,y,w,residuals= FALSE,eta, extra=NULL) {
- cc = eta2theta(eta, .link)
+ cc = eta2theta(eta, .link, earg= .earg)
a = -1 / log(1-cc)
if(residuals) stop("loglikelihood residuals not implemented yet") else
sum(w * (log(a) + y * log(cc) - log(y )))
- }, list( .link=link ))),
+ }, list( .link=link, .earg=earg ))),
vfamily=c("logff"),
deriv=eval(substitute(expression({
- cc = eta2theta(eta, .link)
+ cc = eta2theta(eta, .link, earg= .earg)
a = -1 / log(1-cc)
dl.dc = 1 / ((1-cc) * log(1-cc)) + y / cc
- dc.deta = dtheta.deta(cc, .link)
+ dc.deta = dtheta.deta(cc, .link, earg= .earg)
w * dl.dc * dc.deta
- }), list( .link=link ))),
+ }), list( .link=link, .earg=earg ))),
weight=eval(substitute(expression({
ed2l.dc2 = a * (1 - a * cc) / (cc * (1-cc)^2)
wz = w * dc.deta^2 * ed2l.dc2
wz
- }), list( .link=link ))))
+ }), list( .link=link, .earg=earg ))))
}
-levy = function(delta=NULL, link.gamma="loge", idelta=NULL, igamma=NULL)
+levy = function(delta=NULL, link.gamma="loge",
+ earg=list(), idelta=NULL, igamma=NULL)
{
@@ -4299,6 +4599,7 @@ levy = function(delta=NULL, link.gamma="loge", idelta=NULL, igamma=NULL)
delta.known = is.Numeric(delta, allow=1)
if(mode(link.gamma) != "character" && mode(link.gamma) != "name")
link.gamma = as.character(substitute(link.gamma))
+ if(!is.list(earg)) earg = list()
new("vglmff",
blurb=c("Levy distribution f(y) = sqrt(gamma/(2*pi)) * ",
@@ -4308,16 +4609,19 @@ levy = function(delta=NULL, link.gamma="loge", idelta=NULL, igamma=NULL)
if(delta.known) paste(", delta = ", delta, ",", sep=""),
"\n\n",
if(delta.known) "Link: " else "Links: ",
- namesof("gamma", link.gamma),
+ namesof("gamma", link.gamma, earg=earg),
if(! delta.known)
- c(", ", namesof("delta", "identity")),
+ c(", ", namesof("delta", "identity", earg=list())),
"\n\n",
"Mean: NA",
"\n"),
initialize=eval(substitute(expression({
- predictors.names = c(namesof("gamma", .link.gamma, tag= FALSE),
- if( .delta.known) NULL else
- namesof("delta", "identity", tag= FALSE))
+ if(ncol(cbind(y)) != 1)
+ stop("response must be a vector or a one-column matrix")
+ predictors.names =
+ c(namesof("gamma", .link.gamma, earg=.earg, tag=FALSE),
+ if( .delta.known) NULL else
+ namesof("delta", "identity", earg=list(), tag=FALSE))
if(!length(etastart)) {
delta.init = if( .delta.known) {
@@ -4332,55 +4636,57 @@ levy = function(delta=NULL, link.gamma="loge", idelta=NULL, igamma=NULL)
gamma.init = if(length( .igamma)) .igamma else
median(y - delta.init) # = 1/median(1/(y-delta.init))
gamma.init = rep(gamma.init, length=length(y))
- etastart = cbind(theta2eta(gamma.init, .link.gamma),
+ etastart = cbind(theta2eta(gamma.init, .link.gamma, earg= .earg),
if( .delta.known) NULL else delta.init)
}
- }), list( .link.gamma=link.gamma,
+ }), list( .link.gamma=link.gamma, .earg=earg,
.delta.known=delta.known,
.delta=delta,
.idelta=idelta,
.igamma=igamma ))),
inverse=eval(substitute(function(eta, extra=NULL) {
eta = as.matrix(eta)
- mygamma = eta2theta(eta[,1], .link.gamma)
+ mygamma = eta2theta(eta[,1], .link.gamma, earg= .earg)
delta = if( .delta.known) .delta else eta[,2]
NA * mygamma
- }, list( .link.gamma=link.gamma,
+ }, list( .link.gamma=link.gamma, .earg=earg,
.delta.known=delta.known,
.delta=delta ))),
last=eval(substitute(expression({
misc$link = if( .delta.known) NULL else c(delta="identity")
misc$link = c(gamma = .link.gamma, misc$link)
+ misc$earg = if( .delta.known) list(gamma = .earg) else
+ list(gamma = .earg, delta=list())
if( .delta.known)
misc$delta = .delta
- }), list( .link.gamma=link.gamma,
+ }), list( .link.gamma=link.gamma, .earg=earg,
.delta.known=delta.known,
.delta=delta ))),
loglikelihood=eval(substitute(
function(mu,y,w,residuals= FALSE,eta, extra=NULL) {
eta = as.matrix(eta)
- mygamma = eta2theta(eta[,1], .link.gamma)
+ mygamma = eta2theta(eta[,1], .link.gamma, earg= .earg)
delta = if( .delta.known) .delta else eta[,2]
if(residuals) stop("loglikelihood residuals not implemented yet") else
sum(w * 0.5 * (log(mygamma) -3*log(y-delta) - mygamma / (y-delta )))
- }, list( .link.gamma=link.gamma,
+ }, list( .link.gamma=link.gamma, .earg = earg,
.delta.known=delta.known,
.delta=delta ))),
vfamily=c("levy"),
deriv=eval(substitute(expression({
eta = as.matrix(eta)
- mygamma = eta2theta(eta[,1], .link.gamma)
+ mygamma = eta2theta(eta[,1], .link.gamma, earg= .earg)
delta = if( .delta.known) .delta else eta[,2]
if(! .delta.known)
dl.ddelta = (3 - mygamma / (y-delta)) / (2 * (y-delta))
dl.dgamma = 0.5 * (1 / mygamma - 1 / (y-delta))
- dgamma.deta = dtheta.deta(mygamma, .link.gamma)
+ dgamma.deta = dtheta.deta(mygamma, .link.gamma, earg= .earg)
w * cbind(dl.dgamma * dgamma.deta,
if( .delta.known) NULL else dl.ddelta)
- }), list( .link.gamma=link.gamma,
+ }), list( .link.gamma=link.gamma, .earg=earg,
.delta.known=delta.known,
.delta=delta ))),
weight=eval(substitute(expression({
@@ -4392,7 +4698,7 @@ levy = function(delta=NULL, link.gamma="loge", idelta=NULL, igamma=NULL)
}
wz = w * wz / (2 * mygamma^2)
wz
- }), list( .link.gamma=link.gamma,
+ }), list( .link.gamma=link.gamma, .earg=earg,
.delta.known=delta.known,
.delta=delta ))))
}
@@ -4403,7 +4709,7 @@ levy = function(delta=NULL, link.gamma="loge", idelta=NULL, igamma=NULL)
if(FALSE)
stoppa = function(y0,
link.alpha="loge",
- link.theta="loge",
+ link.theta="loge", ealpha=list(), etheta=list(),
ialpha=NULL,
itheta=1.0,
zero=NULL)
@@ -4417,20 +4723,23 @@ stoppa = function(y0,
link.theta = as.character(substitute(link.theta))
if(length(zero) && !is.Numeric(zero, integer=TRUE, posit=TRUE))
stop("bad input for argument \"zero\"")
+ if(!is.list(ealpha)) ealpha = list()
+ if(!is.list(etheta)) etheta = list()
new("vglmff",
blurb=c("Stoppa distribution\n\n",
"Links: ",
- namesof("alpha", link.alpha), ", ",
- namesof("theta", link.theta), "\n",
+ namesof("alpha", link.alpha, earg=ealpha), ", ",
+ namesof("theta", link.theta, earg=etheta), "\n",
if(is.R()) "Mean: theta*y0*beta(1-1/alpha, theta)" else
"Mean: theta*y0*beta(1-1/alpha, theta)"),
constraints=eval(substitute(expression({
constraints = cm.zero.vgam(constraints, x, .zero, M)
}), list( .zero=zero ))),
initialize=eval(substitute(expression({
- predictors.names = c(namesof("alpha", .link.alpha, tag= FALSE),
- namesof("theta", .link.theta, tag= FALSE))
+ predictors.names =
+ c(namesof("alpha", .link.alpha, earg=.ealpha, tag=FALSE),
+ namesof("theta", .link.theta, earg=.etheta, tag=FALSE))
y0 = .y0
if(min(y) < y0) stop("y0 must lie in the interval (0, min(y))")
@@ -4445,15 +4754,15 @@ stoppa = function(y0,
if(!length(etastart)) {
alpha = rep(if(length( .ialpha)) .ialpha else -1/fit0$coef[1], length=n)
theta = rep(if(length( .itheta)) .itheta else 1.0, length=n)
- etastart = cbind(theta2eta(alpha, .link.alpha),
- theta2eta(theta, .link.theta))
+ etastart = cbind(theta2eta(alpha, .link.alpha, earg= .ealpha),
+ theta2eta(theta, .link.theta, earg= .etheta))
}
}), list( .link.theta=link.theta, .link.alpha=link.alpha,
.y0=y0,
.itheta=itheta, .ialpha=ialpha ))),
inverse=eval(substitute(function(eta, extra=NULL) {
- alpha = eta2theta(eta[,1], .link.alpha)
- theta = eta2theta(eta[,2], .link.theta)
+ alpha = eta2theta(eta[,1], .link.alpha, earg= .ealpha)
+ theta = eta2theta(eta[,2], .link.theta, earg= .etheta)
theta * extra$y0 * beta(1-1/alpha, theta)
}, list( .link.theta=link.theta, .link.alpha=link.alpha ))),
last=eval(substitute(expression({
@@ -4461,25 +4770,25 @@ stoppa = function(y0,
}), list( .link.theta=link.theta, .link.alpha=link.alpha ))),
loglikelihood=eval(substitute(
function(mu, y, w, residuals= FALSE,eta, extra=NULL) {
- alpha = eta2theta(eta[,1], .link.alpha)
- theta = eta2theta(eta[,2], .link.theta)
+ alpha = eta2theta(eta[,1], .link.alpha, earg= .ealpha)
+ theta = eta2theta(eta[,2], .link.theta, earg= .etheta)
if(residuals) stop("loglikelihood residuals not implemented yet") else
sum(w*(log(theta*alpha) + alpha*log(extra$y0) -(alpha+1)*log(y)+
(theta-1) * log(1 - (y/extra$y0)^(-alpha ))))
}, list( .link.theta=link.theta, .link.alpha=link.alpha ))),
vfamily=c("stoppa"),
deriv=eval(substitute(expression({
- alpha = eta2theta(eta[,1], .link.alpha)
- theta = eta2theta(eta[,2], .link.theta)
+ alpha = eta2theta(eta[,1], .link.alpha, earg= .ealpha)
+ theta = eta2theta(eta[,2], .link.theta, earg= .etheta)
temp8 = (y / extra$y0)^(-alpha)
temp8a = log(temp8)
temp8b = log(1-temp8)
dl.dalpha = 1/alpha - log(y/extra$y0) + (theta-1) * temp8 *
log(y / extra$y0) / (1-temp8)
dl.dtheta = 1/theta + temp8b
- dtheta.deta = dtheta.deta(theta, .link.theta)
- dalpha.deta = dtheta.deta(alpha, .link.alpha)
- w * cbind( dl.dalpha * dalpha.deta, dl.dtheta * dtheta.deta )
+ dalpha.deta = dtheta.deta(alpha, .link.alpha, earg= .ealpha)
+ dTHETA.deta = dtheta.deta(theta, .link.theta, earg= .etheta)
+ w * cbind( dl.dalpha * dalpha.deta, dl.dtheta * dTHETA.deta )
}), list( .link.theta=link.theta, .link.alpha=link.alpha ))),
weight=eval(substitute(expression({
ed2l.dalpha = 1/alpha^2 + theta * (2 * log(extra$y0) * (digamma(2)-
@@ -4490,8 +4799,8 @@ stoppa = function(y0,
ed2l.dalphatheta = (digamma(2)-digamma(theta+2)) / (alpha*(theta+1))
wz = matrix(as.numeric(NA), n, dimm(M)) #3=dimm(M)
wz[,iam(1,1,M)] = ed2l.dalpha * dalpha.deta^2
- wz[,iam(2,2,M)] = ed2l.dtheta * dtheta.deta^2
- wz[,iam(1,2,M)] = ed2l.dalpha * dtheta.deta * dalpha.deta
+ wz[,iam(2,2,M)] = ed2l.dtheta * dTHETA.deta^2
+ wz[,iam(1,2,M)] = ed2l.dalpha * dTHETA.deta * dalpha.deta
wz = w * wz
wz
}), list( .link.theta=link.theta, .link.alpha=link.alpha ))) )
@@ -4552,6 +4861,7 @@ rlino = function(n, shape1, shape2, lambda=1) {
lino = function(lshape1="loge",
lshape2="loge",
llambda="loge",
+ eshape1=list(), eshape2=list(), elambda=list(),
ishape1=NULL, ishape2=NULL, ilambda=1, zero=NULL)
{
if(mode(lshape1) != "character" && mode(lshape1) != "name")
@@ -4564,21 +4874,25 @@ lino = function(lshape1="loge",
stop("bad input for argument \"zero\"")
if(!is.Numeric(ilambda, positive=TRUE))
stop("bad input for argument \"ilambda\"")
+ if(!is.list(eshape1)) eshape1 = list()
+ if(!is.list(eshape2)) eshape2 = list()
+ if(!is.list(elambda)) elambda = list()
new("vglmff",
blurb=c("Generalized Beta distribution (Libby and Novick, 1982)\n\n",
"Links: ",
- namesof("shape1", lshape1), ", ",
- namesof("shape2", lshape2), ", ",
- namesof("lambda", llambda), "\n",
+ namesof("shape1", lshape1, earg=eshape1), ", ",
+ namesof("shape2", lshape2, earg=eshape2), ", ",
+ namesof("lambda", llambda, earg=elambda), "\n",
"Mean: something complicated"),
constraints=eval(substitute(expression({
constraints = cm.zero.vgam(constraints, x, .zero, M)
}), list( .zero=zero ))),
initialize=eval(substitute(expression({
- predictors.names = c(namesof("shape1", .lshape1, tag= FALSE),
- namesof("shape2", .lshape2, tag= FALSE),
- namesof("lambda", .llambda, tag= FALSE))
+ predictors.names =
+ c(namesof("shape1", .lshape1, earg=.eshape1, tag=FALSE),
+ namesof("shape2", .lshape2, earg=.eshape2, tag=FALSE),
+ namesof("lambda", .llambda, earg=.elambda, tag=FALSE))
if(min(y) <= 0 || max(y) >= 1)
stop("values of the response must be between 0 and 1 (0,1)")
if(ncol(cbind(y)) != 1)
@@ -4594,48 +4908,54 @@ lino = function(lshape1="loge",
sh1.init = rep((mean2 - 1) / (mean2 - 1/mean1), length=n)
if(!is.Numeric(sh2.init))
sh2.init = rep(sh1.init * (1-mean1) / mean1, length=n)
- etastart = cbind(theta2eta(sh1.init, .lshape1),
- theta2eta(sh2.init, .lshape2),
- theta2eta(lambda.init, .llambda))
+ etastart = cbind(theta2eta(sh1.init, .lshape1, earg= .eshape1),
+ theta2eta(sh2.init, .lshape2, earg= .eshape2),
+ theta2eta(lambda.init, .llambda, earg= .elambda))
}
}), list( .lshape1=lshape1, .lshape2=lshape2, .llambda=llambda,
+ .eshape1=eshape1, .eshape2=eshape2, .elambda=elambda,
.ishape1=ishape1, .ishape2=ishape2, .ilambda=ilambda ))),
inverse=eval(substitute(function(eta, extra=NULL) {
- sh1 = eta2theta(eta[,1], .lshape1)
- sh2 = eta2theta(eta[,2], .lshape2)
- lambda = eta2theta(eta[,3], .llambda)
+ sh1 = eta2theta(eta[,1], .lshape1, earg= .eshape1)
+ sh2 = eta2theta(eta[,2], .lshape2, earg= .eshape2)
+ lambda = eta2theta(eta[,3], .llambda, earg= .elambda)
rep(as.numeric(NA), length=nrow(eta))
- }, list( .lshape1=lshape1, .lshape2=lshape2, .llambda=llambda ))),
+ }, list( .lshape1=lshape1, .lshape2=lshape2, .llambda=llambda,
+ .eshape1=eshape1, .eshape2=eshape2, .elambda=elambda ))),
last=eval(substitute(expression({
misc$link = c(shape1 = .lshape1, shape2 = .lshape2, lambda = .llambda)
- }), list( .lshape1=lshape1, .lshape2=lshape2, .llambda=llambda ))),
+ misc$earg =list(shape1 = .eshape1, shape2 = .eshape2, lambda = .elambda)
+ }), list( .lshape1=lshape1, .lshape2=lshape2, .llambda=llambda,
+ .eshape1=eshape1, .eshape2=eshape2, .elambda=elambda ))),
loglikelihood=eval(substitute(
function(mu, y, w, residuals= FALSE,eta, extra=NULL) {
- sh1 = eta2theta(eta[,1], .lshape1)
- sh2 = eta2theta(eta[,2], .lshape2)
- lambda = eta2theta(eta[,3], .llambda)
+ sh1 = eta2theta(eta[,1], .lshape1, earg= .eshape1)
+ sh2 = eta2theta(eta[,2], .lshape2, earg= .eshape2)
+ lambda = eta2theta(eta[,3], .llambda, earg= .elambda)
if(!is.R()) lbeta = function(a,b) lgamma(a) + lgamma(b) - lgamma(a+b)
if(residuals) stop("loglikelihood residuals not implemented yet") else
sum(w*(sh1*log(lambda) + (sh1-1)*log(y) + (sh2-1)*log(1-y) -
lbeta(sh1,sh2) -(sh1+sh2)*log(1-(1-lambda)*y)) )
- }, list( .lshape1=lshape1, .lshape2=lshape2, .llambda=llambda ))),
+ }, list( .lshape1=lshape1, .lshape2=lshape2, .llambda=llambda,
+ .eshape1=eshape1, .eshape2=eshape2, .elambda=elambda ))),
vfamily=c("lino"),
deriv=eval(substitute(expression({
- sh1 = eta2theta(eta[,1], .lshape1)
- sh2 = eta2theta(eta[,2], .lshape2)
- lambda = eta2theta(eta[,3], .llambda)
+ sh1 = eta2theta(eta[,1], .lshape1, earg= .eshape1)
+ sh2 = eta2theta(eta[,2], .lshape2, earg= .eshape2)
+ lambda = eta2theta(eta[,3], .llambda, earg= .elambda)
temp1 = log(1 - (1-lambda) * y)
temp2 = digamma(sh1+sh2)
dl.dsh1 = log(lambda) + log(y) - digamma(sh1) + temp2 - temp1
dl.dsh2 = log(1-y) - digamma(sh2) + temp2 - temp1
dl.dlambda = sh1/lambda - (sh1+sh2) * y / (1 - (1-lambda) * y)
- dsh1.deta = dtheta.deta(sh1, .lshape1)
- dsh2.deta = dtheta.deta(sh2, .lshape2)
- dlambda.deta = dtheta.deta(lambda, .llambda)
+ dsh1.deta = dtheta.deta(sh1, .lshape1, earg= .eshape1)
+ dsh2.deta = dtheta.deta(sh2, .lshape2, earg= .eshape2)
+ dlambda.deta = dtheta.deta(lambda, .llambda, earg= .elambda)
w * cbind( dl.dsh1 * dsh1.deta,
dl.dsh2 * dsh2.deta,
dl.dlambda * dlambda.deta)
- }), list( .lshape1=lshape1, .lshape2=lshape2, .llambda=llambda ))),
+ }), list( .lshape1=lshape1, .lshape2=lshape2, .llambda=llambda,
+ .eshape1=eshape1, .eshape2=eshape2, .elambda=elambda ))),
weight=eval(substitute(expression({
if(!is.R()) beta = function(a,b) (gamma(a) / gamma(a+b)) * gamma(b)
temp3 = trigamma(sh1+sh2)
@@ -4654,7 +4974,8 @@ lino = function(lshape1="loge",
wz[,iam(2,3,M)] = ed2l.dsh2lambda * dsh2.deta * dlambda.deta
wz = w * wz
wz
- }), list( .lshape1=lshape1, .lshape2=lshape2, .llambda=llambda ))))
+ }), list( .lshape1=lshape1, .lshape2=lshape2, .llambda=llambda,
+ .eshape1=eshape1, .eshape2=eshape2, .elambda=elambda ))))
}
@@ -4662,6 +4983,7 @@ genbetaII= function(link.a="loge",
link.scale="loge",
link.p="loge",
link.q="loge",
+ earg.a=list(), earg.scale=list(), earg.p=list(), earg.q=list(),
init.a=NULL,
init.scale=NULL,
init.p=1.0,
@@ -4679,23 +5001,28 @@ genbetaII= function(link.a="loge",
link.q = as.character(substitute(link.q))
if(length(zero) && !is.Numeric(zero, integer=TRUE, posit=TRUE))
stop("bad input for argument \"zero\"")
+ if(!is.list(earg.a)) earg.a = list()
+ if(!is.list(earg.scale)) earg.scale = list()
+ if(!is.list(earg.p)) earg.p = list()
+ if(!is.list(earg.q)) earg.q = list()
new("vglmff",
blurb=c("Generalized Beta II distribution\n\n",
"Links: ",
- namesof("a", link.a), ", ",
- namesof("scale", link.scale), ", ",
- namesof("p", link.p), ", ",
- namesof("q", link.q), "\n",
+ namesof("a", link.a, earg=earg.a), ", ",
+ namesof("scale", link.scale, earg=earg.scale), ", ",
+ namesof("p", link.p, earg=earg.p), ", ",
+ namesof("q", link.q, earg=earg.q), "\n",
"Mean: scale*gamma(p + 1/a)*gamma(q - 1/a)/(gamma(p)*gamma(q))"),
constraints=eval(substitute(expression({
constraints = cm.zero.vgam(constraints, x, .zero, M)
}), list( .zero=zero ))),
initialize=eval(substitute(expression({
- predictors.names = c(namesof("a", .link.a, tag= FALSE),
- namesof("scale", .link.scale, tag= FALSE),
- namesof("p", .link.p, tag= FALSE),
- namesof("q", .link.q, tag= FALSE))
+ predictors.names =
+ c(namesof("a", .link.a, earg=.earg.a, tag=FALSE),
+ namesof("scale", .link.scale, earg=.earg.scale, tag=FALSE),
+ namesof("p", .link.p, earg=.earg.p, tag=FALSE),
+ namesof("q", .link.q, earg=.earg.q, tag=FALSE))
if(!length(.init.a) || !length(.init.scale)) {
qvec = c(.25, .5, .75) # Arbitrary; could be made an argument
@@ -4710,46 +5037,56 @@ genbetaII= function(link.a="loge",
exp(fit0$coef[1]), length=n)
qq = rep(if(length(.init.q)) .init.q else 1.0, length=n)
parg = rep(if(length(.init.p)) .init.p else 1.0, length=n)
- etastart = cbind(theta2eta(aa, .link.a),
- theta2eta(scale, .link.scale),
- theta2eta(parg, .link.p),
- theta2eta(qq, .link.q))
+ etastart = cbind(theta2eta(aa, .link.a, earg= .earg.a),
+ theta2eta(scale, .link.scale, earg= .earg.scale),
+ theta2eta(parg, .link.p, earg= .earg.p),
+ theta2eta(qq, .link.q, earg= .earg.q))
}
}), list( .link.a=link.a, .link.scale=link.scale,
.link.p=link.p, .link.q=link.q,
+ .earg.a=earg.a, .earg.scale=earg.scale,
+ .earg.p=earg.p, .earg.q=earg.q,
.init.a=init.a, .init.scale=init.scale,
.init.p=init.p, .init.q=init.q ))),
inverse=eval(substitute(function(eta, extra=NULL) {
- aa = eta2theta(eta[,1], .link.a)
- scale = eta2theta(eta[,2], .link.scale)
- parg = eta2theta(eta[,3], .link.p)
- qq = eta2theta(eta[,4], .link.q)
+ aa = eta2theta(eta[,1], .link.a, earg= .earg.a)
+ scale = eta2theta(eta[,2], .link.scale, earg= .earg.scale)
+ parg = eta2theta(eta[,3], .link.p, earg= .earg.p)
+ qq = eta2theta(eta[,4], .link.q, earg= .earg.q)
scale*gamma(parg + 1/aa)*gamma(qq-1/aa)/(gamma(parg)*gamma(qq))
}, list( .link.a=link.a, .link.scale=link.scale,
+ .earg.a=earg.a, .earg.scale=earg.scale,
+ .earg.p=earg.p, .earg.q=earg.q,
.link.p=link.p, .link.q=link.q ))),
last=eval(substitute(expression({
misc$link = c(a= .link.a, scale= .link.scale,
p= .link.p, q= .link.q)
+ misc$earg = list(a= .earg.a, scale= .earg.scale,
+ p= .earg.p, q= .earg.q)
}), list( .link.a=link.a, .link.scale=link.scale,
+ .earg.a=earg.a, .earg.scale=earg.scale,
+ .earg.p=earg.p, .earg.q=earg.q,
.link.p=link.p, .link.q=link.q ))),
loglikelihood=eval(substitute(
function(mu, y, w, residuals= FALSE,eta, extra=NULL) {
- aa = eta2theta(eta[,1], .link.a)
- scale = eta2theta(eta[,2], .link.scale)
- parg = eta2theta(eta[,3], .link.p)
- qq = eta2theta(eta[,4], .link.q)
+ aa = eta2theta(eta[,1], .link.a, earg= .earg.a)
+ scale = eta2theta(eta[,2], .link.scale, earg= .earg.scale)
+ parg = eta2theta(eta[,3], .link.p, earg= .earg.p)
+ qq = eta2theta(eta[,4], .link.q, earg= .earg.q)
if(residuals) stop("loglikelihood residuals not implemented yet") else
sum(w*(log(aa) + (aa*parg-1)*log(y) - aa*parg*log(scale) +
(if(is.R()) -lbeta(parg, qq) else lgamma(parg+qq)-lgamma(parg)-lgamma(qq))-
(parg+qq)*log(1 + (y/scale)^aa )))
}, list( .link.a=link.a, .link.scale=link.scale,
+ .earg.a=earg.a, .earg.scale=earg.scale,
+ .earg.p=earg.p, .earg.q=earg.q,
.link.p=link.p, .link.q=link.q ))),
vfamily=c("genbetaII"),
deriv=eval(substitute(expression({
- aa = eta2theta(eta[,1], .link.a)
- scale = eta2theta(eta[,2], .link.scale)
- parg = eta2theta(eta[,3], .link.p)
- qq = eta2theta(eta[,4], .link.q)
+ aa = eta2theta(eta[,1], .link.a, earg= .earg.a)
+ scale = eta2theta(eta[,2], .link.scale, earg= .earg.scale)
+ parg = eta2theta(eta[,3], .link.p, earg= .earg.p)
+ qq = eta2theta(eta[,4], .link.q, earg= .earg.q)
temp1 = log(y/scale)
temp2 = (y/scale)^aa
@@ -4762,13 +5099,15 @@ genbetaII= function(link.a="loge",
dl.dscale = (aa/scale) * (-parg + (parg+qq) / (1+1/temp2))
dl.dp = aa * temp1 + temp3 - temp3a - temp4
dl.dq = temp3 - temp3b - temp4
- da.deta = dtheta.deta(aa, .link.a)
- dscale.deta = dtheta.deta(scale, .link.scale)
- dp.deta = dtheta.deta(parg, .link.p)
- dq.deta = dtheta.deta(qq, .link.q)
+ da.deta = dtheta.deta(aa, .link.a, earg= .earg.a)
+ dscale.deta = dtheta.deta(scale, .link.scale, earg= .earg.scale)
+ dp.deta = dtheta.deta(parg, .link.p, earg= .earg.p)
+ dq.deta = dtheta.deta(qq, .link.q, earg= .earg.q)
w * cbind( dl.da * da.deta, dl.dscale * dscale.deta,
dl.dp * dp.deta, dl.dq * dq.deta )
}), list( .link.a=link.a, .link.scale=link.scale,
+ .earg.a=earg.a, .earg.scale=earg.scale,
+ .earg.p=earg.p, .earg.q=earg.q,
.link.p=link.p, .link.q=link.q ))),
weight=eval(substitute(expression({
temp5 = trigamma(parg + qq)
@@ -4801,6 +5140,8 @@ genbetaII= function(link.a="loge",
wz = w * wz
wz
}), list( .link.a=link.a, .link.scale=link.scale,
+ .earg.a=earg.a, .earg.scale=earg.scale,
+ .earg.p=earg.p, .earg.q=earg.q,
.link.p=link.p, .link.q=link.q ))))
}
@@ -4956,6 +5297,7 @@ dinvparalogistic = function(x, a, scale)
sinmad = function(link.a="loge",
link.scale="loge",
link.q="loge",
+ earg.a=list(), earg.scale=list(), earg.q=list(),
init.a=NULL,
init.scale=NULL,
init.q=1.0,
@@ -4970,21 +5312,27 @@ sinmad = function(link.a="loge",
link.q = as.character(substitute(link.q))
if(length(zero) && !is.Numeric(zero, integer=TRUE, posit=TRUE))
stop("bad input for argument \"zero\"")
+ if(!is.list(earg.a)) earg.a = list()
+ if(!is.list(earg.scale)) earg.scale = list()
+ if(!is.list(earg.q)) earg.q = list()
new("vglmff",
blurb=c("Singh-Maddala distribution\n\n",
"Links: ",
- namesof("a", link.a), ", ",
- namesof("scale", link.scale), ", ",
- namesof("q", link.q), "\n",
+ namesof("a", link.a, earg=earg.a), ", ",
+ namesof("scale", link.scale, earg=earg.scale), ", ",
+ namesof("q", link.q, earg=earg.q), "\n",
"Mean: scale*gamma(1 + 1/a)*gamma(q - 1/a)/gamma(q)"),
constraints=eval(substitute(expression({
constraints = cm.zero.vgam(constraints, x, .zero, M)
}), list( .zero=zero ))),
initialize=eval(substitute(expression({
- predictors.names = c(namesof("a", .link.a, tag= FALSE),
- namesof("scale", .link.scale, tag= FALSE),
- namesof("q", .link.q, tag= FALSE))
+ if(ncol(cbind(y)) != 1)
+ stop("response must be a vector or a one-column matrix")
+ predictors.names =
+ c(namesof("a", .link.a, earg=.earg.a, tag=FALSE),
+ namesof("scale", .link.scale, earg=.earg.scale, tag=FALSE),
+ namesof("q", .link.q, earg=.earg.q, tag=FALSE))
parg = 1
if(!length(.init.a) || !length(.init.scale)) {
@@ -4999,43 +5347,52 @@ sinmad = function(link.a="loge",
scale = rep(if(length(.init.scale)) .init.scale else
exp(fit0$coef[1]), length=n)
qq = rep(if(length(.init.q)) .init.q else 1.0, length=n)
- etastart = cbind(theta2eta(aa, .link.a),
- theta2eta(scale, .link.scale),
- theta2eta(qq, .link.q))
+ etastart = cbind(theta2eta(aa, .link.a, earg= .earg.a),
+ theta2eta(scale, .link.scale, earg= .earg.scale),
+ theta2eta(qq, .link.q, earg= .earg.q))
}
}), list( .link.a=link.a, .link.scale=link.scale,
.link.q=link.q,
+ .earg.a=earg.a, .earg.scale=earg.scale,
+ .earg.q=earg.q,
.init.a=init.a, .init.scale=init.scale,
.init.q=init.q ))),
inverse=eval(substitute(function(eta, extra=NULL) {
- aa = eta2theta(eta[,1], .link.a)
- scale = eta2theta(eta[,2], .link.scale)
- qq = eta2theta(eta[,3], .link.q)
+ aa = eta2theta(eta[,1], .link.a, earg= .earg.a)
+ scale = eta2theta(eta[,2], .link.scale, earg= .earg.scale)
+ qq = eta2theta(eta[,3], .link.q, earg= .earg.q)
scale*gamma(1 + 1/aa)*gamma(qq-1/aa)/(gamma(qq))
}, list( .link.a=link.a, .link.scale=link.scale,
+ .earg.a=earg.a, .earg.scale=earg.scale,
+ .earg.q=earg.q,
.link.q=link.q ))),
last=eval(substitute(expression({
misc$link = c(a= .link.a, scale= .link.scale, q= .link.q)
+ misc$earg = list(a= .earg.a, scale= .earg.scale, q= .earg.q)
}), list( .link.a=link.a, .link.scale=link.scale,
+ .earg.a=earg.a, .earg.scale=earg.scale,
+ .earg.q=earg.q,
.link.q=link.q ))),
loglikelihood=eval(substitute(
function(mu, y, w, residuals= FALSE,eta, extra=NULL) {
- aa = eta2theta(eta[,1], .link.a)
- scale = eta2theta(eta[,2], .link.scale)
+ aa = eta2theta(eta[,1], .link.a, earg= .earg.a)
+ scale = eta2theta(eta[,2], .link.scale, earg= .earg.scale)
parg = 1
- qq = eta2theta(eta[,3], .link.q)
+ qq = eta2theta(eta[,3], .link.q, earg= .earg)
if(residuals) stop("loglikelihood residuals not implemented yet") else
sum(w*(log(aa) + (aa*parg-1)*log(y) - aa*parg*log(scale) +
(if(is.R()) -lbeta(parg, qq) else lgamma(parg+qq)-lgamma(parg)-lgamma(qq))-
(parg+qq)*log(1 + (y/scale)^aa )))
}, list( .link.a=link.a, .link.scale=link.scale,
+ .earg.a=earg.a, .earg.scale=earg.scale,
+ .earg.q=earg.q,
.link.q=link.q ))),
vfamily=c("sinmad"),
deriv=eval(substitute(expression({
- aa = eta2theta(eta[,1], .link.a)
- scale = eta2theta(eta[,2], .link.scale)
+ aa = eta2theta(eta[,1], .link.a, earg= .earg.a)
+ scale = eta2theta(eta[,2], .link.scale, earg= .earg.scale)
parg = 1
- qq = eta2theta(eta[,3], .link.q)
+ qq = eta2theta(eta[,3], .link.q, earg= .earg.q)
temp1 = log(y/scale)
temp2 = (y/scale)^aa
@@ -5045,12 +5402,14 @@ sinmad = function(link.a="loge",
dl.da = 1/aa + parg * temp1 - (parg+qq) * temp1 / (1+1/temp2)
dl.dscale = (aa/scale) * (-parg + (parg+qq) / (1+1/temp2))
dl.dq = digamma(parg + qq) - temp3b - log(1+temp2)
- da.deta = dtheta.deta(aa, .link.a)
- dscale.deta = dtheta.deta(scale, .link.scale)
- dq.deta = dtheta.deta(qq, .link.q)
+ da.deta = dtheta.deta(aa, .link.a, earg= .earg.a)
+ dscale.deta = dtheta.deta(scale, .link.scale, earg= .earg.scale)
+ dq.deta = dtheta.deta(qq, .link.q, earg= .earg.q)
w * cbind( dl.da * da.deta, dl.dscale * dscale.deta,
dl.dq * dq.deta )
}), list( .link.a=link.a, .link.scale=link.scale,
+ .earg.a=earg.a, .earg.scale=earg.scale,
+ .earg.q=earg.q,
.link.q=link.q ))),
weight=eval(substitute(expression({
ed2l.da = (1 + parg+qq + parg * qq * (trigamma(parg) + trigamma(qq) +
@@ -5072,6 +5431,8 @@ sinmad = function(link.a="loge",
wz = w * wz
wz
}), list( .link.a=link.a, .link.scale=link.scale,
+ .earg.a=earg.a, .earg.scale=earg.scale,
+ .earg.q=earg.q,
.link.q=link.q ))))
}
@@ -5079,6 +5440,7 @@ sinmad = function(link.a="loge",
dagum = function(link.a="loge",
link.scale="loge",
link.p="loge",
+ earg.a=list(), earg.scale=list(), earg.p=list(),
init.a=NULL,
init.scale=NULL,
init.p=1.0,
@@ -5093,21 +5455,27 @@ sinmad = function(link.a="loge",
link.p = as.character(substitute(link.p))
if(length(zero) && !is.Numeric(zero, integer=TRUE, posit=TRUE))
stop("bad input for argument \"zero\"")
+ if(!is.list(earg.a)) earg.a = list()
+ if(!is.list(earg.scale)) earg.scale = list()
+ if(!is.list(earg.p)) earg.p = list()
new("vglmff",
blurb=c("Dagum distribution\n\n",
"Links: ",
- namesof("a", link.a), ", ",
- namesof("scale", link.scale), ", ",
- namesof("p", link.p), "\n",
+ namesof("a", link.a, earg=earg.a), ", ",
+ namesof("scale", link.scale, earg=earg.scale), ", ",
+ namesof("p", link.p, earg=earg.p), "\n",
"Mean: scale*gamma(p + 1/a)*gamma(1 - 1/a)/gamma(p)"),
constraints=eval(substitute(expression({
constraints = cm.zero.vgam(constraints, x, .zero, M)
}), list( .zero=zero ))),
initialize=eval(substitute(expression({
- predictors.names = c(namesof("a", .link.a, tag= FALSE),
- namesof("scale", .link.scale, tag= FALSE),
- namesof("p", .link.p, tag= FALSE))
+ if(ncol(cbind(y)) != 1)
+ stop("response must be a vector or a one-column matrix")
+ predictors.names =
+ c(namesof("a", .link.a, earg=.earg.a, tag=FALSE),
+ namesof("scale", .link.scale, earg=.earg.scale, tag=FALSE),
+ namesof("p", .link.p, earg=.earg.p, tag=FALSE))
if(!length(.init.a) || !length(.init.scale)) {
qvec = c(.25, .5, .75) # Arbitrary; could be made an argument
@@ -5121,43 +5489,52 @@ sinmad = function(link.a="loge",
aa = rep(if(length(.init.a)) .init.a else -1/fit0$coef[2], length=n)
scale = rep(if(length(.init.scale)) .init.scale else
exp(fit0$coef[1]), length=n)
- etastart = cbind(theta2eta(aa, .link.a),
- theta2eta(scale, .link.scale),
- theta2eta(parg, .link.p))
+ etastart = cbind(theta2eta(aa, .link.a, earg= .earg.a),
+ theta2eta(scale, .link.scale, earg= .earg.scale),
+ theta2eta(parg, .link.p, earg= .earg.p))
}
}), list( .link.a=link.a, .link.scale=link.scale,
.link.p=link.p,
+ .earg.a=earg.a, .earg.scale=earg.scale,
+ .earg.p=earg.p,
.init.a=init.a, .init.scale=init.scale,
.init.p=init.p ))),
inverse=eval(substitute(function(eta, extra=NULL) {
- aa = eta2theta(eta[,1], .link.a)
- scale = eta2theta(eta[,2], .link.scale)
- parg = eta2theta(eta[,3], .link.p)
+ aa = eta2theta(eta[,1], .link.a, earg= .earg.a)
+ scale = eta2theta(eta[,2], .link.scale, earg= .earg.scale)
+ parg = eta2theta(eta[,3], .link.p, earg= .earg.p)
qq = 1
scale*gamma(parg + 1/aa)*gamma(qq-1/aa)/(gamma(parg)*gamma(qq))
}, list( .link.a=link.a, .link.scale=link.scale,
+ .earg.a=earg.a, .earg.scale=earg.scale,
+ .earg.p=earg.p,
.link.p=link.p ))),
last=eval(substitute(expression({
misc$link = c(a= .link.a, scale= .link.scale, p= .link.p )
+ misc$earg = list(a= .earg.a, scale= .earg.scale, p= .earg.p)
}), list( .link.a=link.a, .link.scale=link.scale,
+ .earg.a=earg.a, .earg.scale=earg.scale,
+ .earg.p=earg.p,
.link.p=link.p ))),
loglikelihood=eval(substitute(
function(mu, y, w, residuals= FALSE,eta, extra=NULL) {
- aa = eta2theta(eta[,1], .link.a)
- scale = eta2theta(eta[,2], .link.scale)
- parg = eta2theta(eta[,3], .link.p)
+ aa = eta2theta(eta[,1], .link.a, earg= .earg.a)
+ scale = eta2theta(eta[,2], .link.scale, earg= .earg.scale)
+ parg = eta2theta(eta[,3], .link.p, earg= .earg.p)
qq = 1
if(residuals) stop("loglikelihood residuals not implemented yet") else
sum(w*(log(aa) + (aa*parg-1)*log(y) - aa*parg*log(scale) +
(if(is.R()) -lbeta(parg, qq) else lgamma(parg+qq)-lgamma(parg)-lgamma(qq))-
(parg+qq)*log(1 + (y/scale)^aa )))
}, list( .link.a=link.a, .link.scale=link.scale,
+ .earg.a=earg.a, .earg.scale=earg.scale,
+ .earg.p=earg.p,
.link.p=link.p ))),
vfamily=c("dagum"),
deriv=eval(substitute(expression({
- aa = eta2theta(eta[,1], .link.a)
- scale = eta2theta(eta[,2], .link.scale)
- parg = eta2theta(eta[,3], .link.p)
+ aa = eta2theta(eta[,1], .link.a, earg= .earg.a)
+ scale = eta2theta(eta[,2], .link.scale, earg= .earg.scale)
+ parg = eta2theta(eta[,3], .link.p, earg= .earg.p)
qq = 1
temp1 = log(y/scale)
@@ -5168,12 +5545,14 @@ sinmad = function(link.a="loge",
dl.da = 1/aa + parg * temp1 - (parg+qq) * temp1 / (1+1/temp2)
dl.dscale = (aa/scale) * (-parg + (parg+qq) / (1+1/temp2))
dl.dp = aa * temp1 + digamma(parg + qq) - temp3a - log(1+temp2)
- da.deta = dtheta.deta(aa, .link.a)
- dscale.deta = dtheta.deta(scale, .link.scale)
- dp.deta = dtheta.deta(parg, .link.p)
+ da.deta = dtheta.deta(aa, .link.a, earg= .earg.a)
+ dscale.deta = dtheta.deta(scale, .link.scale, earg= .earg.scale)
+ dp.deta = dtheta.deta(parg, .link.p, earg= .earg.p)
w * cbind( dl.da * da.deta, dl.dscale * dscale.deta,
dl.dp * dp.deta )
}), list( .link.a=link.a, .link.scale=link.scale,
+ .earg.a=earg.a, .earg.scale=earg.scale,
+ .earg.p=earg.p,
.link.p=link.p ))),
weight=eval(substitute(expression({
ed2l.da = (1 + parg+qq + parg * qq * (trigamma(parg) + trigamma(qq) +
@@ -5195,6 +5574,8 @@ sinmad = function(link.a="loge",
wz = w * wz
wz
}), list( .link.a=link.a, .link.scale=link.scale,
+ .earg.a=earg.a, .earg.scale=earg.scale,
+ .earg.p=earg.p,
.link.p=link.p ))))
}
@@ -5203,6 +5584,7 @@ sinmad = function(link.a="loge",
betaII= function(link.scale="loge",
link.p="loge",
link.q="loge",
+ earg.scale=list(), earg.p=list(), earg.q=list(),
init.scale=NULL,
init.p=1.0,
init.q=1.0,
@@ -5217,21 +5599,27 @@ betaII= function(link.scale="loge",
link.q = as.character(substitute(link.q))
if(length(zero) && !is.Numeric(zero, integer=TRUE, posit=TRUE))
stop("bad input for argument \"zero\"")
+ if(!is.list(earg.scale)) earg.scale = list()
+ if(!is.list(earg.p)) earg.p = list()
+ if(!is.list(earg.q)) earg.q = list()
new("vglmff",
blurb=c("Beta II distribution\n\n",
"Links: ",
- namesof("scale", link.scale), ", ",
- namesof("p", link.p), ", ",
- namesof("q", link.q), "\n",
+ namesof("scale", link.scale, earg=earg.scale), ", ",
+ namesof("p", link.p, earg=earg.p), ", ",
+ namesof("q", link.q, earg=earg.q), "\n",
"Mean: scale*gamma(p + 1)*gamma(q - 1)/(gamma(p)*gamma(q))"),
constraints=eval(substitute(expression({
constraints = cm.zero.vgam(constraints, x, .zero, M)
}), list( .zero=zero ))),
initialize=eval(substitute(expression({
- predictors.names = c(namesof("scale", .link.scale, tag= FALSE),
- namesof("p", .link.p, tag= FALSE),
- namesof("q", .link.q, tag= FALSE))
+ if(ncol(cbind(y)) != 1)
+ stop("response must be a vector or a one-column matrix")
+ predictors.names =
+ c(namesof("scale", .link.scale, earg=.earg.scale, tag=FALSE),
+ namesof("p", .link.p, earg=.earg.p, tag=FALSE),
+ namesof("q", .link.q, earg=.earg.q, tag=FALSE))
if(!length(.init.scale)) {
qvec = c(.25, .5, .75) # Arbitrary; could be made an argument
@@ -5245,44 +5633,53 @@ betaII= function(link.scale="loge",
exp(fit0$coef[1]), length=n)
qq = rep(if(length(.init.q)) .init.q else 1.0, length=n)
parg = rep(if(length(.init.p)) .init.p else 1.0, length=n)
- etastart = cbind(theta2eta(scale, .link.scale),
- theta2eta(parg, .link.p),
- theta2eta(qq, .link.q))
+ etastart = cbind(theta2eta(scale, .link.scale, earg= .earg.scale),
+ theta2eta(parg, .link.p, earg= .earg.p),
+ theta2eta(qq, .link.q, earg= .earg.q))
}
}), list( .link.scale=link.scale,
.link.p=link.p, .link.q=link.q,
+ .earg.scale=earg.scale,
+ .earg.p=earg.p, .earg.q=earg.q,
.init.scale=init.scale,
.init.p=init.p, .init.q=init.q ))),
inverse=eval(substitute(function(eta, extra=NULL) {
aa = 1
- scale = eta2theta(eta[,1], .link.scale)
- parg = eta2theta(eta[,2], .link.p)
- qq = eta2theta(eta[,3], .link.q)
+ scale = eta2theta(eta[,1], .link.scale, earg= .earg.scale)
+ parg = eta2theta(eta[,2], .link.p, earg= .earg.p)
+ qq = eta2theta(eta[,3], .link.q, earg= .earg.q)
scale*gamma(parg + 1/aa)*gamma(qq-1/aa)/(gamma(parg)*gamma(qq))
}, list( .link.scale=link.scale,
+ .earg.scale=earg.scale,
+ .earg.p=earg.p, .earg.q=earg.q,
.link.p=link.p, .link.q=link.q ))),
last=eval(substitute(expression({
misc$link = c(scale= .link.scale, p= .link.p, q= .link.q)
+ misc$earg = list(scale= .earg.scale, p= .earg.p, q= .earg.q)
}), list( .link.scale=link.scale,
+ .earg.scale=earg.scale,
+ .earg.p=earg.p, .earg.q=earg.q,
.link.p=link.p, .link.q=link.q ))),
loglikelihood=eval(substitute(
function(mu, y, w, residuals= FALSE,eta, extra=NULL) {
aa = 1
- scale = eta2theta(eta[,1], .link.scale)
- parg = eta2theta(eta[,2], .link.p)
- qq = eta2theta(eta[,3], .link.q)
+ scale = eta2theta(eta[,1], .link.scale, earg= .earg.scale)
+ parg = eta2theta(eta[,2], .link.p, earg= .earg.p)
+ qq = eta2theta(eta[,3], .link.q, earg= .earg.q)
if(residuals) stop("loglikelihood residuals not implemented yet") else
sum(w*(log(aa) + (aa*parg-1)*log(y) - aa*parg*log(scale) +
(if(is.R()) -lbeta(parg, qq) else lgamma(parg+qq)-lgamma(parg)-lgamma(qq))-
(parg+qq)*log(1 + (y/scale)^aa )))
}, list( .link.scale=link.scale,
+ .earg.scale=earg.scale,
+ .earg.p=earg.p, .earg.q=earg.q,
.link.p=link.p, .link.q=link.q ))),
vfamily=c("betaII"),
deriv=eval(substitute(expression({
aa = 1
- scale = eta2theta(eta[,1], .link.scale)
- parg = eta2theta(eta[,2], .link.p)
- qq = eta2theta(eta[,3], .link.q)
+ scale = eta2theta(eta[,1], .link.scale, earg= .earg.scale)
+ parg = eta2theta(eta[,2], .link.p, earg= .earg.p)
+ qq = eta2theta(eta[,3], .link.q, earg= .earg.q)
temp1 = log(y/scale)
temp2 = (y/scale)^aa
@@ -5294,12 +5691,14 @@ betaII= function(link.scale="loge",
dl.dscale = (aa/scale) * (-parg + (parg+qq) / (1+1/temp2))
dl.dp = aa * temp1 + temp3 - temp3a - temp4
dl.dq = temp3 - temp3b - temp4
- dscale.deta = dtheta.deta(scale, .link.scale)
- dp.deta = dtheta.deta(parg, .link.p)
- dq.deta = dtheta.deta(qq, .link.q)
+ dscale.deta = dtheta.deta(scale, .link.scale, earg= .earg.scale)
+ dp.deta = dtheta.deta(parg, .link.p, earg= .earg.p)
+ dq.deta = dtheta.deta(qq, .link.q, earg= .earg.q)
w * cbind( dl.dscale * dscale.deta,
dl.dp * dp.deta, dl.dq * dq.deta )
}), list( .link.scale=link.scale,
+ .earg.scale=earg.scale,
+ .earg.p=earg.p, .earg.q=earg.q,
.link.p=link.p, .link.q=link.q ))),
weight=eval(substitute(expression({
temp5 = trigamma(parg + qq)
@@ -5319,6 +5718,8 @@ betaII= function(link.scale="loge",
wz = w * wz
wz
}), list( .link.scale=link.scale,
+ .earg.scale=earg.scale,
+ .earg.p=earg.p, .earg.q=earg.q,
.link.p=link.p, .link.q=link.q ))))
}
@@ -5326,6 +5727,7 @@ betaII= function(link.scale="loge",
lomax = function(link.scale="loge",
link.q="loge",
+ earg.scale=list(), earg.q=list(),
init.scale=NULL,
init.q=1.0,
zero=NULL)
@@ -5337,19 +5739,24 @@ lomax = function(link.scale="loge",
link.q = as.character(substitute(link.q))
if(length(zero) && !is.Numeric(zero, integer=TRUE, posit=TRUE))
stop("bad input for argument \"zero\"")
+ if(!is.list(earg.scale)) earg.scale = list()
+ if(!is.list(earg.q)) earg.q = list()
new("vglmff",
blurb=c("Lomax distribution\n\n",
"Links: ",
- namesof("scale", link.scale), ", ",
- namesof("q", link.q), "\n",
+ namesof("scale", link.scale, earg=earg.scale), ", ",
+ namesof("q", link.q, earg=earg.q), "\n",
"Mean: scale/(q-1)"),
constraints=eval(substitute(expression({
constraints = cm.zero.vgam(constraints, x, .zero, M)
}), list( .zero=zero ))),
initialize=eval(substitute(expression({
- predictors.names = c(namesof("scale", .link.scale, tag= FALSE),
- namesof("q", .link.q, tag= FALSE))
+ if(ncol(cbind(y)) != 1)
+ stop("response must be a vector or a one-column matrix")
+ predictors.names =
+ c(namesof("scale", .link.scale, earg=.earg.scale, tag=FALSE),
+ namesof("q", .link.q, earg=.earg.q, tag=FALSE))
aa = parg = 1
if(!length(.init.scale)) {
@@ -5361,51 +5768,63 @@ lomax = function(link.scale="loge",
if(!length(etastart)) {
qq = rep(if(length(.init.q)) .init.q else 1.0, length=n)
- scale = rep(if(length(.init.scale)) .init.scale else exp(fit0$coef[1]), length=n)
- etastart = cbind(theta2eta(scale, .link.scale),
- theta2eta(qq, .link.q))
+ scale = rep(if(length(.init.scale)) .init.scale else
+ exp(fit0$coef[1]), length=n)
+ etastart = cbind(theta2eta(scale, .link.scale, earg= .earg.scale),
+ theta2eta(qq, .link.q, earg= .earg.q))
}
}), list( .link.scale=link.scale,
.link.q=link.q,
+ .earg.scale=earg.scale,
+ .earg.q=earg.q,
.init.scale=init.scale,
.init.q=init.q ))),
inverse=eval(substitute(function(eta, extra=NULL) {
- scale = eta2theta(eta[,1], .link.scale)
- qq = eta2theta(eta[,2], .link.q)
+ scale = eta2theta(eta[,1], .link.scale, earg= .earg.scale)
+ qq = eta2theta(eta[,2], .link.q, earg= .earg.q)
scale/(qq-1)
}, list( .link.scale=link.scale,
+ .earg.scale=earg.scale,
+ .earg.q=earg.q,
.link.q=link.q ))),
last=eval(substitute(expression({
misc$link = c(scale= .link.scale, q= .link.q)
+ misc$earg = list(scale= .earg.scale, q= .earg.q)
}), list( .link.scale=link.scale,
+ .earg.scale=earg.scale,
+ .earg.q=earg.q,
.link.q=link.q ))),
loglikelihood=eval(substitute(
function(mu, y, w, residuals= FALSE,eta, extra=NULL) {
aa = 1
- scale = eta2theta(eta[,1], .link.scale)
+ scale = eta2theta(eta[,1], .link.scale, earg= .earg.scale)
parg = 1
- qq = eta2theta(eta[,2], .link.q)
+ qq = eta2theta(eta[,2], .link.q, earg= .earg.q)
if(residuals) stop("loglikelihood residuals not implemented yet") else
sum(w*(log(aa) + (aa*parg-1)*log(y) - aa*parg*log(scale) +
(if(is.R()) -lbeta(parg, qq) else lgamma(parg+qq)-lgamma(parg)-lgamma(qq))-
(parg+qq)*log(1 + (y/scale)^aa )))
}, list( .link.scale=link.scale,
+ .earg.scale=earg.scale,
+ .earg.q=earg.q,
.link.q=link.q ))),
vfamily=c("lomax"),
deriv=eval(substitute(expression({
aa = 1
- scale = eta2theta(eta[,1], .link.scale)
+ scale = eta2theta(eta[,1], .link.scale, earg= .earg.scale)
parg = 1
- qq = eta2theta(eta[,2], .link.q)
+ qq = eta2theta(eta[,2], .link.q, earg= .earg.q)
temp2 = (y/scale)^aa
dl.dscale = (aa/scale) * (-parg + (parg+qq) / (1+1/temp2))
dl.dq = digamma(parg + qq) - digamma(qq) - log(1+temp2)
- dscale.deta = dtheta.deta(scale, .link.scale)
- dq.deta = dtheta.deta(qq, .link.q)
+ dscale.deta = dtheta.deta(scale, .link.scale, earg= .earg.scale)
+ dq.deta = dtheta.deta(qq, .link.q, earg= .earg.q)
w * cbind( dl.dscale * dscale.deta,
dl.dq * dq.deta )
}), list( .link.scale=link.scale,
+ .earg.scale=earg.scale,
+ .earg.q=earg.q,
.link.q=link.q ))),
weight=eval(substitute(expression({
ed2l.dscale = aa^2 * parg * qq / (scale^2 * (1+parg+qq))
@@ -5418,12 +5837,15 @@ lomax = function(link.scale="loge",
wz = w * wz
wz
}), list( .link.scale=link.scale,
+ .earg.scale=earg.scale,
+ .earg.q=earg.q,
.link.q=link.q ))))
}
fisk = function(link.a="loge",
link.scale="loge",
+ earg.a=list(), earg.scale=list(),
init.a=NULL,
init.scale=NULL,
zero=NULL)
@@ -5435,19 +5857,22 @@ lomax = function(link.scale="loge",
link.scale = as.character(substitute(link.scale))
if(length(zero) && !is.Numeric(zero, integer=TRUE, posit=TRUE))
stop("bad input for argument \"zero\"")
+ if(!is.list(earg.a)) earg.a = list()
+ if(!is.list(earg.scale)) earg.scale = list()
new("vglmff",
blurb=c("Fisk distribution\n\n",
"Links: ",
- namesof("a", link.a), ", ",
- namesof("scale", link.scale), "\n",
+ namesof("a", link.a, earg=earg.a), ", ",
+ namesof("scale", link.scale, earg=earg.scale), "\n",
"Mean: scale * gamma(1 + 1/a) * gamma(1 - 1/a)"),
constraints=eval(substitute(expression({
constraints = cm.zero.vgam(constraints, x, .zero, M)
}), list( .zero=zero ))),
initialize=eval(substitute(expression({
- predictors.names = c(namesof("a", .link.a, tag= FALSE),
- namesof("scale", .link.scale, tag= FALSE))
+ predictors.names =
+ c(namesof("a", .link.a, earg=.earg.a, tag=FALSE),
+ namesof("scale", .link.scale, earg=.earg.scale, tag=FALSE))
qq = parg = 1
if(!length(.init.scale)) {
@@ -5458,38 +5883,44 @@ lomax = function(link.scale="loge",
if(!length(etastart)) {
aa = rep(if(length(.init.a)) .init.a else -1/fit0$coef[2], length=n)
- scale = rep(if(length(.init.scale)) .init.scale else exp(fit0$coef[1]), length=n)
- etastart = cbind(theta2eta(aa, .link.a),
- theta2eta(scale, .link.scale))
+ scale = rep(if(length(.init.scale)) .init.scale else
+ exp(fit0$coef[1]), length=n)
+ etastart = cbind(theta2eta(aa, .link.a, earg= .earg.a),
+ theta2eta(scale, .link.scale, earg= .earg.scale))
}
}), list( .link.a=link.a, .link.scale=link.scale,
+ .earg.a=earg.a, .earg.scale=earg.scale,
.init.a=init.a, .init.scale=init.scale
))),
inverse=eval(substitute(function(eta, extra=NULL) {
- aa = eta2theta(eta[,1], .link.a)
- scale = eta2theta(eta[,2], .link.scale)
+ aa = eta2theta(eta[,1], .link.a, earg= .earg.a)
+ scale = eta2theta(eta[,2], .link.scale, earg= .earg.scale)
qq = 1
scale*gamma(1 + 1/aa)*gamma(1-1/aa)
- }, list( .link.a=link.a, .link.scale=link.scale
+ }, list( .link.a=link.a, .link.scale=link.scale,
+ .earg.a=earg.a, .earg.scale=earg.scale
))),
last=eval(substitute(expression({
misc$link = c(a= .link.a, scale= .link.scale)
- }), list( .link.a=link.a, .link.scale=link.scale
+ misc$earg = list(a= .earg.a, scale= .earg.scale)
+ }), list( .link.a=link.a, .link.scale=link.scale,
+ .earg.a=earg.a, .earg.scale=earg.scale
))),
loglikelihood=eval(substitute(
function(mu, y, w, residuals= FALSE,eta, extra=NULL) {
- aa = eta2theta(eta[,1], .link.a)
- scale = eta2theta(eta[,2], .link.scale)
+ aa = eta2theta(eta[,1], .link.a, earg= .earg)
+ scale = eta2theta(eta[,2], .link.scale, earg= .earg.scale)
parg = qq = 1
if(residuals) stop("loglikelihood residuals not implemented yet") else
sum(w*(log(aa) + (aa*parg-1)*log(y) - aa*parg*log(scale) +
(if(is.R()) -lbeta(parg, qq) else lgamma(parg+qq)-lgamma(parg)-lgamma(qq))-
(parg+qq)*log(1 + (y/scale)^aa )))
- }, list( .link.a=link.a, .link.scale=link.scale ))),
+ }, list( .link.a=link.a, .link.scale=link.scale,
+ .earg.a=earg.a, .earg.scale=earg.scale ))),
vfamily=c("fisk"),
deriv=eval(substitute(expression({
- aa = eta2theta(eta[,1], .link.a)
- scale = eta2theta(eta[,2], .link.scale)
+ aa = eta2theta(eta[,1], .link.a, earg= .earg.a)
+ scale = eta2theta(eta[,2], .link.scale, earg= .earg.scale)
parg = qq = 1
temp1 = log(y/scale)
@@ -5499,10 +5930,11 @@ lomax = function(link.scale="loge",
dl.da = 1/aa + parg * temp1 - (parg+qq) * temp1 / (1+1/temp2)
dl.dscale = (aa/scale) * (-parg + (parg+qq) / (1+1/temp2))
- da.deta = dtheta.deta(aa, .link.a)
- dscale.deta = dtheta.deta(scale, .link.scale)
+ da.deta = dtheta.deta(aa, .link.a, earg= .earg.a)
+ dscale.deta = dtheta.deta(scale, .link.scale, earg= .earg.scale)
w * cbind( dl.da * da.deta, dl.dscale * dscale.deta )
- }), list( .link.a=link.a, .link.scale=link.scale
+ }), list( .link.a=link.a, .link.scale=link.scale,
+ .earg.a=earg.a, .earg.scale=earg.scale
))),
weight=eval(substitute(expression({
ed2l.da = (1 + parg+qq + parg * qq * (trigamma(parg) + trigamma(qq) +
@@ -5517,12 +5949,14 @@ lomax = function(link.scale="loge",
wz[,iam(1,2,M)] = ed2l.dascale * da.deta * dscale.deta
wz = w * wz
wz
- }), list( .link.a=link.a, .link.scale=link.scale ))))
+ }), list( .link.a=link.a, .link.scale=link.scale,
+ .earg.a=earg.a, .earg.scale=earg.scale ))))
}
invlomax = function(link.scale="loge",
link.p="loge",
+ earg.scale=list(), earg.p=list(),
init.scale=NULL,
init.p=1.0,
zero=NULL)
@@ -5534,19 +5968,24 @@ invlomax = function(link.scale="loge",
link.p = as.character(substitute(link.p))
if(length(zero) && !is.Numeric(zero, integer=TRUE, posit=TRUE))
stop("bad input for argument \"zero\"")
+ if(!is.list(earg.scale)) earg.scale = list()
+ if(!is.list(earg.p)) earg.p = list()
new("vglmff",
blurb=c("Inverse Lomax distribution\n\n",
"Links: ",
- namesof("scale", link.scale), ", ",
- namesof("p", link.p), "\n",
+ namesof("scale", link.scale, earg=earg.scale), ", ",
+ namesof("p", link.p, earg=earg.p), "\n",
"Mean: does not exist"),
constraints=eval(substitute(expression({
constraints = cm.zero.vgam(constraints, x, .zero, M)
}), list( .zero=zero ))),
initialize=eval(substitute(expression({
- predictors.names = c(namesof("scale", .link.scale, tag= FALSE),
- namesof("p", .link.p, tag= FALSE))
+ if(ncol(cbind(y)) != 1)
+ stop("response must be a vector or a one-column matrix")
+ predictors.names =
+ c(namesof("scale", .link.scale, earg=.earg.scale, tag=FALSE),
+ namesof("p", .link.p, earg=.earg.p, tag=FALSE))
qq = aa = 1
if(!length(.init.scale)) {
@@ -5556,50 +5995,62 @@ invlomax = function(link.scale="loge",
fit0 = lsfit(x=xvec, y=log(quantile(y, qvec )))
}
if(!length(etastart)) {
- scale = rep(if(length(.init.scale)) .init.scale else exp(fit0$coef[1]), length=n)
+ scale = rep(if(length(.init.scale)) .init.scale else
+ exp(fit0$coef[1]), length=n)
parg = rep(if(length(.init.p)) .init.p else 1.0, length=n)
- etastart = cbind(theta2eta(scale, .link.scale),
- theta2eta(parg, .link.p))
+ etastart = cbind(theta2eta(scale, .link.scale, earg= .earg.scale),
+ theta2eta(parg, .link.p, earg= .earg.p))
}
}), list( .link.scale=link.scale,
.link.p=link.p,
+ .earg.scale=earg.scale,
+ .earg.p=earg.p,
.init.scale=init.scale,
.init.p=init.p ))),
inverse=eval(substitute(function(eta, extra=NULL) {
rep(as.numeric(NA), len=nrow(eta))
}, list( .link.scale=link.scale,
+ .earg.scale=earg.scale,
+ .earg.p=earg.p,
.link.p=link.p ))),
last=eval(substitute(expression({
misc$link = c(scale= .link.scale, p= .link.p )
+ misc$earg = list(scale= .earg.scale, p= .earg.p )
}), list( .link.scale=link.scale,
+ .earg.scale=earg.scale,
+ .earg.p=earg.p,
.link.p=link.p ))),
loglikelihood=eval(substitute(
function(mu, y, w, residuals= FALSE,eta, extra=NULL) {
aa = qq = 1
- scale = eta2theta(eta[,1], .link.scale)
- parg = eta2theta(eta[,2], .link.p)
+ scale = eta2theta(eta[,1], .link.scale, earg= .earg.scale)
+ parg = eta2theta(eta[,2], .link.p, earg= .earg.p)
if(residuals) stop("loglikelihood residuals not implemented yet") else
sum(w*(log(aa) + (aa*parg-1)*log(y) - aa*parg*log(scale) +
(if(is.R()) -lbeta(parg, qq) else lgamma(parg+qq)-lgamma(parg)-lgamma(qq))-
(parg+qq)*log(1 + (y/scale)^aa )))
}, list( .link.scale=link.scale,
+ .earg.scale=earg.scale,
+ .earg.p=earg.p,
.link.p=link.p ))),
vfamily=c("invlomax"),
deriv=eval(substitute(expression({
aa = qq = 1
- scale = eta2theta(eta[,1], .link.scale)
- parg = eta2theta(eta[,2], .link.p)
+ scale = eta2theta(eta[,1], .link.scale, earg= .earg.scale)
+ parg = eta2theta(eta[,2], .link.p, earg= .earg.p)
temp1 = log(y/scale)
temp2 = (y/scale)^aa
dl.dscale = (aa/scale) * (-parg + (parg+qq) / (1+1/temp2))
dl.dp = aa * temp1 + digamma(parg + qq) - digamma(parg) - log(1+temp2)
- dscale.deta = dtheta.deta(scale, .link.scale)
- dp.deta = dtheta.deta(parg, .link.p)
+ dscale.deta = dtheta.deta(scale, .link.scale, earg= .earg.scale)
+ dp.deta = dtheta.deta(parg, .link.p, earg= .earg.p)
w * cbind( dl.dscale * dscale.deta,
dl.dp * dp.deta )
}), list( .link.scale=link.scale,
+ .earg.scale=earg.scale,
+ .earg.p=earg.p,
.link.p=link.p ))),
weight=eval(substitute(expression({
ed2l.dscale = aa^2 * parg * qq / (scale^2 * (1+parg+qq))
@@ -5612,12 +6063,15 @@ invlomax = function(link.scale="loge",
wz = w * wz
wz
}), list( .link.scale=link.scale,
+ .earg.scale=earg.scale,
+ .earg.p=earg.p,
.link.p=link.p ))))
}
paralogistic = function(link.a="loge",
link.scale="loge",
+ earg.a=list(), earg.scale=list(),
init.a=1.0,
init.scale=NULL,
zero=NULL)
@@ -5629,19 +6083,24 @@ paralogistic = function(link.a="loge",
link.scale = as.character(substitute(link.scale))
if(length(zero) && !is.Numeric(zero, integer=TRUE, posit=TRUE))
stop("bad input for argument \"zero\"")
+ if(!is.list(earg.a)) earg.a = list()
+ if(!is.list(earg.scale)) earg.scale = list()
new("vglmff",
blurb=c("Paralogistic distribution\n\n",
"Links: ",
- namesof("a", link.a), ", ",
- namesof("scale", link.scale), "\n",
+ namesof("a", link.a, earg=earg.a), ", ",
+ namesof("scale", link.scale, earg=earg.scale), "\n",
"Mean: scale*gamma(1 + 1/a)*gamma(a - 1/a)/gamma(a)"),
constraints=eval(substitute(expression({
constraints = cm.zero.vgam(constraints, x, .zero, M)
}), list( .zero=zero ))),
initialize=eval(substitute(expression({
- predictors.names = c(namesof("a", .link.a, tag= FALSE),
- namesof("scale", .link.scale, tag= FALSE))
+ if(ncol(cbind(y)) != 1)
+ stop("response must be a vector or a one-column matrix")
+ predictors.names =
+ c(namesof("a", .link.a, earg=.earg.a, tag=FALSE),
+ namesof("scale", .link.scale, earg=.earg.scale, tag=FALSE))
parg = 1
if(!length(.init.a) || !length(.init.scale)) {
@@ -5655,39 +6114,44 @@ paralogistic = function(link.a="loge",
aa = rep(if(length(.init.a)) .init.a else 1/fit0$coef[2], length=n)
scale = rep(if(length(.init.scale)) .init.scale else
exp(fit0$coef[1]), length=n)
- etastart = cbind(theta2eta(aa, .link.a),
- theta2eta(scale, .link.scale))
+ etastart = cbind(theta2eta(aa, .link.a, earg= .earg.a),
+ theta2eta(scale, .link.scale, earg= .earg.scale))
}
}), list( .link.a=link.a, .link.scale=link.scale,
+ .earg.a=earg.a, .earg.scale=earg.scale,
.init.a=init.a, .init.scale=init.scale
))),
inverse=eval(substitute(function(eta, extra=NULL) {
- aa = eta2theta(eta[,1], .link.a)
- scale = eta2theta(eta[,2], .link.scale)
+ aa = eta2theta(eta[,1], .link.a, earg= .earg.a)
+ scale = eta2theta(eta[,2], .link.scale, earg= .earg.scale)
qq = aa
scale*gamma(1 + 1/aa)*gamma(qq-1/aa)/(gamma(qq))
- }, list( .link.a=link.a, .link.scale=link.scale
+ }, list( .link.a=link.a, .link.scale=link.scale,
+ .earg.a=earg.a, .earg.scale=earg.scale
))),
last=eval(substitute(expression({
misc$link = c(a= .link.a, scale= .link.scale)
- }), list( .link.a=link.a, .link.scale=link.scale
+ misc$earg = list(a= .earg.a, scale= .earg.scale )
+ }), list( .link.a=link.a, .link.scale=link.scale,
+ .earg.a=earg.a, .earg.scale=earg.scale
))),
loglikelihood=eval(substitute(
function(mu, y, w, residuals= FALSE,eta, extra=NULL) {
- aa = eta2theta(eta[,1], .link.a)
- scale = eta2theta(eta[,2], .link.scale)
+ aa = eta2theta(eta[,1], .link.a, earg= .earg.a)
+ scale = eta2theta(eta[,2], .link.scale, earg= .earg.scale)
parg = 1
qq = aa
if(residuals) stop("loglikelihood residuals not implemented yet") else
sum(w*(log(aa) + (aa*parg-1)*log(y) - aa*parg*log(scale) +
(if(is.R()) -lbeta(parg, qq) else lgamma(parg+qq)-lgamma(parg)-lgamma(qq))-
(parg+qq)*log(1 + (y/scale)^aa )))
- }, list( .link.a=link.a, .link.scale=link.scale
+ }, list( .link.a=link.a, .link.scale=link.scale,
+ .earg.a=earg.a, .earg.scale=earg.scale
))),
vfamily=c("paralogistic"),
deriv=eval(substitute(expression({
- aa = eta2theta(eta[,1], .link.a)
- scale = eta2theta(eta[,2], .link.scale)
+ aa = eta2theta(eta[,1], .link.a, earg= .earg.a)
+ scale = eta2theta(eta[,2], .link.scale, earg= .earg.scale)
parg = 1
qq = aa
@@ -5698,10 +6162,11 @@ paralogistic = function(link.a="loge",
dl.da = 1/aa + parg * temp1 - (parg+qq) * temp1 / (1+1/temp2)
dl.dscale = (aa/scale) * (-parg + (parg+qq) / (1+1/temp2))
- da.deta = dtheta.deta(aa, .link.a)
- dscale.deta = dtheta.deta(scale, .link.scale)
+ da.deta = dtheta.deta(aa, .link.a, earg= .earg.a)
+ dscale.deta = dtheta.deta(scale, .link.scale, earg= .earg.scale)
w * cbind( dl.da * da.deta, dl.dscale * dscale.deta)
- }), list( .link.a=link.a, .link.scale=link.scale
+ }), list( .link.a=link.a, .link.scale=link.scale,
+ .earg.a=earg.a, .earg.scale=earg.scale
))),
weight=eval(substitute(expression({
ed2l.da = (1 + parg+qq + parg * qq * (trigamma(parg) + trigamma(qq) +
@@ -5716,13 +6181,15 @@ paralogistic = function(link.a="loge",
wz[,iam(1,2,M)] = ed2l.dascale * da.deta * dscale.deta
wz = w * wz
wz
- }), list( .link.a=link.a, .link.scale=link.scale
+ }), list( .link.a=link.a, .link.scale=link.scale,
+ .earg.a=earg.a, .earg.scale=earg.scale
))))
}
invparalogistic = function(link.a="loge",
link.scale="loge",
+ earg.a=list(), earg.scale=list(),
init.a=1.0,
init.scale=NULL,
zero=NULL)
@@ -5734,19 +6201,24 @@ paralogistic = function(link.a="loge",
link.scale = as.character(substitute(link.scale))
if(length(zero) && !is.Numeric(zero, integer=TRUE, posit=TRUE))
stop("bad input for argument \"zero\"")
+ if(!is.list(earg.a)) earg.a = list()
+ if(!is.list(earg.scale)) earg.scale = list()
new("vglmff",
blurb=c("Inverse paralogistic distribution\n\n",
"Links: ",
- namesof("a", link.a), ", ",
- namesof("scale", link.scale), "\n",
+ namesof("a", link.a, earg=earg.a), ", ",
+ namesof("scale", link.scale, earg=earg.scale), "\n",
"Mean: scale*gamma(a + 1/a)*gamma(1 - 1/a)/gamma(a)"),
constraints=eval(substitute(expression({
constraints = cm.zero.vgam(constraints, x, .zero, M)
}), list( .zero=zero ))),
initialize=eval(substitute(expression({
- predictors.names = c(namesof("a", .link.a, tag= FALSE),
- namesof("scale", .link.scale, tag= FALSE))
+ if(ncol(cbind(y)) != 1)
+ stop("response must be a vector or a one-column matrix")
+ predictors.names =
+ c(namesof("a", .link.a, earg=.earg.a, tag=FALSE),
+ namesof("scale", .link.scale, earg=.earg.scale, tag=FALSE))
if(!length(.init.a) || !length(.init.scale)) {
qvec = c(.25, .5, .75) # Arbitrary; could be made an argument
@@ -5760,36 +6232,41 @@ paralogistic = function(link.a="loge",
aa = rep(if(length(.init.a)) .init.a else -1/fit0$coef[2], length=n)
scale = rep(if(length(.init.scale)) .init.scale else
exp(fit0$coef[1]), length=n)
- etastart = cbind(theta2eta(aa, .link.a),
- theta2eta(scale, .link.scale))
+ etastart = cbind(theta2eta(aa, .link.a, earg= .earg.a),
+ theta2eta(scale, .link.scale, earg= .earg.scale))
}
}), list( .link.a=link.a, .link.scale=link.scale,
+ .earg.a=earg.a, .earg.scale=earg.scale,
.init.a=init.a, .init.scale=init.scale ))),
inverse=eval(substitute(function(eta, extra=NULL) {
- aa = eta2theta(eta[,1], .link.a)
- scale = eta2theta(eta[,2], .link.scale)
+ aa = eta2theta(eta[,1], .link.a, earg= .earg.a)
+ scale = eta2theta(eta[,2], .link.scale, earg= .earg.scale)
parg = aa
qq = 1
scale*gamma(parg + 1/aa)*gamma(qq-1/aa)/(gamma(parg)*gamma(qq))
- }, list( .link.a=link.a, .link.scale=link.scale ))),
+ }, list( .link.a=link.a, .link.scale=link.scale,
+ .earg.a=earg.a, .earg.scale=earg.scale ))),
last=eval(substitute(expression({
misc$link = c(a= .link.a, scale= .link.scale )
- }), list( .link.a=link.a, .link.scale=link.scale ))),
+ misc$earg = list(a= .earg.a, scale= .earg.scale )
+ }), list( .link.a=link.a, .link.scale=link.scale,
+ .earg.a=earg.a, .earg.scale=earg.scale ))),
loglikelihood=eval(substitute(
function(mu, y, w, residuals= FALSE,eta, extra=NULL) {
- aa = eta2theta(eta[,1], .link.a)
- scale = eta2theta(eta[,2], .link.scale)
+ aa = eta2theta(eta[,1], .link.a, earg= .earg.a)
+ scale = eta2theta(eta[,2], .link.scale, earg= .earg.scale)
parg = aa
qq = 1
if(residuals) stop("loglikelihood residuals not implemented yet") else
sum(w*(log(aa) + (aa*parg-1)*log(y) - aa*parg*log(scale) +
(if(is.R()) -lbeta(parg, qq) else lgamma(parg+qq)-lgamma(parg)-lgamma(qq))-
(parg+qq)*log(1 + (y/scale)^aa )))
- }, list( .link.a=link.a, .link.scale=link.scale ))),
+ }, list( .link.a=link.a, .link.scale=link.scale,
+ .earg.a=earg.a, .earg.scale=earg.scale ))),
vfamily=c("invparalogistic"),
deriv=eval(substitute(expression({
- aa = eta2theta(eta[,1], .link.a)
- scale = eta2theta(eta[,2], .link.scale)
+ aa = eta2theta(eta[,1], .link.a, earg= .earg.a)
+ scale = eta2theta(eta[,2], .link.scale, earg= .earg.scale)
parg = aa
qq = 1
@@ -5800,10 +6277,11 @@ paralogistic = function(link.a="loge",
dl.da = 1/aa + parg * temp1 - (parg+qq) * temp1 / (1+1/temp2)
dl.dscale = (aa/scale) * (-parg + (parg+qq) / (1+1/temp2))
- da.deta = dtheta.deta(aa, .link.a)
- dscale.deta = dtheta.deta(scale, .link.scale)
+ da.deta = dtheta.deta(aa, .link.a, earg= .earg.a)
+ dscale.deta = dtheta.deta(scale, .link.scale, earg= .earg.scale)
w * cbind( dl.da * da.deta, dl.dscale * dscale.deta )
- }), list( .link.a=link.a, .link.scale=link.scale ))),
+ }), list( .link.a=link.a, .link.scale=link.scale,
+ .earg.a=earg.a, .earg.scale=earg.scale ))),
weight=eval(substitute(expression({
ed2l.da = (1 + parg+qq + parg * qq * (trigamma(parg) + trigamma(qq) +
(temp3b - temp3a + (parg-qq)/(parg*qq))^2 -
@@ -5817,14 +6295,15 @@ paralogistic = function(link.a="loge",
wz[,iam(1,2,M)] = ed2l.dascale * da.deta * dscale.deta
wz = w * wz
wz
- }), list( .link.a=link.a, .link.scale=link.scale ))))
+ }), list( .link.a=link.a, .link.scale=link.scale,
+ .earg.a=earg.a, .earg.scale=earg.scale ))))
}
if(FALSE)
-genlognormal = function(link.sigma="loge",
- link.r="loge",
+genlognormal = function(link.sigma="loge", link.r="loge",
+ esigma=list(), er=list(),
init.sigma=1, init.r=1, zero=NULL)
{
warning(paste("2/4/04; doesn't work, possibly because first derivs are",
@@ -5839,19 +6318,24 @@ warning(paste("2/4/04; doesn't work, possibly because first derivs are",
link.r = as.character(substitute(link.r))
if(length(zero) && !is.Numeric(zero, integer=TRUE, posit=TRUE))
stop("bad input for argument \"zero\"")
+ if(!is.list(esigma)) esigma = list()
+ if(!is.list(er)) er = list()
new("vglmff",
blurb=c("Three-parameter generalized lognormal distribution\n\n",
"Links: ",
- "loc; ", namesof("sigma", link.sigma, tag= TRUE),
- ", ", namesof("r", link.r, tag= TRUE)),
+ "loc; ", namesof("sigma", link.sigma, earg=esigma, tag= TRUE),
+ ", ", namesof("r", link.r, earg=er, tag= TRUE)),
constraints=eval(substitute(expression({
constraints = cm.zero.vgam(constraints, x, .zero, M)
}), list( .zero=zero ))),
initialize=eval(substitute(expression({
- predictors.names = c("loc", # zz call it "mean" or "mymu" ?
- namesof("sigma", .link.sigma, tag= FALSE),
- namesof("r", .link.r, tag= FALSE))
+ if(ncol(cbind(y)) != 1)
+ stop("response must be a vector or a one-column matrix")
+ predictors.names =
+ c(namesof("loc", "identity", earg= list(), tag=FALSE),
+ namesof("sigma", .link.sigma, earg=.esigma, tag=FALSE),
+ namesof("r", .link.r, earg=.er, tag=FALSE))
if(!length(.init.sigma) || !length(.init.r)) {
init.r = if(length(.init.r)) .init.r else 1
@@ -5869,9 +6353,9 @@ warning(paste("2/4/04; doesn't work, possibly because first derivs are",
}), list( .link.sigma=link.sigma, .link.r=link.r,
.init.sigma=init.sigma, .init.r=init.r ))),
inverse=eval(substitute(function(eta, extra=NULL) {
- mymu = eta2theta(eta[,1], "identity")
- sigma = eta2theta(eta[,2], .link.sigma)
- r = eta2theta(eta[,3], .link.r)
+ mymu = eta2theta(eta[,1], "identity", earg=list())
+ sigma = eta2theta(eta[,2], .link.sigma, earg= .esigma)
+ r = eta2theta(eta[,3], .link.r, earg= .er)
r
}, list( .link.sigma=link.sigma, .link.r=link.r ))),
last=eval(substitute(expression({
@@ -5880,18 +6364,18 @@ warning(paste("2/4/04; doesn't work, possibly because first derivs are",
}), list( .link.sigma=link.sigma, .link.r=link.r ))),
loglikelihood=eval(substitute(
function(mu,y,w,residuals= FALSE,eta, extra=NULL) {
- mymu = eta2theta(eta[,1], "identity")
- sigma = eta2theta(eta[,2], .link.sigma)
- r = eta2theta(eta[,3], .link.r)
+ mymu = eta2theta(eta[,1], "identity", earg=list())
+ sigma = eta2theta(eta[,2], .link.sigma, earg= .esigma)
+ r = eta2theta(eta[,3], .link.r, earg= .er)
temp89 = (abs(log(y)-mymu)/sigma)^r
if(residuals) stop("loglikelihood residuals not implemented yet") else
sum(w * (-log(r^(1/r) * sigma) - lgamma(1+1/r) - temp89/r))
}, list( .link.sigma=link.sigma, .link.r=link.r ))),
vfamily=c("genlognormal3"),
deriv=eval(substitute(expression({
- mymu = eta2theta(eta[,1], "identity")
- sigma = eta2theta(eta[,2], .link.sigma)
- r = eta2theta(eta[,3], .link.r)
+ mymu = eta2theta(eta[,1], "identity", earg=list())
+ sigma = eta2theta(eta[,2], .link.sigma, earg= .esigma)
+ r = eta2theta(eta[,3], .link.r, earg= .er)
ss = 1 + 1/r
temp33 = (abs(log(y)-mymu)/sigma)
temp33r1 = temp33^(r-1)
@@ -5900,9 +6384,9 @@ warning(paste("2/4/04; doesn't work, possibly because first derivs are",
dl.dr = (log(r) - 1 + digamma(ss) + temp33*temp33r1)/r^2 -
temp33r1 * log(temp33r1) / r
- dmymu.deta = dtheta.deta(mymu, "identity")
- dsigma.deta = dtheta.deta(sigma, .link.sigma)
- dr.deta = dtheta.deta(r, .link.r)
+ dmymu.deta = dtheta.deta(mymu, "identity", earg=list())
+ dsigma.deta = dtheta.deta(sigma, .link.sigma, earg= .esigma)
+ dr.deta = dtheta.deta(r, .link.r, earg= .er)
w * cbind(dl.dmymu * dmymu.deta,
dl.dsigma * dsigma.deta,
dl.dr * dr.deta)
@@ -5924,18 +6408,19 @@ warning(paste("2/4/04; doesn't work, possibly because first derivs are",
}
-betaprime = function(link="loge", i1=2, i2=NULL, zero=NULL)
+betaprime = function(link="loge", earg=list(), i1=2, i2=NULL, zero=NULL)
{
if(mode(link) != "character" && mode(link) != "name")
link = as.character(substitute(link))
+ if(!is.list(earg)) earg = list()
new("vglmff",
blurb=c("Beta-prime distribution\n",
"y^(shape1-1) * (1+y)^(-shape1-shape2) / Beta(shape1,shape2),",
" y>0, shape1>0, shape2>0\n\n",
"Links: ",
- namesof("shape1", link), ", ",
- namesof("shape2", link), "\n",
+ namesof("shape1", link, earg=earg), ", ",
+ namesof("shape2", link, earg=earg), "\n",
"Mean: shape1/(shape2-1) provided shape2>1"),
constraints=eval(substitute(expression({
constraints = cm.zero.vgam(constraints, x, .zero, M)
@@ -5945,45 +6430,48 @@ betaprime = function(link="loge", i1=2, i2=NULL, zero=NULL)
stop("betaprime cannot handle matrix responses yet")
if(min(y) <= 0)
stop("response must be positive")
- predictors.names = c(namesof("shape1", .link, short= TRUE),
- namesof("shape2", .link, short= TRUE))
+ predictors.names = c(namesof("shape1", .link, earg=.earg, short=TRUE),
+ namesof("shape2", .link, earg=.earg, short=TRUE))
if(is.numeric(.i1) && is.numeric(.i2)) {
vec = c(.i1, .i2)
- vec = c(theta2eta(vec[1], .link), theta2eta(vec[2], .link))
+ vec = c(theta2eta(vec[1], .link, earg= .earg),
+ theta2eta(vec[2], .link, earg= .earg))
etastart = matrix(vec, n, 2, byrow= TRUE)
}
if(!length(etastart)) {
init1 = if(length( .i1)) rep( .i1, len=n) else rep(1, len=n)
init2 = if(length( .i2)) rep( .i2, len=n) else 1 + init1 / (y + 0.1)
- etastart = matrix(theta2eta(c(init1, init2), .link),n,2,byrow=TRUE)
+ etastart = matrix(theta2eta(c(init1, init2), .link, earg= .earg),
+ n,2,byrow=TRUE)
}
- }), list( .link=link, .i1=i1, .i2=i2 ))),
+ }), list( .link=link, .earg=earg, .i1=i1, .i2=i2 ))),
inverse=eval(substitute(function(eta, extra=NULL) {
- shapes = eta2theta(eta, .link)
+ shapes = eta2theta(eta, .link, earg= .earg)
ifelse(shapes[,2] > 1, shapes[,1]/(shapes[,2]-1), NA)
- }, list( .link=link ))),
+ }, list( .link=link, .earg=earg ))),
last=eval(substitute(expression({
misc$link = c(shape1 = .link, shape2 = .link)
- }), list( .link=link ))),
+ misc$earg = list(shape1 = .earg, shape2 = .earg)
+ }), list( .link=link, .earg=earg ))),
loglikelihood=eval(substitute(
function(mu, y, w, residuals= FALSE, eta, extra=NULL){
- shapes = eta2theta(eta, .link)
+ shapes = eta2theta(eta, .link, earg= .earg)
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)-(shapes[,2]+shapes[,1])*log(1+y)-temp))
- }, list( .link=link ))),
+ }, list( .link=link, .earg=earg ))),
vfamily="betaprime",
deriv=eval(substitute(expression({
- shapes = eta2theta(eta, .link)
- dshapes.deta = dtheta.deta(shapes, .link)
+ shapes = eta2theta(eta, .link, earg= .earg)
+ dshapes.deta = dtheta.deta(shapes, .link, earg= .earg)
dl.dshapes = cbind(log(y) - log(1+y) - digamma(shapes[,1]) +
digamma(shapes[,1]+shapes[,2]),
- log(1+y) - digamma(shapes[,2]) +
digamma(shapes[,1]+shapes[,2]))
w * dl.dshapes * dshapes.deta
- }), list( .link=link ))),
+ }), list( .link=link, .earg=earg ))),
weight=expression({
temp2 = trigamma(shapes[,1]+shapes[,2])
d2l.dshape12 = temp2 - trigamma(shapes[,1])
@@ -6001,47 +6489,51 @@ betaprime = function(link="loge", i1=2, i2=NULL, zero=NULL)
-maxwell = function(link="loge") {
+maxwell = function(link="loge", earg=list()) {
if(mode(link) != "character" && mode(link) != "name")
link = as.character(substitute(link))
+ if(!is.list(earg)) earg = list()
new("vglmff",
blurb=c("Maxwell distribution f(y) = sqrt(2/pi) * a^(3/2) * y^2 *",
" exp(-0.5*a*y^2), y>0, a>0\n",
- "Link: ", namesof("a", link), "\n", "\n",
+ "Link: ", namesof("a", link, earg=earg), "\n", "\n",
"Mean: sqrt(8 / (a * pi))"),
initialize=eval(substitute(expression({
- predictors.names = namesof("a", .link, tag= FALSE)
+ if(ncol(cbind(y)) != 1)
+ stop("response must be a vector or a one-column matrix")
+ predictors.names = namesof("a", .link, earg=.earg, tag=FALSE)
if(!length(etastart)) {
a.init = rep(8 / (pi*(y+0.1)^2), length=length(y))
- etastart = theta2eta(a.init, .link)
+ etastart = theta2eta(a.init, .link, earg= .earg)
}
- }), list( .link=link ))),
+ }), list( .link=link, .earg=earg ))),
inverse=eval(substitute(function(eta, extra=NULL) {
- a = eta2theta(eta, .link)
+ a = eta2theta(eta, .link, earg= .earg)
sqrt(8 / (a * pi))
- }, list( .link=link ))),
+ }, list( .link=link, .earg=earg ))),
last=eval(substitute(expression({
misc$link = c(a= .link)
- }), list( .link=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)
+ a = eta2theta(eta, .link, earg= .earg)
if(residuals) stop("loglikelihood residuals not implemented yet") else
sum(w * (1.5 * log(a) + 2 * log(y) - 0.5 * a * y^2 + 0.5*log(2/pi )))
- }, list( .link=link ))),
+ }, list( .link=link, .earg=earg ))),
vfamily=c("maxwell"),
deriv=eval(substitute(expression({
- a = eta2theta(eta, .link)
+ a = eta2theta(eta, .link, earg= .earg)
dl.da = 1.5 / a - 0.5 * y^2
- da.deta = dtheta.deta(a, .link)
+ da.deta = dtheta.deta(a, .link, earg= .earg)
w * dl.da * da.deta
- }), list( .link=link ))),
+ }), list( .link=link, .earg=earg ))),
weight=eval(substitute(expression({
ed2l.da2 = 1.5 / a^2
wz = w * da.deta^2 * ed2l.da2
wz
- }), list( .link=link ))))
+ }), list( .link=link, .earg=earg ))))
}
@@ -6159,13 +6651,16 @@ rnaka = function(n, shape, scale=1, Smallno=1.0e-6) {
-nakagami = function(lshape="loge", lscale="loge", ishape=NULL, iscale=1) {
+nakagami = function(lshape="loge", lscale="loge",
+ eshape=list(), escale=list(), ishape=NULL, iscale=1) {
if(mode(lshape) != "character" && mode(lshape) != "name")
lshape = as.character(substitute(lshape))
if(mode(lscale) != "character" && mode(lscale) != "name")
lscale = as.character(substitute(lscale))
if(!is.null(iscale) && !is.Numeric(iscale, positi=TRUE))
stop("argument \"iscale\" must be a positive number or NULL")
+ if(!is.list(eshape)) eshape = list()
+ if(!is.list(escale)) escale = list()
new("vglmff",
blurb=c("Nakagami distribution f(y) = 2 * (shape/scale)^shape *\n",
@@ -6174,54 +6669,61 @@ nakagami = function(lshape="loge", lscale="loge", ishape=NULL, iscale=1) {
" ",
"y>0, shape>0, scale>0\n",
"Links: ",
- namesof("shape", lshape), ", ",
- namesof("scale", lscale),
+ namesof("shape", lshape, earg=eshape), ", ",
+ namesof("scale", lscale, earg=escale),
"\n",
"\n",
"Mean: sqrt(scale/shape) * gamma(shape+0.5) / gamma(shape)"),
initialize=eval(substitute(expression({
if(ncol(cbind(y)) != 1)
stop("response must be a vector or a one-column matrix")
- predictors.names = c(namesof("shape", .lshape, tag= FALSE),
- namesof("scale", .lscale, tag= FALSE))
+ predictors.names = c(namesof("shape", .lshape, earg=.eshape, tag=FALSE),
+ namesof("scale", .lscale, earg=.escale, tag=FALSE))
if(!length(etastart)) {
init2 = if(is.Numeric( .iscale, posit=TRUE))
rep( .iscale, len=n) else rep(1, len=n)
init1 = if(is.Numeric( .ishape, posit=TRUE))
rep( .ishape, len=n) else
rep(init2 / (y+1/8)^2, len=n)
- etastart = cbind(theta2eta(init1, .lshape),
- theta2eta(init2, .lscale))
+ etastart = cbind(theta2eta(init1, .lshape, earg= .eshape),
+ theta2eta(init2, .lscale, earg= .escale))
}
- }), list( .lscale=lscale, .lshape=lshape, .ishape=ishape, .iscale=iscale ))),
+ }), list( .lscale=lscale, .lshape=lshape,
+ .escale=escale, .eshape=eshape,
+ .ishape=ishape, .iscale=iscale ))),
inverse=eval(substitute(function(eta, extra=NULL) {
- shape = eta2theta(eta[,1], .lshape)
- scale = eta2theta(eta[,2], .lscale)
+ shape = eta2theta(eta[,1], .lshape, earg= .eshape)
+ scale = eta2theta(eta[,2], .lscale, earg= .escale)
sqrt(scale/shape) * gamma(shape+0.5) / gamma(shape)
- }, list( .lscale=lscale, .lshape=lshape ))),
+ }, list( .lscale=lscale, .lshape=lshape,
+ .escale=escale, .eshape=eshape ))),
last=eval(substitute(expression({
misc$link = c(shape= .lshape, scale= .lscale)
+ misc$earg = list(shape = .eshape, scale = .escale)
misc$expected = TRUE
- }), list( .lscale=lscale, .lshape=lshape ))),
+ }), list( .lscale=lscale, .lshape=lshape,
+ .escale=escale, .eshape=eshape ))),
loglikelihood=eval(substitute(
function(mu,y,w,residuals= FALSE,eta, extra=NULL) {
- shape = eta2theta(eta[,1], .lshape)
- scale = eta2theta(eta[,2], .lscale)
+ shape = eta2theta(eta[,1], .lshape, earg= .eshape)
+ scale = eta2theta(eta[,2], .lscale, earg= .escale)
if(residuals) stop("loglikelihood residuals not implemented yet") else
sum(w * (log(2) + shape * log(shape/scale) - lgamma(shape) +
(2*shape-1) * log(y) - shape * y^2 / scale))
- }, list( .lscale=lscale, .lshape=lshape ))),
+ }, list( .lscale=lscale, .lshape=lshape,
+ .escale=escale, .eshape=eshape ))),
vfamily=c("nakagami"),
deriv=eval(substitute(expression({
- shape = eta2theta(eta[,1], .lshape)
- Scale = eta2theta(eta[,2], .lscale)
+ shape = eta2theta(eta[,1], .lshape, earg= .eshape)
+ Scale = eta2theta(eta[,2], .lscale, earg= .escale)
dl.dshape = 1 + log(shape/Scale) - digamma(shape) +
2 * log(y) - y^2 / Scale
dl.dscale = -shape/Scale + shape * (y/Scale)^2
- dshape.deta = dtheta.deta(shape, .lshape)
- dscale.deta = dtheta.deta(Scale, .lscale)
+ dshape.deta = dtheta.deta(shape, .lshape, earg= .eshape)
+ dscale.deta = dtheta.deta(Scale, .lscale, earg= .escale)
w * cbind(dl.dshape * dshape.deta, dl.dscale * dscale.deta)
- }), list( .lscale=lscale, .lshape=lshape ))),
+ }), list( .lscale=lscale, .lshape=lshape,
+ .escale=escale, .eshape=eshape ))),
weight=eval(substitute(expression({
d2l.dshape2 = trigamma(shape) - 1/shape
d2l.dscale2 = shape / Scale^2
@@ -6229,53 +6731,58 @@ nakagami = function(lshape="loge", lscale="loge", ishape=NULL, iscale=1) {
wz[,iam(1,1,M)] = d2l.dshape2 * dshape.deta^2
wz[,iam(2,2,M)] = d2l.dscale2 * dscale.deta^2
w * wz
- }), list( .lscale=lscale, .lshape=lshape ))))
+ }), list( .lscale=lscale, .lshape=lshape,
+ .escale=escale, .eshape=eshape ))))
}
-rayleigh = function(link="loge") {
+rayleigh = function(link="loge", earg=list()) {
if(mode(link) != "character" && mode(link) != "name")
link = as.character(substitute(link))
+ if(!is.list(earg)) earg = list()
new("vglmff",
blurb=c("Rayleigh distribution f(y) = y*exp(-0.5*(y/a)^2)/a^2, y>0, a>0\n",
"Link: ",
- namesof("a", link), "\n\n",
+ namesof("a", link, earg=earg), "\n\n",
"Mean: a * sqrt(pi / 2)"),
initialize=eval(substitute(expression({
- predictors.names = namesof("a", .link, tag= FALSE)
+ if(ncol(cbind(y)) != 1)
+ stop("response must be a vector or a one-column matrix")
+ predictors.names = namesof("a", .link, earg=.earg, tag=FALSE)
if(!length(etastart)) {
a.init = (y+1/8) / sqrt(pi/2)
- etastart = theta2eta(a.init, .link)
+ etastart = theta2eta(a.init, .link, earg= .earg)
}
- }), list( .link=link ))),
+ }), list( .link=link, .earg=earg ))),
inverse=eval(substitute(function(eta, extra=NULL) {
- a = eta2theta(eta, .link)
+ a = eta2theta(eta, .link, earg= .earg)
a * sqrt(pi/2)
- }, list( .link=link ))),
+ }, list( .link=link, .earg=earg ))),
last=eval(substitute(expression({
misc$link = c(a= .link)
- }), list( .link=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)
+ a = eta2theta(eta, .link, earg= .earg)
if(residuals) stop("loglikelihood residuals not implemented yet") else
sum(w * (log(y) - 2 * log(a) - 0.5 * (y/a)^2))
- }, list( .link=link ))),
+ }, list( .link=link, .earg=earg ))),
vfamily=c("rayleigh"),
deriv=eval(substitute(expression({
- a = eta2theta(eta, .link)
+ a = eta2theta(eta, .link, earg= .earg)
dl.da = ((y/a)^2 - 2) / a
- da.deta = dtheta.deta(a, .link)
+ da.deta = dtheta.deta(a, .link, earg= .earg)
w * dl.da * da.deta
- }), list( .link=link ))),
+ }), list( .link=link, .earg=earg ))),
weight=eval(substitute(expression({
ed2l.da2 = 4 / a^2
wz = w * da.deta^2 * ed2l.da2
wz
- }), list( .link=link ))))
+ }), list( .link=link, .earg=earg ))))
}
@@ -6417,6 +6924,7 @@ paretoIV = function(location=0,
lscale="loge",
linequality="loge",
lshape="loge",
+ escale=list(), einequality=list(), eshape=list(),
iscale=1, iinequality=1, ishape=NULL,
method.init=1) {
if(mode(lscale) != "character" && mode(lscale) != "name")
@@ -6437,23 +6945,27 @@ paretoIV = function(location=0,
stop("bad input for argument \"method.init\"")
if(linequality == "nloge" && location != 0)
warning("The Burr distribution has location=0 and linequality=nloge")
+ if(!is.list(escale)) escale = list()
+ if(!is.list(einequality)) einequality = list()
+ if(!is.list(eshape)) eshape = list()
new("vglmff",
blurb=c("Pareto(IV) distribution F(y)=1-[1+((y - ", location,
")/scale)^(1/inequality)]^(-shape),",
"\n", " y > ",
location, ", scale > 0, inequality > 0, shape > 0,\n",
- "Links: ", namesof("scale", lscale ), ", ",
- namesof("inequality", linequality ), ", ",
- namesof("shape", lshape ), "\n",
+ "Links: ", namesof("scale", lscale, earg=escale ), ", ",
+ namesof("inequality", linequality, earg=einequality ), ", ",
+ namesof("shape", lshape, earg=eshape ), "\n",
"Mean: location + scale * NA"), # zz
initialize=eval(substitute(expression({
- predictors.names = c(namesof("scale", .lscale, tag= FALSE),
- namesof("inequality", .linequality, tag= FALSE),
- namesof("shape", .lshape, tag= FALSE))
- extra$location = location = .location
if(ncol(cbind(y)) != 1)
- stop("the response must be a vector or a one-column matrix")
+ stop("response must be a vector or a one-column matrix")
+ predictors.names =
+ c(namesof("scale", .lscale, earg=.escale, tag=FALSE),
+ namesof("inequality", .linequality, earg=.einequality, tag=FALSE),
+ namesof("shape", .lshape, earg=.eshape, tag=FALSE))
+ extra$location = location = .location
if(any(y <= location))
stop("the response must have values > than the \"location\" argument")
if(!length(etastart)) {
@@ -6471,55 +6983,63 @@ paretoIV = function(location=0,
}
shape.init = max(0.01, (2*A2-A1)/(A1-A2))
}
- etastart=cbind(theta2eta(rep(scale.init, len=n), .lscale),
- theta2eta(rep(inequality.init, len=n), .linequality),
- theta2eta(rep(shape.init, len=n), .lshape))
+ etastart=cbind(
+ theta2eta(rep(scale.init, len=n), .lscale, earg= .escale),
+ theta2eta(rep(inequality.init, len=n), .linequality, earg= .einequality),
+ theta2eta(rep(shape.init, len=n), .lshape, earg= .eshape))
}
}), list( .location=location, .lscale=lscale,
.linequality=linequality, .lshape=lshape, .method.init=method.init,
+ .escale=escale, .einequality=einequality, .eshape=eshape,
.iscale=iscale, .iinequality=iinequality, .ishape=ishape ))),
inverse=eval(substitute(function(eta, extra=NULL) {
location = extra$location
- Scale = eta2theta(eta[,1], .lscale)
- inequality = eta2theta(eta[,2], .linequality)
- shape = eta2theta(eta[,3], .lshape)
+ Scale = eta2theta(eta[,1], .lscale, earg= .escale)
+ inequality = eta2theta(eta[,2], .linequality, earg= .einequality)
+ shape = eta2theta(eta[,3], .lshape, earg= .eshape)
location + Scale * NA
- }, list( .lscale=lscale, .linequality=linequality, .lshape=lshape ))),
+ }, list( .lscale=lscale, .linequality=linequality, .lshape=lshape,
+ .escale=escale, .einequality=einequality, .eshape=eshape ))),
last=eval(substitute(expression({
misc$link=c("scale"= .lscale, "inequality"= .linequality,
"shape"= .lshape)
+ misc$earg = list(scale = .escale, inequality= .einequality,
+ shape = .eshape)
misc$location = extra$location # Use this for prediction
- }), list( .lscale=lscale, .linequality=linequality, .lshape=lshape ))),
+ }), list( .lscale=lscale, .linequality=linequality, .lshape=lshape,
+ .escale=escale, .einequality=einequality, .eshape=eshape ))),
loglikelihood=eval(substitute(
function(mu,y,w,residuals= FALSE,eta, extra=NULL) {
location = extra$location
- Scale = eta2theta(eta[,1], .lscale)
- inequality = eta2theta(eta[,2], .linequality)
- shape = eta2theta(eta[,3], .lshape)
+ Scale = eta2theta(eta[,1], .lscale, earg= .escale)
+ inequality = eta2theta(eta[,2], .linequality, earg= .einequality)
+ shape = eta2theta(eta[,3], .lshape, earg= .eshape)
zedd = (y - location) / Scale
if(residuals) stop("loglikelihood residuals not implemented yet") else
sum(w * (log(shape) - log(inequality) - log(Scale) + (1/inequality -1) *
log(zedd) - (shape+1) * log(1 + zedd^(1/inequality ))))
- }, list( .lscale=lscale, .linequality=linequality, .lshape=lshape ))),
+ }, list( .lscale=lscale, .linequality=linequality, .lshape=lshape,
+ .escale=escale, .einequality=einequality, .eshape=eshape ))),
vfamily=c("paretoIV"),
deriv=eval(substitute(expression({
location = extra$location
- Scale = eta2theta(eta[,1], .lscale)
- inequality = eta2theta(eta[,2], .linequality)
- shape = eta2theta(eta[,3], .lshape)
+ Scale = eta2theta(eta[,1], .lscale, earg= .escale)
+ inequality = eta2theta(eta[,2], .linequality, earg= .einequality)
+ shape = eta2theta(eta[,3], .lshape, earg= .eshape)
zedd = (y - location) / Scale
temp100 = 1 + zedd^(1/inequality)
dl.dscale = (shape - (1+shape) / temp100) / (inequality * Scale)
dl.dinequality = ((log(zedd) * (shape - (1+shape)/temp100)) /
inequality - 1) / inequality
dl.dshape = -log(temp100) + 1/shape
- dscale.deta = dtheta.deta(Scale, .lscale)
- dinequality.deta = dtheta.deta(inequality, .linequality)
- dshape.deta = dtheta.deta(shape, .lshape)
+ dscale.deta = dtheta.deta(Scale, .lscale, earg= .escale)
+ dinequality.deta = dtheta.deta(inequality, .linequality, earg= .einequality)
+ dshape.deta = dtheta.deta(shape, .lshape, earg= .eshape)
w * cbind(dl.dscale * dscale.deta,
dl.dinequality * dinequality.deta,
dl.dshape * dshape.deta)
- }), list( .lscale=lscale, .linequality=linequality, .lshape=lshape ))),
+ }), list( .lscale=lscale, .linequality=linequality, .lshape=lshape,
+ .escale=escale, .einequality=einequality, .eshape=eshape ))),
weight=eval(substitute(expression({
temp200 = digamma(shape) - digamma(1) - 1
d2scale.deta2 = shape / ((inequality*Scale)^2 * (shape+2))
@@ -6537,12 +7057,14 @@ paretoIV = function(location=0,
wz[,iam(1,3,M)] = dscale.deta * dshape.deta * d2ss.deta2
wz[,iam(2,3,M)] = dinequality.deta * dshape.deta * d2is.deta2
w * wz
- }), list( .lscale=lscale, .linequality=linequality, .lshape=lshape ))))
+ }), list( .lscale=lscale, .linequality=linequality, .lshape=lshape,
+ .escale=escale, .einequality=einequality, .eshape=eshape ))))
}
paretoIII = function(location=0,
lscale="loge",
linequality="loge",
+ escale=list(), einequality=list(),
iscale=NULL, iinequality=NULL) {
if(mode(lscale) != "character" && mode(lscale) != "name")
lscale = as.character(substitute(lscale))
@@ -6554,21 +7076,24 @@ paretoIII = function(location=0,
stop("argument \"iscale\" must be positive")
if(is.Numeric(iinequality) && any(iinequality <= 0))
stop("argument \"iinequality\" must be positive")
+ if(!is.list(escale)) escale = list()
+ if(!is.list(einequality)) einequality = list()
new("vglmff",
blurb=c("Pareto(III) distribution F(y)=1-[1+((y - ", location,
")/scale)^(1/inequality)]^(-1),",
"\n", " y > ",
location, ", scale > 0, inequality > 0, \n",
- "Links: ", namesof("scale", lscale ), ", ",
- namesof("inequality", linequality ), "\n",
+ "Links: ", namesof("scale", lscale, earg=escale ), ", ",
+ namesof("inequality", linequality, earg=einequality ), "\n",
"Mean: location + scale * NA"), # zz
initialize=eval(substitute(expression({
- predictors.names = c(namesof("scale", .lscale, tag= FALSE),
- namesof("inequality", .linequality, tag= FALSE))
- extra$location = location = .location
if(ncol(cbind(y)) != 1)
stop("the response must be a vector or a one-column matrix")
+ predictors.names =
+ c(namesof("scale", .lscale, earg=.escale, tag=FALSE),
+ namesof("inequality", .linequality, earg=.einequality, tag=FALSE))
+ extra$location = location = .location
if(any(y <= location))
stop("the response must have values > than the \"location\" argument")
if(!length(etastart)) {
@@ -6583,47 +7108,54 @@ paretoIII = function(location=0,
if(!length(scale.init))
scale.init = exp(fittemp$coef["Intercept"])
}
- etastart=cbind(theta2eta(rep(scale.init, len=n), .lscale),
- theta2eta(rep(inequality.init, len=n), .linequality))
+ etastart=cbind(
+ theta2eta(rep(scale.init, len=n), .lscale, earg= .escale),
+ theta2eta(rep(inequality.init, len=n), .linequality, earg= .einequality))
}
}), list( .location=location, .lscale=lscale, .linequality=linequality,
- .iscale=iscale, .iinequality=iinequality ))),
+ .escale=escale, .einequality=einequality,
+ .iscale=iscale, .iinequality=iinequality ))),
inverse=eval(substitute(function(eta, extra=NULL) {
location = extra$location
- Scale = eta2theta(eta[,1], .lscale)
- inequality = eta2theta(eta[,2], .linequality)
+ Scale = eta2theta(eta[,1], .lscale, earg= .escale)
+ inequality = eta2theta(eta[,2], .linequality, earg= .einequality)
location + Scale * NA
- }, list( .lscale=lscale, .linequality=linequality ))),
+ }, list( .lscale=lscale, .linequality=linequality,
+ .escale=escale, .einequality=einequality ))),
last=eval(substitute(expression({
misc$link=c("scale"= .lscale, "inequality"= .linequality)
+ misc$earg = list(scale = .escale, inequality= .einequality)
misc$location = extra$location # Use this for prediction
- }), list( .lscale=lscale, .linequality=linequality ))),
+ }), list( .lscale=lscale, .linequality=linequality,
+ .escale=escale, .einequality=einequality ))),
loglikelihood=eval(substitute(
function(mu,y,w,residuals= FALSE,eta, extra=NULL) {
location = extra$location
- Scale = eta2theta(eta[,1], .lscale)
- inequality = eta2theta(eta[,2], .linequality)
+ Scale = eta2theta(eta[,1], .lscale, earg= .escale)
+ inequality = eta2theta(eta[,2], .linequality, earg= .einequality)
zedd = (y - location) / Scale
if(residuals) stop("loglikelihood residuals not implemented yet") else
sum(w * (-log(inequality) - log(Scale) + (1/inequality -1) *
log(zedd) - (1+1) * log(1 + zedd^(1/inequality ))))
- }, list( .lscale=lscale, .linequality=linequality ))),
+ }, list( .lscale=lscale, .linequality=linequality,
+ .escale=escale, .einequality=einequality ))),
vfamily=c("paretoIII"),
deriv=eval(substitute(expression({
location = extra$location
- Scale = eta2theta(eta[,1], .lscale)
- inequality = eta2theta(eta[,2], .linequality)
+ Scale = eta2theta(eta[,1], .lscale, earg= .escale)
+ inequality = eta2theta(eta[,2], .linequality, earg= .einequality)
shape = 1
zedd = (y - location) / Scale
temp100 = 1 + zedd^(1/inequality)
dl.dscale = (shape - (1+shape) / temp100) / (inequality * Scale)
dl.dinequality = ((log(zedd) * (shape - (1+shape)/temp100)) /
inequality - 1) / inequality
- dscale.deta = dtheta.deta(Scale, .lscale)
- dinequality.deta = dtheta.deta(inequality, .linequality)
+ dscale.deta = dtheta.deta(Scale, .lscale, earg= .escale)
+ dinequality.deta = dtheta.deta(inequality, .linequality, earg= .einequality)
w * cbind(dl.dscale * dscale.deta,
dl.dinequality * dinequality.deta)
- }), list( .lscale=lscale, .linequality=linequality ))),
+ }), list( .lscale=lscale, .linequality=linequality,
+ .escale=escale, .einequality=einequality ))),
weight=eval(substitute(expression({
d2scale.deta2 = 1 / ((inequality*Scale)^2 * 3)
d2inequality.deta2 = (1 + 2* trigamma(1)) / (inequality^2 * 3)
@@ -6631,13 +7163,15 @@ paretoIII = function(location=0,
wz[,iam(1,1,M)] = dscale.deta^2 * d2scale.deta2
wz[,iam(2,2,M)] = dinequality.deta^2 * d2inequality.deta2
w * wz
- }), list( .lscale=lscale, .linequality=linequality ))))
+ }), list( .lscale=lscale, .linequality=linequality,
+ .escale=escale, .einequality=einequality ))))
}
paretoII = function(location=0,
lscale="loge",
lshape="loge",
+ escale=list(), eshape=list(),
iscale=NULL, ishape=NULL) {
if(mode(lscale) != "character" && mode(lscale) != "name")
lscale = as.character(substitute(lscale))
@@ -6649,21 +7183,24 @@ paretoII = function(location=0,
stop("argument \"iscale\" must be positive")
if(is.Numeric(ishape) && any(ishape <= 0))
stop("argument \"ishape\" must be positive")
+ if(!is.list(escale)) escale = list()
+ if(!is.list(eshape)) eshape = list()
new("vglmff",
blurb=c("Pareto(II) distribution F(y)=1-[1+(y - ", location,
")/scale]^(-shape),",
"\n", " y > ",
location, ", scale > 0, shape > 0,\n",
- "Links: ", namesof("scale", lscale ), ", ",
- namesof("shape", lshape ), "\n",
+ "Links: ", namesof("scale", lscale, earg=escale ), ", ",
+ namesof("shape", lshape, earg=eshape ), "\n",
"Mean: location + scale * NA"), # zz
initialize=eval(substitute(expression({
- predictors.names = c(namesof("scale", .lscale, tag= FALSE),
- namesof("shape", .lshape, tag= FALSE))
- extra$location = location = .location
if(ncol(cbind(y)) != 1)
stop("the response must be a vector or a one-column matrix")
+ predictors.names =
+ c(namesof("scale", .lscale, earg=.escale, tag=FALSE),
+ namesof("shape", .lshape, earg=.eshape, tag=FALSE))
+ extra$location = location = .location
if(any(y <= location))
stop("the response must have values > than the \"location\" argument")
if(!length(etastart)) {
@@ -6679,44 +7216,51 @@ paretoII = function(location=0,
if(!length(scale.init))
scale.init = exp(fittemp$coef["Intercept"])
}
- etastart=cbind(theta2eta(rep(scale.init, len=n), .lscale),
- theta2eta(rep(shape.init, len=n), .lshape))
+ etastart=cbind(
+ theta2eta(rep(scale.init, len=n), .lscale, earg= .escale),
+ theta2eta(rep(shape.init, len=n), .lshape, earg= .eshape))
}
}), list( .location=location, .lscale=lscale,
- .lshape=lshape, .iscale=iscale, .ishape=ishape ))),
+ .escale=escale, .eshape=eshape,
+ .lshape=lshape, .iscale=iscale, .ishape=ishape ))),
inverse=eval(substitute(function(eta, extra=NULL) {
location = extra$location
- Scale = eta2theta(eta[,1], .lscale)
- shape = eta2theta(eta[,2], .lshape)
+ Scale = eta2theta(eta[,1], .lscale, earg= .escale)
+ shape = eta2theta(eta[,2], .lshape, earg= .eshape)
location + Scale * NA
- }, list( .lscale=lscale, .lshape=lshape ))),
+ }, list( .lscale=lscale, .lshape=lshape,
+ .escale=escale, .eshape=eshape ))),
last=eval(substitute(expression({
misc$link=c("scale"= .lscale, "shape"= .lshape)
+ misc$earg = list(scale = .escale, shape= .eshape)
misc$location = extra$location # Use this for prediction
- }), list( .lscale=lscale, .lshape=lshape ))),
+ }), list( .lscale=lscale, .lshape=lshape,
+ .escale=escale, .eshape=eshape ))),
loglikelihood=eval(substitute(
function(mu,y,w,residuals= FALSE,eta, extra=NULL) {
location = extra$location
- Scale = eta2theta(eta[,1], .lscale)
- shape = eta2theta(eta[,2], .lshape)
+ Scale = eta2theta(eta[,1], .lscale, earg= .escale)
+ shape = eta2theta(eta[,2], .lshape, earg= .eshape)
zedd = (y - location) / Scale
if(residuals) stop("loglikelihood residuals not implemented yet") else
sum(w * (log(shape) - log(Scale) - (shape+1) * log(1 + zedd )))
- }, list( .lscale=lscale, .lshape=lshape ))),
+ }, list( .lscale=lscale, .lshape=lshape,
+ .escale=escale, .eshape=eshape ))),
vfamily=c("paretoII"),
deriv=eval(substitute(expression({
location = extra$location
- Scale = eta2theta(eta[,1], .lscale)
- shape = eta2theta(eta[,2], .lshape)
+ Scale = eta2theta(eta[,1], .lscale, earg= .escale)
+ shape = eta2theta(eta[,2], .lshape, earg= .eshape)
zedd = (y - location) / Scale
temp100 = 1 + zedd
dl.dscale = (shape - (1+shape) / temp100) / (1 * Scale)
dl.dshape = -log(temp100) + 1/shape
- dscale.deta = dtheta.deta(Scale, .lscale)
- dshape.deta = dtheta.deta(shape, .lshape)
+ dscale.deta = dtheta.deta(Scale, .lscale, earg= .escale)
+ dshape.deta = dtheta.deta(shape, .lshape, earg= .eshape)
w * cbind(dl.dscale * dscale.deta,
dl.dshape * dshape.deta)
- }), list( .lscale=lscale, .lshape=lshape ))),
+ }), list( .lscale=lscale, .lshape=lshape,
+ .escale=escale, .eshape=eshape ))),
weight=eval(substitute(expression({
d2scale.deta2 = shape / (Scale^2 * (shape+2))
d2shape.deta2 = 1 / shape^2
@@ -6726,24 +7270,28 @@ paretoII = function(location=0,
wz[,iam(2,2,M)] = dshape.deta^2 * d2shape.deta2
wz[,iam(1,2,M)] = dscale.deta * dshape.deta * d2ss.deta2
w * wz
- }), list( .lscale=lscale, .lshape=lshape ))))
+ }), list( .lscale=lscale, .lshape=lshape,
+ .escale=escale, .eshape=eshape ))))
}
-pareto1 = function(lshape="loge", location=NULL) {
+pareto1 = function(lshape="loge", earg=list(), location=NULL) {
if(mode(lshape) != "character" && mode(lshape) != "name")
lshape = as.character(substitute(lshape))
if(is.Numeric(location) && location <= 0)
stop("argument \"location\" must be positive")
+ if(!is.list(earg)) earg = list()
new("vglmff",
blurb=c("Pareto distribution f(y) = shape * location^shape / y^(shape+1),",
" y>location>0, shape>0\n",
- "Link: ", namesof("shape", lshape), "\n", "\n",
+ "Link: ", namesof("shape", lshape, earg=earg), "\n", "\n",
"Mean: location*shape/(shape-1) for shape>1"),
initialize=eval(substitute(expression({
- predictors.names = namesof("shape", .lshape, tag= FALSE)
+ if(ncol(cbind(y)) != 1)
+ stop("response must be a vector or a one-column matrix")
+ predictors.names = namesof("shape", .lshape, earg=.earg, tag=FALSE)
locationhat = if(!length( .location)) {
locationEstimated = TRUE
min(y)
@@ -6757,38 +7305,39 @@ pareto1 = function(lshape="loge", location=NULL) {
extra$locationEstimated = locationEstimated
if(!length(etastart)) {
k.init = (y + 1/8) / (y - locationhat + 1/8)
- etastart = theta2eta(k.init, .lshape)
+ etastart = theta2eta(k.init, .lshape, earg= .earg)
}
- }), list( .lshape=lshape, .location=location ))),
+ }), list( .lshape=lshape, .earg=earg, .location=location ))),
inverse=eval(substitute(function(eta, extra=NULL) {
- k = eta2theta(eta, .lshape)
+ k = eta2theta(eta, .lshape, earg= .earg)
location = extra$location
ifelse(k>1, k * location / (k-1), NA)
- }, list( .lshape=lshape ))),
+ }, list( .lshape=lshape, .earg=earg ))),
last=eval(substitute(expression({
misc$link = c(k= .lshape)
+ misc$earg = list(k = .earg)
misc$location = extra$location # Use this for prediction
- }), list( .lshape=lshape ))),
+ }), list( .lshape=lshape, .earg=earg ))),
loglikelihood=eval(substitute(
function(mu,y,w,residuals= FALSE,eta, extra=NULL) {
- k = eta2theta(eta, .lshape)
+ k = eta2theta(eta, .lshape, earg= .earg)
location = extra$location
if(residuals) stop("loglikelihood residuals not implemented yet") else
sum(w * (log(k) + k * log(location) - (k+1) * log(y )))
- }, list( .lshape=lshape ))),
+ }, list( .lshape=lshape, .earg=earg ))),
vfamily=c("pareto1"),
deriv=eval(substitute(expression({
location = extra$location
- k = eta2theta(eta, .lshape)
+ k = eta2theta(eta, .lshape, earg= .earg)
dl.dk = 1/k + log(location/y)
- dk.deta = dtheta.deta(k, .lshape)
+ dk.deta = dtheta.deta(k, .lshape, earg= .earg)
w * dl.dk * dk.deta
- }), list( .lshape=lshape ))),
+ }), list( .lshape=lshape, .earg=earg ))),
weight=eval(substitute(expression({
ed2l.dk2 = 1 / k^2
wz = w * dk.deta^2 * ed2l.dk2
wz
- }), list( .lshape=lshape ))))
+ }), list( .lshape=lshape, .earg=earg ))))
}
@@ -6824,7 +7373,7 @@ rpareto = function(n, location, shape) {
}
-tpareto1 = function(lower, upper, lshape="loge", ishape=NULL) {
+tpareto1 = function(lower, upper, lshape="loge", earg=list(), ishape=NULL) {
if(mode(lshape) != "character" && mode(lshape) != "name")
lshape = as.character(substitute(lshape))
if(!is.Numeric(lower, posit=TRUE, allow=1))
@@ -6835,18 +7384,19 @@ tpareto1 = function(lower, upper, lshape="loge", ishape=NULL) {
stop("lower < upper is required")
if(length(ishape) && !is.Numeric(ishape, posit=TRUE))
stop("bad input for argument \"ishape\"")
+ if(!is.list(earg)) earg = list()
new("vglmff",
blurb=c("Truncated Pareto distribution f(y) = shape * lower^shape /",
"(y^(shape+1) * (1-(lower/upper)^shape)),",
" 0 < lower < y < upper < Inf, shape>0\n",
- "Link: ", namesof("shape", lshape), "\n", "\n",
+ "Link: ", namesof("shape", lshape, earg=earg), "\n", "\n",
"Mean: shape*lower^shape*(upper^(1-shape)-lower^(1-shape)) /",
" ((1-shape) * (1-(lower/upper)^shape))"),
initialize=eval(substitute(expression({
if(ncol(cbind(y)) != 1)
- stop("response must be a vector or a 1-column matrix")
- predictors.names = namesof("shape", .lshape, tag= FALSE)
+ stop("response must be a vector or a one-column matrix")
+ predictors.names = namesof("shape", .lshape, earg=.earg, tag=FALSE)
if(any(y <= .lower))
stop(paste("the value of argument \"lower\" is too high",
"(requires 0 < lower < min(y))"))
@@ -6858,44 +7408,46 @@ tpareto1 = function(lower, upper, lshape="loge", ishape=NULL) {
if(!length(etastart)) {
shape.init = if(is.Numeric( .ishape)) 0 * y + .ishape else
(y + 1/8) / (y - .lower + 1/8)
- etastart = theta2eta(shape.init, .lshape)
+ etastart = theta2eta(shape.init, .lshape, earg= .earg)
}
- }), list( .ishape=ishape, .lshape=lshape, .lower=lower, .upper=upper ))),
+ }), list( .ishape=ishape, .earg=earg, .lshape=lshape,
+ .lower=lower, .upper=upper ))),
inverse=eval(substitute(function(eta, extra=NULL) {
- shape = eta2theta(eta, .lshape)
+ shape = eta2theta(eta, .lshape, earg= .earg)
myratio = .lower / .upper
constprop = shape * .lower^shape / (1 - myratio^shape)
constprop * ( .upper^(1-shape) - .lower^(1-shape)) / (1-shape)
- }, list( .lshape=lshape, .lower=lower, .upper=upper ))),
+ }, list( .lshape=lshape, .earg=earg, .lower=lower, .upper=upper ))),
last=eval(substitute(expression({
misc$link = c(shape= .lshape)
+ misc$earg = list(shape = .earg)
misc$lower = extra$lower
misc$upper = extra$upper
misc$expected = TRUE
- }), list( .lshape=lshape, .lower=lower, .upper=upper ))),
+ }), list( .lshape=lshape, .earg=earg, .lower=lower, .upper=upper ))),
loglikelihood=eval(substitute(
function(mu,y,w,residuals= FALSE,eta, extra=NULL) {
- shape = eta2theta(eta, .lshape)
+ shape = eta2theta(eta, .lshape, earg= .earg)
myratio = .lower / .upper
if(residuals) stop("loglikelihood residuals not implemented yet") else
sum(w * (log(shape) + shape * log( .lower) - (shape+1) * log(y) -
log(1 - myratio^shape )))
- }, list( .lshape=lshape, .lower=lower, .upper=upper ))),
+ }, list( .lshape=lshape, .earg=earg, .lower=lower, .upper=upper ))),
vfamily=c("tpareto1"),
deriv=eval(substitute(expression({
- shape = eta2theta(eta, .lshape)
+ shape = eta2theta(eta, .lshape, earg= .earg)
myratio = .lower / .upper
myratio2 = myratio^shape
tmp330 = myratio2 * log(myratio) / (1 - myratio2)
dl.dshape = 1/shape + log( .lower) - log(y) + tmp330
- dshape.deta = dtheta.deta(shape, .lshape)
+ dshape.deta = dtheta.deta(shape, .lshape, earg= .earg)
w * dl.dshape * dshape.deta
- }), list( .lshape=lshape, .lower=lower, .upper=upper ))),
+ }), list( .lshape=lshape, .earg=earg, .lower=lower, .upper=upper ))),
weight=eval(substitute(expression({
ed2l.dshape2 = 1 / shape^2 - tmp330^2 / myratio2
wz = w * dshape.deta^2 * ed2l.dshape2
wz
- }), list( .lshape=lshape, .lower=lower, .upper=upper ))))
+ }), list( .lshape=lshape, .earg=earg, .lower=lower, .upper=upper ))))
}
dtpareto = function(x, lower, upper, shape) {
@@ -6951,58 +7503,64 @@ erfc = function(x)
-wald <- function(link.lambda="loge", init.lambda=NULL)
+wald <- function(link.lambda="loge", earg=list(), init.lambda=NULL)
{
if(mode(link.lambda) != "character" && mode(link.lambda) != "name")
link.lambda = as.character(substitute(link.lambda))
+ if(!is.list(earg)) earg = list()
new("vglmff",
blurb=c("Standard Wald distribution\n\n",
"f(y) = sqrt(lambda/(2*pi*y^3)) * exp(-lambda*(y-1)^2/(2*y)), y&lambda>0",
"\n",
"Link: ",
- namesof("lambda", link.lambda), "\n",
+ namesof("lambda", link.lambda, earg=earg), "\n",
"Mean: ", "1\n",
"Variance: 1 / lambda"),
initialize=eval(substitute(expression({
+ if(ncol(cbind(y)) != 1)
+ stop("response must be a vector or a one-column matrix")
if(any(y <= 0)) stop("Require the response to have positive values")
- predictors.names = c(namesof("lambda", .link.lambda, short= TRUE))
+ predictors.names =
+ namesof("lambda", .link.lambda, earg=.earg, short=TRUE)
if(!length(etastart)) {
initlambda = if(length( .init.lambda)) .init.lambda else
1 / (0.01 + (y-1)^2)
initlambda = rep(initlambda, len=n)
- etastart = cbind(theta2eta(initlambda, link=.link.lambda))
+ etastart = cbind(theta2eta(initlambda, link=.link.lambda, earg= .earg))
}
- }), list( .link.lambda=link.lambda,
+ }), list( .link.lambda=link.lambda, .earg=earg,
.init.lambda=init.lambda ))),
inverse=function(eta, extra=NULL) {
0*eta + 1
},
last=eval(substitute(expression({
- misc$link = c(lambda = .link.lambda)
- }), list( .link.lambda=link.lambda ))),
+ misc$link = c(lambda = .link.lambda )
+ misc$earg = list(lambda = .earg )
+ }), list( .link.lambda=link.lambda, .earg=earg ))),
loglikelihood=eval(substitute(
function(mu, y, w, residuals = FALSE, eta, extra=NULL) {
- lambda = eta2theta(eta, link=.link.lambda)
+ lambda = eta2theta(eta, link=.link.lambda, earg= .earg)
if(residuals) stop("loglikelihood residuals not implemented yet") else
sum(w*(0.5 * log(lambda / (2 * pi * y^3)) -
lambda *(y-1)^2 / (2* y )))
- }, list( .link.lambda=link.lambda ))),
+ }, list( .link.lambda=link.lambda, .earg=earg ))),
vfamily="wald",
deriv=eval(substitute(expression({
- lambda = eta2theta(eta, link=.link.lambda)
+ lambda = eta2theta(eta, link=.link.lambda, earg= .earg)
dl.dlambda = 0.5 / lambda + 1 - 0.5 * (y + 1/y)
- dlambda.deta = dtheta.deta(theta=lambda, link=.link.lambda)
+ dlambda.deta = dtheta.deta(theta=lambda, link=.link.lambda, earg= .earg)
w * cbind(dl.dlambda * dlambda.deta)
- }), list( .link.lambda=link.lambda ))),
+ }), list( .link.lambda=link.lambda, .earg=earg ))),
weight=eval(substitute(expression({
d2l.dlambda2 = 0.5 / (lambda^2)
w * cbind(dlambda.deta^2 * d2l.dlambda2)
- }), list( .link.lambda=link.lambda ))))
+ }), list( .link.lambda=link.lambda, .earg=earg ))))
}
expexp = function(lshape="loge", lscale="loge",
+ eshape=list(), escale=list(),
ishape=1.1, iscale=NULL, # ishape cannot be 1
tolerance = 1.0e-6,
zero=NULL) {
@@ -7018,19 +7576,24 @@ expexp = function(lshape="loge", lscale="loge",
if(!is.Numeric(ishape, posit=TRUE))
stop("bad input for argument \"ishape\"")
ishape[ishape==1] = 1.1 # Fails in @deriv
+ if(!is.list(escale)) escale = list()
+ if(!is.list(eshape)) eshape = list()
new("vglmff",
blurb=c("Exponentiated Exponential Distribution\n",
"Links: ",
- namesof("shape", lshape), ", ",
- namesof("scale", lscale),"\n",
+ namesof("shape", lshape, earg=eshape), ", ",
+ namesof("scale", lscale, earg=escale),"\n",
"Mean: (digamma(shape+1)-digamma(1))/scale"),
constraints=eval(substitute(expression({
constraints = cm.zero.vgam(constraints, x, .zero, M)
}), list( .zero=zero ))),
initialize=eval(substitute(expression({
- predictors.names = c(namesof("shape", .lshape, short=TRUE),
- namesof("scale", .lscale, short=TRUE))
+ if(ncol(cbind(y)) != 1)
+ stop("response must be a vector or a one-column matrix")
+ predictors.names =
+ c(namesof("shape", .lshape, earg=.eshape, short=TRUE),
+ namesof("scale", .lscale, earg=.escale, short=TRUE))
if(!length(etastart)) {
shape.init = if(!is.Numeric( .ishape, posit=TRUE))
stop("argument \"ishape\" must be positive") else
@@ -7038,37 +7601,43 @@ expexp = function(lshape="loge", lscale="loge",
scale.init = if(length( .iscale)) rep(.iscale, len=n) else
(digamma(shape.init+1) - digamma(1)) / (y+1/8)
scale.init = rep(weighted.mean(scale.init, w=w), len=n)
- etastart = cbind(theta2eta(shape.init, .lshape),
- theta2eta(scale.init, .lscale))
+ etastart = cbind(theta2eta(shape.init, .lshape, earg= .eshape),
+ theta2eta(scale.init, .lscale, earg= .escale))
}
- }), list( .lshape=lshape, .lscale=lscale, .iscale=iscale, .ishape=ishape ))),
+ }), list( .lshape=lshape, .lscale=lscale, .iscale=iscale, .ishape=ishape,
+ .eshape=eshape, .escale=escale ))),
inverse=eval(substitute(function(eta, extra=NULL) {
- shape = eta2theta(eta[,1], .lshape)
- scale = eta2theta(eta[,2], .lscale)
+ shape = eta2theta(eta[,1], .lshape, earg= .eshape)
+ scale = eta2theta(eta[,2], .lscale, earg= .escale)
(digamma(shape+1)-digamma(1)) / scale
- }, list( .lshape=lshape, .lscale=lscale ))),
+ }, list( .lshape=lshape, .lscale=lscale,
+ .eshape=eshape, .escale=escale ))),
last=eval(substitute(expression({
misc$link = c("shape"= .lshape, "scale"= .lscale)
+ misc$earg = list(shape= .eshape, scale= .escale)
misc$expected = TRUE
- }), list( .lshape=lshape, .lscale=lscale ))),
+ }), list( .lshape=lshape, .lscale=lscale,
+ .eshape=eshape, .escale=escale ))),
loglikelihood= eval(substitute(
function(mu, y, w, residuals = FALSE, eta, extra=NULL) {
- shape = eta2theta(eta[,1], .lshape)
- scale = eta2theta(eta[,2], .lscale)
+ shape = eta2theta(eta[,1], .lshape, earg= .eshape)
+ scale = eta2theta(eta[,2], .lscale, earg= .escale)
if(residuals) stop("loglikelihood residuals not implemented yet") else
sum(w * (log(shape) + log(scale) +
(shape-1)*log(1-exp(-scale*y)) - scale*y))
- }, list( .lscale=lscale, .lshape=lshape ))),
+ }, list( .lscale=lscale, .lshape=lshape,
+ .eshape=eshape, .escale=escale ))),
vfamily=c("expexp"),
deriv=eval(substitute(expression({
- shape = eta2theta(eta[,1], .lshape)
- scale = eta2theta(eta[,2], .lscale)
+ 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.dshape = 1/shape + log(1-exp(-scale*y))
- dscale.deta = dtheta.deta(scale, .lscale)
- dshape.deta = dtheta.deta(shape, .lshape)
+ dscale.deta = dtheta.deta(scale, .lscale, earg= .escale)
+ dshape.deta = dtheta.deta(shape, .lshape, earg= .eshape)
w * cbind(dl.dshape * dshape.deta, dl.dscale * dscale.deta)
- }), list( .lshape=lshape, .lscale=lscale ))),
+ }), list( .lshape=lshape, .lscale=lscale,
+ .eshape=eshape, .escale=escale ))),
weight=eval(substitute(expression({
d11 = 1 / shape^2 # True for all shape
d22 = d12 = rep(as.numeric(NA), len=n)
@@ -7109,20 +7678,27 @@ expexp = function(lshape="loge", lscale="loge",
}
+
+
+
expexp1 = function(lscale="loge",
+ escale=list(),
iscale=NULL,
ishape=1) {
if(mode(lscale) != "character" && mode(lscale) != "name")
lscale = as.character(substitute(lscale))
+ if(!is.list(escale)) escale = list()
new("vglmff",
blurb=c("Exponentiated Exponential Distribution",
" (profile likelihood estimation)\n",
"Links: ",
- namesof("scale", lscale), "\n",
+ namesof("scale", lscale, earg=escale), "\n",
"Mean: (digamma(shape+1)-digamma(1))/scale"),
initialize=eval(substitute(expression({
- predictors.names = namesof("scale", .lscale, short=TRUE)
+ if(ncol(cbind(y)) != 1)
+ stop("response must be a vector or a one-column matrix")
+ predictors.names = namesof("scale", .lscale, earg=.escale, short=TRUE)
if(length(w) != n || !is.Numeric(w, integer=TRUE, posit=TRUE))
stop("weights must be a vector of positive integers")
if(!intercept.only)
@@ -7136,46 +7712,49 @@ expexp1 = function(lscale="loge",
rep(.ishape, len=n)
scaleinit = if(length( .iscale)) rep(.iscale, len=n) else
(digamma(shape.init+1) - digamma(1)) / (y+1/8)
- etastart = cbind(theta2eta(scaleinit, .lscale))
+ etastart = cbind(theta2eta(scaleinit, .lscale, earg= .escale))
}
- }), list( .lscale=lscale, .iscale=iscale, .ishape=ishape ))),
+ }), list( .lscale=lscale, .iscale=iscale, .ishape=ishape,
+ .escale=escale ))),
inverse=eval(substitute(function(eta, extra=NULL) {
- scale = eta2theta(eta, .lscale)
+ scale = eta2theta(eta, .lscale, earg= .escale)
temp7 = 1 - exp(-scale*extra$yvector)
shape = -extra$sumw / sum(extra$w*log(temp7)) # \gamma(\theta)
(digamma(shape+1)-digamma(1)) / scale
- }, list( .lscale=lscale ))),
+ }, list( .lscale=lscale,
+ .escale=escale ))),
last=eval(substitute(expression({
misc$link = c("scale"= .lscale)
+ misc$earg = list(scale= .escale)
temp7 = 1 - exp(-scale*y)
shape = -extra$sumw / sum(w*log(temp7)) # \gamma(\theta)
misc$shape = shape # Store the ML estimate here
misc$pooled.weight = pooled.weight
- }), list( .lscale=lscale ))),
+ }), list( .lscale=lscale, .escale=escale ))),
loglikelihood= eval(substitute(
function(mu, y, w, residuals = FALSE, eta, extra=NULL) {
- scale = eta2theta(eta, .lscale)
+ scale = eta2theta(eta, .lscale, earg= .escale)
temp7 = 1 - exp(-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) +
(shape-1)*log(1-exp(-scale*y)) - scale*y))
- }, list( .lscale=lscale ))),
+ }, list( .lscale=lscale, .escale=escale ))),
vfamily=c("expexp1"),
deriv=eval(substitute(expression({
- scale = eta2theta(eta, .lscale)
+ scale = eta2theta(eta, .lscale, earg= .escale)
temp6 = exp(-scale*y)
temp7 = 1-temp6
shape = -extra$sumw / sum(w*log(temp7)) # \gamma(\theta)
d1 = 1/scale + (shape-1)*y*temp6/temp7 - y
- w * cbind(d1 * dtheta.deta(scale, .lscale))
- }), list( .lscale=lscale ))),
+ w * cbind(d1 * dtheta.deta(scale, .lscale, earg= .escale))
+ }), list( .lscale=lscale, .escale=escale ))),
weight=eval(substitute(expression({
d11 = 1/scale^2 + y*(temp6/temp7^2) * ((shape-1) *
(y*temp7+temp6) - y*temp6 / (log(temp7))^2)
wz = matrix(0, n, dimm(M))
- wz[,iam(1,1,M)] = dtheta.deta(scale, .lscale)^2 * d11 -
- d2theta.deta2(scale, .lscale) * d1
+ wz[,iam(1,1,M)] = dtheta.deta(scale, .lscale, earg= .escale)^2 * d11 -
+ d2theta.deta2(scale, .lscale, earg= .escale) * d1
if(FALSE && intercept.only) {
sumw = sum(w)
@@ -7186,7 +7765,7 @@ expexp1 = function(lscale="loge",
} else
pooled.weight = FALSE
w * wz
- }), list( .lscale=lscale ))))
+ }), list( .lscale=lscale, .escale=escale ))))
}
@@ -7198,7 +7777,8 @@ betaffqn.control <- function(save.weight=TRUE, ...)
-betaffqn = function(link="loge", i1=NULL, i2=NULL, trim=0.05, A=0, B=1)
+betaffqn = function(link="loge", earg=list(),
+ i1=NULL, i2=NULL, trim=0.05, A=0, B=1)
{
if(mode(link) != "character" && mode(link) != "name")
link = as.character(substitute(link))
@@ -7206,6 +7786,7 @@ betaffqn = function(link="loge", i1=NULL, i2=NULL, trim=0.05, A=0, B=1)
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()
new("vglmff",
blurb=c("Two-parameter Beta distribution\n",
@@ -7215,16 +7796,19 @@ betaffqn = function(link="loge", i1=NULL, i2=NULL, trim=0.05, A=0, B=1)
paste("(y-",A,")^(shape1-1) * (",B,
"-y)^(shape2-1), ",A,"<=y<=",B," shape1>0, shape2>0\n\n", sep=""),
"Links: ",
- namesof("shape1", link), ", ",
- namesof("shape2", link)),
+ namesof("shape1", link, earg=earg), ", ",
+ namesof("shape2", link, earg=earg)),
initialize=eval(substitute(expression({
+ if(ncol(cbind(y)) != 1)
+ stop("response must be a vector or a one-column matrix")
if(min(y) <= .A || max(y) >= .B)
stop("data not within (A, B)")
- predictors.names = c(namesof("shape1", .link, short= TRUE),
- namesof("shape2", .link, short= TRUE))
+ predictors.names = c(namesof("shape1", .link, earg=.earg, short=TRUE),
+ namesof("shape2", .link, earg=.earg, short=TRUE))
if(is.numeric(.i1) && is.numeric(.i2)) {
vec = c(.i1, .i2)
- vec = c(theta2eta(vec[1], .link), theta2eta(vec[2], .link))
+ vec = c(theta2eta(vec[1], .link, earg= .earg),
+ theta2eta(vec[2], .link, earg= .earg))
etastart = matrix(vec, n, 2, byrow= TRUE)
}
@@ -7238,33 +7822,35 @@ betaffqn = function(link="loge", i1=NULL, i2=NULL, trim=0.05, A=0, B=1)
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),n,2,byrow=TRUE)
+ etastart = matrix(theta2eta(c(pinit,qinit), .link, earg= .earg),
+ n,2,byrow=TRUE)
}
- }), list( .link=link, .i1=i1, .i2=i2, .trim=trim, .A=A, .B=B ))),
+ }), list( .link=link, .earg=earg, .i1=i1, .i2=i2, .trim=trim, .A=A, .B=B ))),
inverse=eval(substitute(function(eta, extra=NULL) {
- shapes = eta2theta(eta, .link)
+ shapes = eta2theta(eta, .link, earg= .earg)
.A + (.B-.A) * shapes[,1] / (shapes[,1] + shapes[,2])
- }, list( .link=link, .A=A, .B=B ))),
+ }, list( .link=link, .earg=earg, .A=A, .B=B ))),
last=eval(substitute(expression({
misc$link = c(shape1 = .link, shape2 = .link)
+ misc$earg = list(shape1 = .earg, shape2 = .earg)
misc$limits = c(.A, .B)
misc$expected = FALSE
misc$BFGS = TRUE
- }), list( .link=link, .A=A, .B=B ))),
+ }), list( .link=link, .earg=earg, .A=A, .B=B ))),
loglikelihood=eval(substitute(
function(mu, y, w, residuals= FALSE, eta, extra=NULL){
- shapes = eta2theta(eta, .link)
+ shapes = eta2theta(eta, .link, earg= .earg)
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 ))),
+ }, list( .link=link, .earg=earg, .A=A, .B=B ))),
vfamily="betaffqn",
deriv=eval(substitute(expression({
- shapes = eta2theta(eta, .link)
- dshapes.deta = dtheta.deta(shapes, .link)
+ shapes = eta2theta(eta, .link, earg= .earg)
+ dshapes.deta = dtheta.deta(shapes, .link, earg= .earg)
dl.dshapes = cbind(log(y-.A), log(.B-y)) - digamma(shapes) +
digamma(shapes[,1] + shapes[,2]) - log(.B - .A)
if(iter == 1) {
@@ -7276,7 +7862,7 @@ betaffqn = function(link="loge", i1=NULL, i2=NULL, trim=0.05, A=0, B=1)
}
derivnew = w * dl.dshapes * dshapes.deta
derivnew
- }), list( .link=link, .A=A, .B=B ))),
+ }), list( .link=link, .earg=earg, .A=A, .B=B ))),
weight=expression({
if(iter == 1) {
wznew = cbind(matrix(w, n, M), matrix(0, n, dimm(M)-M))
@@ -7294,6 +7880,8 @@ betaffqn = function(link="loge", i1=NULL, i2=NULL, trim=0.05, A=0, B=1)
logistic2 = function(llocation="identity",
lscale="loge",
+ elocation=list(),
+ escale=list(),
ilocation=NULL, iscale=NULL,
method.init=1, zero=NULL) {
if(mode(llocation) != "character" && mode(llocation) != "name")
@@ -7304,12 +7892,14 @@ 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(!is.list(elocation)) elocation = list()
+ if(!is.list(escale)) escale = list()
new("vglmff",
blurb=c("Two-parameter logistic distribution\n\n",
"Links: ",
- namesof("location", llocation), ", ",
- namesof("scale", lscale),
+ namesof("location", llocation, earg=elocation), ", ",
+ namesof("scale", lscale, earg=escale),
"\n", "\n",
"Mean: location", "\n",
"Variance: (pi*scale)^2 / 3"),
@@ -7317,8 +7907,11 @@ logistic2 = function(llocation="identity",
constraints = cm.zero.vgam(constraints, x, .zero, M)
}), list( .zero=zero ))),
initialize=eval(substitute(expression({
- predictors.names = c(namesof("location", .llocation, tag= FALSE),
- namesof("scale", .lscale, tag= FALSE))
+ 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 = y
@@ -7332,38 +7925,45 @@ logistic2 = function(llocation="identity",
if(.llocation == "loge") location.init = abs(location.init) + 0.001
scale.init = if(length(.iscale)) rep(.iscale, len=n) else
rep(1, len=n)
- etastart = cbind(theta2eta(location.init, .llocation),
- theta2eta(scale.init, .lscale))
+ etastart = cbind(
+ theta2eta(location.init, .llocation, earg= .elocation),
+ theta2eta(scale.init, .lscale, earg= .escale))
}
}), list( .method.init=method.init, .ilocation=ilocation,
- .llocation=llocation, .iscale=iscale, .lscale=lscale ))),
+ .elocation=elocation, .escale=escale,
+ .llocation=llocation, .iscale=iscale, .lscale=lscale ))),
inverse=eval(substitute(function(eta, extra=NULL) {
- eta2theta(eta[,1], .llocation)
- }, list( .llocation=llocation ))),
+ eta2theta(eta[,1], .llocation, earg= .elocation)
+ }, list( .llocation=llocation,
+ .elocation=elocation, .escale=escale ))),
last=eval(substitute(expression({
misc$link = c(location=.llocation, scale= .lscale)
- }), list( .llocation=llocation, .lscale=lscale ))),
+ misc$earg = list(location= .elocation, scale= .escale)
+ }), list( .llocation=llocation, .lscale=lscale,
+ .elocation=elocation, .escale=escale ))),
loglikelihood=eval(substitute(
function(mu,y,w,residuals= FALSE,eta, extra=NULL) {
- location = eta2theta(eta[,1], .llocation)
- Scale = eta2theta(eta[,2], .lscale)
+ location = eta2theta(eta[,1], .llocation, earg= .elocation)
+ Scale = eta2theta(eta[,2], .lscale, earg= .escale)
zedd = (y-location) / Scale
if(residuals) stop("loglikelihood residuals not implemented yet") else
sum(w * (-zedd - 2 * log(1+exp(-zedd)) - log(Scale )))
- }, list( .llocation=llocation, .lscale=lscale ))),
+ }, list( .llocation=llocation, .lscale=lscale,
+ .elocation=elocation, .escale=escale ))),
vfamily=c("logistic2"),
deriv=eval(substitute(expression({
- location = eta2theta(eta[,1], .llocation)
- Scale = eta2theta(eta[,2], .lscale)
+ location = eta2theta(eta[,1], .llocation, earg= .elocation)
+ Scale = eta2theta(eta[,2], .lscale, earg= .escale)
zedd = (y-location) / Scale
ezedd = exp(-zedd)
dl.dlocation = (1-ezedd) / ((1 + ezedd) * Scale)
- dlocation.deta = dtheta.deta(location, .llocation)
+ dlocation.deta = dtheta.deta(location, .llocation, earg= .elocation)
dl.dscale = zedd * (1-ezedd) / ((1 + ezedd) * Scale) - 1/Scale
- dscale.deta = dtheta.deta(Scale, .lscale)
+ dscale.deta = dtheta.deta(Scale, .lscale, earg= .escale)
w * cbind(dl.dlocation * dlocation.deta,
dl.dscale * dscale.deta)
- }), list( .llocation=llocation, .lscale=lscale ))),
+ }), list( .llocation=llocation, .lscale=lscale,
+ .elocation=elocation, .escale=escale ))),
weight=eval(substitute(expression({
d2l.location2 = 1 / (3*Scale^2)
d2l.dscale2 = (3 + pi^2) / (9*Scale^2)
@@ -7371,7 +7971,8 @@ logistic2 = function(llocation="identity",
wz[,iam(1,1,M)] = d2l.location2 * dlocation.deta^2
wz[,iam(2,2,M)] = d2l.dscale2 * dscale.deta^2
w * wz
- }), list( .llocation=llocation, .lscale=lscale ))))
+ }), list( .llocation=llocation, .lscale=lscale,
+ .elocation=elocation, .escale=escale ))))
}
@@ -7386,7 +7987,7 @@ laplace.control <- function(save.weight=TRUE, ...)
if(FALSE)
-laplace = function(lscale="loge",
+laplace = function(lscale="loge", escale=list(),
ilocation=NULL, iscale=NULL,
method.init=1, zero=NULL) {
if(mode(lscale) != "character" && mode(lscale) != "name")
@@ -7395,12 +7996,13 @@ laplace = function(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(!is.list(escale)) escale = list()
new("vglmff",
blurb=c("Two-parameter Laplace distribution\n\n",
"Links: ",
- namesof("location", "identity"), ", ",
- namesof("scale", lscale),
+ namesof("location", "identity", earg=list()), ", ",
+ namesof("scale", lscale, earg=escale),
"\n", "\n",
"Mean: location", "\n",
"Variance: 2*scale^2"),
@@ -7408,8 +8010,11 @@ laplace = function(lscale="loge",
constraints = cm.zero.vgam(constraints, x, .zero, M)
}), list( .zero=zero ))),
initialize=eval(substitute(expression({
- predictors.names = c(namesof("location", "identity", tag= FALSE),
- namesof("scale", .lscale, tag= FALSE))
+ if(ncol(cbind(y)) != 1)
+ stop("response must be a vector or a one-column matrix")
+ predictors.names =
+ c(namesof("location", "identity", earg=list(), tag=FALSE),
+ namesof("scale", .lscale, earg=.escale, tag=FALSE))
if(!length(etastart)) {
if( .method.init == 1) {
location.init = median(y)
@@ -7422,36 +8027,37 @@ laplace = function(lscale="loge",
rep(location.init, len=n)
scale.init = if(length(.iscale)) rep(.iscale, len=n) else
rep(1, len=n)
- etastart = cbind(theta2eta(location.init, "identity"),
- theta2eta(scale.init, .lscale))
+ etastart = cbind(theta2eta(location.init, "identity", earg= list()),
+ theta2eta(scale.init, .lscale, earg= .escale))
}
}), list( .method.init=method.init, .ilocation=ilocation,
- .iscale=iscale, .lscale=lscale ))),
+ .escale=escale, .iscale=iscale, .lscale=lscale ))),
inverse=function(eta, extra=NULL) {
eta[,1]
},
last=eval(substitute(expression({
misc$link = c(location="identity", scale= .lscale)
+ misc$earg = list(location=list(), scale= .escale)
misc$expected = FALSE
misc$BFGS = TRUE
- }), list( .lscale=lscale ))),
+ }), list( .escale=escale, .lscale=lscale ))),
loglikelihood=eval(substitute(
function(mu,y,w,residuals= FALSE,eta, extra=NULL) {
- location = eta2theta(eta[,1], "identity")
- Scale = eta2theta(eta[,2], .lscale)
+ location = eta2theta(eta[,1], "identity", earg= list())
+ Scale = eta2theta(eta[,2], .lscale, earg= .escale)
zedd = abs(y-location) / Scale
if(residuals) stop("loglikelihood residuals not implemented yet") else
sum(w * (-zedd - log(Scale )))
- }, list( .lscale=lscale ))),
+ }, list( .escale=escale, .lscale=lscale ))),
vfamily=c("laplace"),
deriv=eval(substitute(expression({
- location = eta2theta(eta[,1], "identity")
- Scale = eta2theta(eta[,2], .lscale)
+ location = eta2theta(eta[,1], "identity", earg= list())
+ Scale = eta2theta(eta[,2], .lscale, earg= .escale)
zedd = abs(y-location) / Scale
dl.dlocation = sign(y-location) / Scale
- dlocation.deta = dtheta.deta(location, "identity")
+ dlocation.deta = dtheta.deta(location, "identity", earg= list())
dl.dscale = zedd / Scale - 1/Scale
- dscale.deta = dtheta.deta(Scale, .lscale)
+ dscale.deta = dtheta.deta(Scale, .lscale, earg= .escale)
if(iter == 1) {
etanew = eta
} else {
@@ -7462,7 +8068,7 @@ laplace = function(lscale="loge",
derivnew = w * cbind(dl.dlocation * dlocation.deta,
dl.dscale * dscale.deta)
derivnew
- }), list( .lscale=lscale ))),
+ }), list( .escale=escale, .lscale=lscale ))),
weight=eval(substitute(expression({
if(iter == 1) {
wznew = cbind(matrix(w, n, M), matrix(0, n, dimm(M)-M))
@@ -7473,7 +8079,7 @@ laplace = function(lscale="loge",
trace=trace) # weights incorporated in args
}
wznew
- }), list( .lscale=lscale ))))
+ }), list( .escale=escale, .lscale=lscale ))))
}
dlaplace = function(x, location=0, scale=1) {
@@ -7496,15 +8102,16 @@ qlaplace = function(p, location=0, scale=1) {
stop("argument \"scale\" must be positive")
L = max(length(p), length(location), length(scale))
p = rep(p, len=L); location = rep(location, len=L); scale= rep(scale, len=L)
- loc - sign(p-0.5) * scale * log(2*ifelse(p < 0.5, p, 1-p))
+ location - sign(p-0.5) * scale * log(2*ifelse(p < 0.5, p, 1-p))
}
rlaplace = function(n, location=0, scale=1) {
if(!is.Numeric(n, posit=TRUE, integ=TRUE, allow=1))
stop("bad input for argument \"n\"")
if(!is.Numeric(scale, posit=TRUE)) stop("\"scale\" must be positive")
+ location = rep(location, len=n); scale= rep(scale, len=n)
r = runif(n)
- loc - sign(r-0.5) * scale * log(2*ifelse(r < 0.5, r, 1-r))
+ location - sign(r-0.5) * scale * log(2*ifelse(r < 0.5, r, 1-r))
}
@@ -7515,7 +8122,7 @@ fff.control <- function(save.weight=TRUE, ...)
list(save.weight=save.weight)
}
-fff = function(link="loge",
+fff = function(link="loge", earg=list(),
idf1=NULL, idf2=NULL,
method.init=1, zero=NULL) {
if(mode(link) != "character" && mode(link) != "name")
@@ -7524,12 +8131,13 @@ fff = function(link="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(!is.list(earg)) earg = list()
new("vglmff",
blurb=c("F-distribution\n\n",
"Links: ",
- namesof("df1", link), ", ",
- namesof("df2", link),
+ namesof("df1", link, earg=earg), ", ",
+ namesof("df2", link, earg=earg),
"\n", "\n",
"Mean: df2/(df2-2) provided df2>2", "\n",
"Variance: 2*df2^2*(df1+df2-2)/(df1*(df2-2)^2*(df2-4)) provided df2>4"),
@@ -7537,8 +8145,10 @@ fff = function(link="loge",
constraints = cm.zero.vgam(constraints, x, .zero, M)
}), list( .zero=zero ))),
initialize=eval(substitute(expression({
- predictors.names = c(namesof("df1", .link, tag= FALSE),
- namesof("df2", .link, tag= FALSE))
+ if(ncol(cbind(y)) != 1)
+ stop("response must be a vector or a one-column matrix")
+ predictors.names = c(namesof("df1", .link, earg=.earg, tag=FALSE),
+ namesof("df2", .link, earg=.earg, tag=FALSE))
if(!length(etastart)) {
if( .method.init == 1) {
df2.init = b = 2*mean(y) / (mean(y)-1)
@@ -7554,43 +8164,44 @@ fff = function(link="loge",
df1.init = if(length(.idf1)) rep(.idf1, len=n) else
rep(df1.init, len=n)
df2.init = if(length(.idf2)) rep(.idf2, len=n) else rep(1, len=n)
- etastart = cbind(theta2eta(df1.init, .link),
- theta2eta(df2.init, .link))
+ etastart = cbind(theta2eta(df1.init, .link, earg= .earg),
+ theta2eta(df2.init, .link, earg= .earg))
}
- }), list( .method.init=method.init, .idf1=idf1,
+ }), list( .method.init=method.init, .idf1=idf1, .earg=earg,
.idf2=idf2, .link=link ))),
inverse=eval(substitute(function(eta, extra=NULL) {
- df2 = eta2theta(eta[,2], .link)
+ df2 = eta2theta(eta[,2], .link, earg= .earg)
ans = df2 * NA
ans[df2>2] = df2[df2>2] / (df2[df2>2]-2)
ans
- }, list( .link=link ))),
+ }, list( .link=link, .earg=earg ))),
last=eval(substitute(expression({
misc$link = c(df1= .link, df2= .link)
- }), list( .link=link ))),
+ misc$earg = list(df1= .earg, df2= .earg)
+ }), list( .link=link, .earg=earg ))),
loglikelihood=eval(substitute(
function(mu,y,w,residuals= FALSE,eta, extra=NULL) {
- df1 = eta2theta(eta[,1], .link)
- df2 = eta2theta(eta[,2], .link)
+ df1 = eta2theta(eta[,1], .link, earg= .earg)
+ df2 = eta2theta(eta[,2], .link, earg= .earg)
if(residuals) stop("loglikelihood residuals not implemented yet") else
sum(w * (lgamma(0.5*(df1+df2)) + 0.5*df1*log(df1/df2) +
0.5*(df1-2) * log(y) - lgamma(df1/2) - lgamma(df2/2) -
0.5*(df1+df2)*log(1 + df1*y/df2 )))
- }, list( .link=link ))),
+ }, list( .link=link, .earg=earg ))),
vfamily=c("fff"),
deriv=eval(substitute(expression({
- df1 = eta2theta(eta[,1], .link)
- df2 = eta2theta(eta[,2], .link)
+ df1 = eta2theta(eta[,1], .link, earg= .earg)
+ df2 = eta2theta(eta[,2], .link, earg= .earg)
dl.ddf1 = 0.5*digamma(0.5*(df1+df2)) + 0.5 + 0.5*log(df1/df2) +
0.5*log(y) - 0.5*digamma(0.5*df1) -
0.5*(df1+df2)*(y/df2) / (1 + df1*y/df2) -
0.5*log(1 + df1*y/df2)
- ddf1.deta = dtheta.deta(df1, .link)
+ ddf1.deta = dtheta.deta(df1, .link, earg= .earg)
dl.ddf2 = 0.5*digamma(0.5*(df1+df2)) - 0.5*df1/df2 -
0.5*digamma(0.5*df2) -
0.5*(df1+df2) * (-df1*y/df2^2) / (1 + df1*y/df2) -
0.5*log(1 + df1*y/df2)
- ddf2.deta = dtheta.deta(df2, .link)
+ ddf2.deta = dtheta.deta(df2, .link, earg= .earg)
if(iter == 1) {
etanew = eta
} else {
@@ -7601,7 +8212,7 @@ fff = function(link="loge",
derivnew = w * cbind(dl.ddf1 * ddf1.deta,
dl.ddf2 * ddf2.deta)
derivnew
- }), list( .link=link ))),
+ }), list( .link=link, .earg=earg ))),
weight=eval(substitute(expression({
if(iter == 1) {
wznew = cbind(matrix(w, n, M), matrix(0, n, dimm(M)-M))
@@ -7612,12 +8223,15 @@ fff = function(link="loge",
trace=trace) # weights incorporated in args
}
wznew
- }), list( .link=link ))))
+ }), list( .link=link, .earg=earg ))))
}
-vonmises = function(lscale="loge",
+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(lscale) != "character" && mode(lscale) != "name")
@@ -7626,20 +8240,24 @@ vonmises = function(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(!is.list(escale)) escale = list()
new("vglmff",
blurb=c("Von Mises distribution\n\n",
"Links: ",
- namesof("location", "identity"), ", ",
- namesof("scale", lscale),
+ 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({
- predictors.names = c(namesof("location", "identity", tag= FALSE),
- namesof("scale", .lscale, tag= FALSE))
+ 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)
@@ -7651,39 +8269,46 @@ vonmises = function(lscale="loge",
}
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, "identity"),
- theta2eta(scale.init, .lscale))
+ 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,
- .iscale=iscale, .lscale=lscale ))),
+ .escale=escale, .iscale=iscale,
+ .lscale=lscale, .llocation=llocation, .elocation=elocation ))),
inverse=eval(substitute(function(eta, extra=NULL) {
- eta2theta(eta[,1], "identity") %% (2*pi)
- }, list( .lscale=lscale ))),
+ 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= "identity", scale= .lscale)
- }), list( .lscale=lscale ))),
+ 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], "identity")
- Scale = eta2theta(eta[,2], .lscale)
+ 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( .lscale=lscale ))),
+ }, list( .escale=escale, .lscale=lscale,
+ .llocation=llocation, .elocation=elocation ))),
vfamily=c("vonmises"),
deriv=eval(substitute(expression({
- location = eta2theta(eta[,1], "identity")
- Scale = eta2theta(eta[,2], .lscale)
+ 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, "identity")
+ dlocation.deta = dtheta.deta(location, .llocation, earg= .elocation)
dl.dscale = cos(y - location) - tmp6[,2] / tmp6[,1]
- dscale.deta = dtheta.deta(Scale, .lscale)
+ dscale.deta = dtheta.deta(Scale, .lscale, earg= .escale)
w * cbind(dl.dlocation * dlocation.deta,
dl.dscale * dscale.deta)
- }), list( .lscale=lscale ))),
+ }), 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
@@ -7691,13 +8316,14 @@ vonmises = function(lscale="loge",
wz[,iam(1,1,M)] = d2l.location2 * dlocation.deta^2
wz[,iam(2,2,M)] = d2l.dscale2 * dscale.deta^2
w * wz
- }), list( .lscale=lscale ))))
+ }), list( .escale=escale, .lscale=lscale,
+ .llocation=llocation, .elocation=elocation ))))
}
-hyper = function(N=NULL, D=NULL,
- lprob="logit",
+hyperg = function(N=NULL, D=NULL,
+ lprob="logit", earg=list(),
iprob=NULL) {
if(mode(lprob) != "character" && mode(lprob) != "name")
lprob = as.character(substitute(lprob))
@@ -7707,11 +8333,12 @@ hyper = function(N=NULL, D=NULL,
stop("only one of \"N\" and \"D\" is to be inputted")
if(!inputD && !inputN)
stop("one of \"N\" and \"D\" needs to be inputted")
+ if(!is.list(earg)) earg = list()
new("vglmff",
blurb=c("Hypergeometric distribution\n\n",
"Link: ",
- namesof("prob", lprob), "\n",
+ namesof("prob", lprob, earg=earg), "\n",
"Mean: D/N\n"),
initialize=eval(substitute(expression({
NCOL = function (x)
@@ -7736,7 +8363,7 @@ hyper = function(N=NULL, D=NULL,
} else
stop("Response not of the right form")
- predictors.names = namesof("prob", .lprob, tag= FALSE)
+ predictors.names = namesof("prob", .lprob, earg=.earg, tag=FALSE)
extra$Nvector = .N
extra$Dvector = .D
extra$Nunknown = length(extra$Nvector) == 0
@@ -7744,18 +8371,19 @@ hyper = function(N=NULL, D=NULL,
init.prob = if(length( .iprob)) rep( .iprob, len=n) else mustart
etastart = matrix(init.prob, n, ncol(cbind(y )))
}
- }), list( .lprob=lprob, .N=N, .D=D, .iprob=iprob ))),
+ }), list( .lprob=lprob, .earg=earg, .N=N, .D=D, .iprob=iprob ))),
inverse=eval(substitute(function(eta, extra=NULL) {
- eta2theta(eta, .lprob)
- }, list( .lprob=lprob ))),
+ eta2theta(eta, .lprob, earg= .earg)
+ }, list( .lprob=lprob, .earg=earg ))),
last=eval(substitute(expression({
misc$link = c("prob"= .lprob)
+ misc$earg = list("prob"= .earg)
misc$Dvector = .D
misc$Nvector = .N
- }), list( .N=N, .D=D, .lprob=lprob ))),
+ }), list( .N=N, .D=D, .lprob=lprob, .earg=earg ))),
link=eval(substitute(function(mu, extra=NULL) {
- theta2eta(mu, .lprob)
- }, list( .lprob=lprob ))),
+ theta2eta(mu, .lprob, earg= .earg)
+ }, list( .lprob=lprob, .earg=earg ))),
loglikelihood=eval(substitute(
function(mu, y, w, residuals = FALSE, eta, extra=NULL) {
N = extra$Nvector
@@ -7771,11 +8399,11 @@ hyper = function(N=NULL, D=NULL,
sum(lgamma(1+N*prob) + lgamma(1+N*(1-prob)) -
lgamma(1+N*prob-yvec) - lgamma(1+N*(1-prob) -w + yvec))
}
- }, list( .lprob=lprob ))),
- vfamily=c("hyper"),
+ }, list( .lprob=lprob, .earg=earg ))),
+ vfamily=c("hyperg"),
deriv=eval(substitute(expression({
- prob = mu # equivalently, eta2theta(eta, .lprob)
- dprob.deta = dtheta.deta(prob, .lprob)
+ prob = mu # equivalently, eta2theta(eta, .lprob, earg= .earg)
+ dprob.deta = dtheta.deta(prob, .lprob, earg= .earg)
Dvec = extra$Dvector
Nvec = extra$Nvector
yvec = w * y
@@ -7789,7 +8417,7 @@ hyper = function(N=NULL, D=NULL,
digamma(1+Nvec*prob-yvec) + digamma(1+Nvec*(1-prob)-w+yvec))
}
w * dl.dprob * dprob.deta
- }), list( .lprob=lprob ))),
+ }), list( .lprob=lprob, .earg=earg ))),
weight=eval(substitute(expression({
if(extra$Nunknown) {
tmp722 = tmp72^2
@@ -7808,12 +8436,12 @@ hyper = function(N=NULL, D=NULL,
trigamma(1+Nvec*prob-yvec) -
trigamma(1+Nvec*(1-prob)-w+yvec))
}
- d2prob.deta2 = d2theta.deta2(prob, .lprob)
+ d2prob.deta2 = d2theta.deta2(prob, .lprob, earg= .earg)
wz = -(dprob.deta^2) * d2l.dprob2 - d2prob.deta2 * dl.dprob
wz = w * wz
wz[wz < .Machine$double.eps] = .Machine$double.eps
wz
- }), list( .lprob=lprob ))))
+ }), list( .lprob=lprob, .earg=earg ))))
}
@@ -7860,7 +8488,7 @@ rbenini = function(n, shape, y0) {
}
benini = function(y0=stop("argument \"y0\" must be specified"),
- lshape="loge",
+ lshape="loge", earg=list(),
ishape=NULL, method.init=1) {
if(mode(lshape) != "character" && mode(lshape) != "name")
lshape = as.character(substitute(lshape))
@@ -7868,15 +8496,17 @@ benini = function(y0=stop("argument \"y0\" must be specified"),
method.init > 2) stop("argument \"method.init\" must be 1 or 2")
if(!is.Numeric(y0, allow=1, posit=TRUE))
stop("bad input for argument \"y0\"")
+ if(!is.list(earg)) earg = list()
new("vglmff",
blurb=c("1-parameter Benini distribution\n\n",
"Link: ",
- namesof("shape", lshape),
- "\n", "\n",
- "Mean: zz"),
+ namesof("shape", lshape, earg=earg),
+ "\n", "\n"),
initialize=eval(substitute(expression({
- predictors.names = c(namesof("shape", .lshape, tag= FALSE))
+ if(ncol(cbind(y)) != 1)
+ stop("response must be a vector or a one-column matrix")
+ predictors.names = c(namesof("shape", .lshape, earg=.earg, tag=FALSE))
extra$y0 = .y0
if(min(y) <= extra$y0) stop("argument \"y0\" is too large")
if(!length(etastart)) {
@@ -7889,40 +8519,41 @@ benini = function(y0=stop("argument \"y0\" must be specified"),
}
shape.init = if(length(.ishape)) rep(.ishape, len=n) else
rep(shape.init, len=n)
- etastart = cbind(theta2eta(shape.init, .lshape))
+ etastart = cbind(theta2eta(shape.init, .lshape, earg= .earg))
}
- }), list( .method.init=method.init, .ishape=ishape, .lshape=lshape,
+ }), list( .method.init=method.init, .ishape=ishape, .lshape=lshape, .earg=earg,
.y0=y0 ))),
inverse=eval(substitute(function(eta, extra=NULL) {
- shape = eta2theta(eta, .lshape)
+ shape = eta2theta(eta, .lshape, earg= .earg)
temp = 1/(4*shape)
extra$y0 * exp(temp) *
((sqrt(pi) * (1 - pgamma(temp, 0.5 ))) / (2*sqrt(shape)) +
1 - pgamma(temp, 1))
- }, list( .lshape=lshape ))),
+ }, list( .lshape=lshape, .earg=earg ))),
last=eval(substitute(expression({
misc$link = c(shape= .lshape)
- }), list( .lshape=lshape ))),
+ misc$earg = list(shape= .earg )
+ }), list( .lshape=lshape, .earg=earg ))),
loglikelihood=eval(substitute(
function(mu,y,w,residuals= FALSE,eta, extra=NULL) {
- shape = eta2theta(eta, .lshape)
+ shape = eta2theta(eta, .lshape, earg= .earg)
y0 = extra$y0
if(residuals) stop("loglikelihood residuals not implemented yet") else
sum(w * (log(shape) - log(y) - shape*(log(y/y0))^2 + log(log(y/y0 ))))
- }, list( .lshape=lshape ))),
+ }, list( .lshape=lshape, .earg=earg ))),
vfamily=c("benini"),
deriv=eval(substitute(expression({
- shape = eta2theta(eta, .lshape)
+ shape = eta2theta(eta, .lshape, earg= .earg)
y0 = extra$y0
dl.dshape = 1/shape - (log(y/y0))^2
- dshape.deta = dtheta.deta(shape, .lshape)
+ dshape.deta = dtheta.deta(shape, .lshape, earg= .earg)
w * dl.dshape * dshape.deta
- }), list( .lshape=lshape ))),
+ }), list( .lshape=lshape, .earg=earg ))),
weight=eval(substitute(expression({
d2l.dshape2 = 1 / shape^2
wz = d2l.dshape2 * dshape.deta^2
w * wz
- }), list( .lshape=lshape ))))
+ }), list( .lshape=lshape, .earg=earg ))))
}
@@ -7965,3 +8596,6 @@ rpolono = function(n, meanlog=0, sdlog=1) {
+
+
+
diff --git a/R/family.zeroinf.q b/R/family.zeroinf.q
index 939631e..03f01fb 100644
--- a/R/family.zeroinf.q
+++ b/R/family.zeroinf.q
@@ -4,6 +4,9 @@
+
+
+
dzipois = function(x, lambda, phi=0) {
L = max(length(x), length(lambda), length(phi))
x = rep(x, len=L); lambda = rep(lambda, len=L); phi = rep(phi, len=L);
@@ -132,19 +135,22 @@ yip88 = function(link.lambda="loge", n.arg=NULL)
-zapoisson = function(lp0="logit", llambda="loge")
+zapoisson = function(lp0="logit", llambda="loge",
+ ep0=list(), elambda=list())
{
if(mode(lp0) != "character" && mode(lp0) != "name")
lp0 = as.character(substitute(lp0))
if(mode(llambda) != "character" && mode(llambda) != "name")
llambda = as.character(substitute(llambda))
+ if(!is.list(ep0)) ep0 = list()
+ if(!is.list(elambda)) elambda = list()
new("vglmff",
blurb=c(
"Zero-altered Poisson (binomial and positive-Poisson conditional model)\n\n",
"Links: ",
- namesof("p0", lp0, tag=FALSE), ", ",
- namesof("lambda", llambda, tag=FALSE),
+ namesof("p0", lp0, earg=ep0, tag=FALSE), ", ",
+ namesof("lambda", llambda, earg= .elambda, tag=FALSE),
"\n"),
initialize=eval(substitute(expression({
y = as.matrix(y)
@@ -155,33 +161,41 @@ zapoisson = function(lp0="logit", llambda="loge")
mynames1 = if(ncoly==1) "p0" else paste("p0", 1:ncoly, sep="")
mynames2 = if(ncoly==1) "lambda" else paste("lambda", 1:ncoly, sep="")
- predictors.names = c(namesof(mynames1, .lp0, tag=FALSE),
- namesof(mynames2, .llambda, tag=FALSE))
+ predictors.names =
+ c(namesof(mynames1, .lp0, earg= .ep0, tag=FALSE),
+ namesof(mynames2, .llambda, earg= .elambda, tag=FALSE))
if(!length(etastart)) {
- etastart = cbind(theta2eta((0.5 + w * y0) / (1 + w), .lp0),
+ etastart = cbind(theta2eta((0.5+w*y0)/(1+w), .lp0, earg= .ep0 ),
matrix(1, n, NOS)) # 1 here is any old value
for(spp. in 1:NOS)
etastart[!skip.these[,spp.],NOS+spp.] =
theta2eta(y[!skip.these[,spp.],spp.] /
- (1-exp(-y[!skip.these[,spp.],spp.])), .llambda)
+ (1-exp(-y[!skip.these[,spp.],spp.])), .llambda,
+ earg= .elambda )
}
- }), list( .lp0=lp0, .llambda=llambda ))),
+ }), list( .lp0=lp0, .llambda=llambda, .ep0= ep0, .elambda= elambda ))),
inverse=eval(substitute(function(eta, extra=NULL) {
NOS = extra$NOS
- p0 = eta2theta(eta[,1:NOS], .lp0)
- lambda = eta2theta(eta[,NOS+(1:NOS)], .llambda)
+ p0 = eta2theta(eta[,1:NOS], .lp0, earg= .ep0)
+ lambda = eta2theta(eta[,NOS+(1:NOS)], .llambda, earg= .elambda)
(1-p0) * (lambda / (1-exp(-lambda)))
- }, list( .lp0=lp0, .llambda=llambda ))),
+ }, list( .lp0=lp0, .llambda=llambda, .ep0= ep0, .elambda= elambda ))),
last=eval(substitute(expression({
misc$link = c(rep( .lp0, len=NOS), rep( .llambda, len=NOS))
names(misc$link) = c(mynames1, mynames2)
- }), list( .lp0=lp0, .llambda=llambda ))),
+ misc$earg = vector("list", 2*NOS)
+ names(misc$earg) = c(mynames1, mynames2)
+ for(ii in 1:NOS) {
+ misc$earg[[ ii]] = .ep0
+ misc$earg[[NOS + ii]] = .elambda
+ }
+ }), list( .lp0=lp0, .llambda=llambda, .ep0= ep0, .elambda= elambda ))),
loglikelihood=eval(substitute(
function(mu,y,w,residuals=FALSE, eta,extra=NULL) {
NOS = extra$NOS
- p0 = cbind(eta2theta(eta[,1:NOS], .lp0))
+ p0 = cbind(eta2theta(eta[,1:NOS], .lp0, earg= .ep0))
skip = extra$skip.these
- lambda = cbind(eta2theta(eta[,NOS+(1:NOS)], .llambda))
+ lambda = cbind(eta2theta(eta[,NOS+(1:NOS)], .llambda, earg= .elambda ))
ans = 0
for(spp. in 1:NOS) {
ans = ans + sum(w[skip[,spp.]] * log(p0[skip[,spp.],spp.])) +
@@ -191,30 +205,30 @@ zapoisson = function(lp0="logit", llambda="loge")
y[!skip[,spp.],spp.]*log(lambda[!skip[,spp.],spp.])))
}
ans
- }, list( .lp0=lp0, .llambda=llambda ))),
+ }, list( .lp0=lp0, .llambda=llambda, .ep0= ep0, .elambda= elambda ))),
vfamily=c("zapoisson"),
deriv=eval(substitute(expression({
NOS = extra$NOS
y0 = extra$y0
skip = extra$skip.these
- p0 = cbind(eta2theta(eta[,1:NOS], .lp0))
- lambda = cbind(eta2theta(eta[,NOS+(1:NOS)], .llambda))
+ p0 = cbind(eta2theta(eta[,1:NOS], .lp0, earg= .ep0))
+ lambda = cbind(eta2theta(eta[,NOS+(1:NOS)], .llambda, earg= .ep0))
dl.dlambda = y/lambda - 1 - 1/(exp(lambda)-1)
for(spp. in 1:NOS)
dl.dlambda[skip[,spp.],spp.] = 0
- dlambda.deta = dtheta.deta(lambda, .llambda)
+ dlambda.deta = dtheta.deta(lambda, .llambda, earg= .ep0)
mup0 = p0
temp3 = if(.lp0 == "logit") {
w * (y0 - mup0)
} else
- w * dtheta.deta(mup0, link=.lp0) * (y0/mup0 - 1) / (1-mup0)
+ w * dtheta.deta(mup0, link=.lp0, earg= .ep0) * (y0/mup0 - 1) / (1-mup0)
ans = cbind(temp3, w * dl.dlambda * dlambda.deta)
ans
- }), list( .lp0=lp0, .llambda=llambda ))),
+ }), list( .lp0=lp0, .llambda=llambda, .ep0= ep0, .elambda= elambda ))),
weight=eval(substitute(expression({
wz = matrix( .Machine$double.eps^0.8, n, 2*NOS)
for(spp. in 1:NOS) {
- temp4 = exp(lambda[!skip[,spp.],spp.])
+ temp4 = exp(lambda[!skip[,spp.], spp.])
ed2l.dlambda2 = -temp4 * (1/lambda[!skip[,spp.],spp.] -
1/(temp4-1)) / (temp4-1)
wz[!skip[,spp.],NOS+spp.] = -w[!skip[,spp.]] *
@@ -226,7 +240,7 @@ zapoisson = function(lp0="logit", llambda="loge")
tmp200 = if(.lp0 == "logit") {
cbind(w * tmp100)
} else {
- cbind(w * dtheta.deta(mup0, link= .lp0)^2 / tmp100)
+ cbind(w * dtheta.deta(mup0, link= .lp0, earg= .ep0)^2 / tmp100)
}
for(ii in 1:NOS) {
index200 = abs(tmp200[,ii]) < .Machine$double.eps
@@ -236,12 +250,13 @@ zapoisson = function(lp0="logit", llambda="loge")
}
wz[,1:NOS] = tmp200
wz
- }), list( .lp0=lp0, .llambda=llambda ))))
+ }), list( .lp0=lp0, .llambda=llambda, .ep0= ep0, .elambda= elambda ))))
}
zanegbinomial = function(lp0="logit", lmunb = "loge", lk = "loge",
+ ep0=list(), emunb =list(), ek = list(),
ik = 1, zero = -3, cutoff = 0.995, method.init=3)
{
@@ -258,14 +273,17 @@ zanegbinomial = function(lp0="logit", lmunb = "loge", lk = "loge",
lk = as.character(substitute(lk))
if(mode(lp0) != "character" && mode(lp0) != "name")
lp0 = as.character(substitute(lp0))
+ if(!is.list(ep0)) ep0 = list()
+ if(!is.list(emunb)) emunb = list()
+ if(!is.list(ek)) ek = list()
new("vglmff",
blurb=c("Zero-altered negative binomial (binomial and\n",
"positive-negative binomial conditional model)\n\n",
"Links: ",
- namesof("p0", lp0, tag=FALSE), ", ",
- namesof("munb", lmunb), ", ",
- namesof("k", lk), "\n",
+ namesof("p0", lp0, earg= ep0, tag=FALSE), ", ",
+ namesof("munb", lmunb, earg= emunb, tag=FALSE), ", ",
+ namesof("k", lk, earg= ek, tag=FALSE), "\n",
"Mean: (1-p0) * munb / [1 - (k/(k+munb))^k]"),
constraints=eval(substitute(expression({
temp752 = .zero
@@ -281,9 +299,10 @@ zanegbinomial = function(lp0="logit", lmunb = "loge", lk = "loge",
mynames1 = if(NOS==1) "p0" else paste("p0", 1:NOS, sep="")
mynames2 = if(NOS==1) "munb" else paste("munb", 1:NOS, sep="")
mynames3 = if(NOS==1) "k" else paste("k", 1:NOS, sep="")
- predictors.names = c(namesof(mynames1, .lp0, tag= FALSE),
- namesof(mynames2, .lmunb, tag= FALSE),
- namesof(mynames3, .lk, tag= FALSE))
+ predictors.names =
+ c(namesof(mynames1, .lp0, earg= .ep0, 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)]
extra$y0 = y0 = ifelse(y==0, 1, 0)
extra$ymat = ymat = cbind(y0=y0, y=y)
@@ -301,35 +320,47 @@ zanegbinomial = function(lp0="logit", lmunb = "loge", lk = "loge",
}
kmat0 = matrix( .ik, nrow(y), ncoly, byrow=TRUE) # Initial kmat
pnb0 = (kmat0 / (kmat0 + mu.init))^kmat0
- etastart = cbind(theta2eta((0.5 + w * y0) / (1 + w), .lp0),
- theta2eta(mu.init*(1-pnb0), .lmunb),
- theta2eta(kmat0, .lk))
+ etastart = cbind(theta2eta((0.5 + w * y0) / (1 + w), .lp0, earg= .ep0 ),
+ theta2eta(mu.init*(1-pnb0), .lmunb, earg= .emunb ),
+ theta2eta(kmat0, .lk, earg= .ek ))
etastart = etastart[,interleave.VGAM(ncol(etastart),M=3)]
}
}), list( .lp0=lp0, .lmunb=lmunb, .lk=lk, .ik=ik,
+ .ep0=ep0, .emunb=emunb, .ek=ek,
.method.init=method.init ))),
inverse=eval(substitute(function(eta, extra=NULL) {
NOS = extra$NOS
- p0 = eta2theta(eta[,3*(1:NOS)-2], .lp0) # p(0) from logistic regression
- munb = eta2theta(eta[,3*(1:NOS)-1,drop=FALSE], .lmunb)
- kmat = eta2theta(eta[,3*(1:NOS),drop=FALSE], .lk)
+ p0 = eta2theta(eta[,3*(1:NOS)-2], .lp0, earg= .ep0 )
+ munb = eta2theta(eta[,3*(1:NOS)-1,drop=FALSE], .lmunb, earg= .emunb )
+ kmat = eta2theta(eta[,3*(1:NOS),drop=FALSE], .lk, earg= .ek )
pnb0 = (kmat / (kmat + munb))^kmat # p(0) from negative binomial
(1 - p0) * munb / (1 - pnb0)
- }, list( .lp0=lp0, .lk=lk, .lmunb=lmunb ))),
+ }, list( .lp0=lp0, .lk=lk, .lmunb=lmunb,
+ .ep0=ep0, .emunb=emunb, .ek=ek ))),
last=eval(substitute(expression({
misc$link = c(rep( .lp0, length=NOS), rep( .lmunb, length=NOS),
rep( .lk, length=NOS))
- names(misc$link) = c(mynames1, mynames2, mynames3)
+ 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]] = .ep0
+ misc$earg[[3*ii-1]] = .emunb
+ misc$earg[[3*ii ]] = .ek
+ }
misc$cutoff = .cutoff
misc$method.init = .method.init
}), list( .lp0=lp0, .lmunb=lmunb, .lk=lk, .cutoff=cutoff,
+ .ep0=ep0, .emunb=emunb, .ek=ek,
.method.init=method.init ))),
loglikelihood=eval(substitute(
function(mu,y,w,residuals=FALSE, eta,extra=NULL) {
NOS = extra$NOS
- p0 = eta2theta(eta[,3*(1:NOS)-2,drop=FALSE], .lp0)
- munb = eta2theta(eta[,3*(1:NOS)-1,drop=FALSE], .lmunb)
- kmat = eta2theta(eta[,3*(1:NOS),drop=FALSE], .lk)
+ p0 = eta2theta(eta[,3*(1:NOS)-2,drop=FALSE], .lp0, earg= .ep0 )
+ munb = eta2theta(eta[,3*(1:NOS)-1,drop=FALSE], .lmunb, earg= .emunb )
+ kmat = eta2theta(eta[,3*(1:NOS),drop=FALSE], .lk, earg= .ek )
skip = extra$skip.these
pnb0 = (kmat / (kmat + munb))^kmat
ans = 0.0
@@ -346,15 +377,15 @@ zanegbinomial = function(lp0="logit", lmunb = "loge", lk = "loge",
log1p(-pnb0[!i8,spp.]) else log(1 - pnb0[!i8,spp.]))))
}
ans
- }, list( .lp0=lp0, .lmunb=lmunb, .lk=lk ))),
+ }, list( .lp0=lp0, .lmunb=lmunb, .lk=lk,
+ .ep0=ep0, .emunb=emunb, .ek=ek ))),
vfamily=c("zanegbinomial"),
deriv=eval(substitute(expression({
NOS = extra$NOS
y0 = extra$y0
-
- p0 = eta2theta(eta[,3*(1:NOS)-2], .lp0) # p(0) from logistic regression
- munb = eta2theta(eta[,3*(1:NOS)-1,drop=FALSE], .lmunb)
- kmat = eta2theta(eta[,3*(1:NOS),drop=FALSE], .lk)
+ p0 = eta2theta(eta[,3*(1:NOS)-2], .lp0, earg= .ep0 )
+ munb = eta2theta(eta[,3*(1:NOS)-1,drop=FALSE], .lmunb, earg= .emunb )
+ kmat = eta2theta(eta[,3*(1:NOS),drop=FALSE], .lk, earg= .ek )
skip = extra$skip.these
d3 = deriv3(~ -log(1 - (kmat. /(kmat. + munb. ))^kmat. ),
@@ -377,20 +408,21 @@ zanegbinomial = function(lp0="logit", lmunb = "loge", lk = "loge",
for(spp. in 1:NOS)
dl.dk[skip[,spp.],spp.] = dl.dmunb[skip[,spp.],spp.] = 0
- dmunb.deta = dtheta.deta(munb, .lmunb)
- dk.deta = dtheta.deta(kmat, .lk)
+ dmunb.deta = dtheta.deta(munb, .lmunb, earg= .emunb )
+ dk.deta = dtheta.deta(kmat, .lk, earg= .ek )
myderiv = w * cbind(dl.dmunb * dmunb.deta, dl.dk * dk.deta)
mup0 = p0
temp3 = if(.lp0 == "logit") {
w * (y0 - mup0)
} else
- w * dtheta.deta(mup0, link=.lp0) * (y0/mup0 - 1) / (1-mup0)
+ w * dtheta.deta(mup0, link=.lp0, earg= .ep0 ) * (y0/mup0 - 1) / (1-mup0)
ans = cbind(temp3, myderiv)
ans = ans[,interleave.VGAM(ncol(ans), M=3)]
ans
- }), list( .lp0=lp0, .lmunb=lmunb, .lk=lk ))),
+ }), list( .lp0=lp0, .lmunb=lmunb, .lk=lk,
+ .ep0=ep0, .emunb=emunb, .ek=ek ))),
weight=eval(substitute(expression({
wz = matrix(0, n, 6*NOS-1) # wz is not 'diagonal'
pnb0 = (kmat / (kmat + munb))^kmat
@@ -415,7 +447,7 @@ zanegbinomial = function(lp0="logit", lmunb = "loge", lk = "loge",
tmp200 = if(.lp0 == "logit") {
cbind(w * tmp100)
} else {
- cbind(w * dtheta.deta(mup0, link= .lp0)^2 / tmp100)
+ cbind(w * dtheta.deta(mup0, link= .lp0, earg= .ep0 )^2 / tmp100)
}
for(ii in 1:NOS) {
index200 = abs(tmp200[,ii]) < .Machine$double.eps
@@ -431,7 +463,7 @@ zanegbinomial = function(lp0="logit", lmunb = "loge", lk = "loge",
wz[skip[,spp.],3*NOS+3*(spp.)-1] = 0
}
wz
- }), list( .lp0=lp0, .cutoff=cutoff ))))
+ }), list( .lp0=lp0, .ep0=ep0, .cutoff=cutoff ))))
}
@@ -456,7 +488,9 @@ rposnegbin = function(n, munb, k) {
-zipoisson = function(lphi="logit", llambda="loge", iphi=NULL, zero=NULL)
+zipoisson = function(lphi="logit", llambda="loge",
+ ephi=list(), elambda =list(),
+ iphi=NULL, zero=NULL)
{
if(mode(lphi) != "character" && mode(lphi) != "name")
lphi = as.character(substitute(lphi))
@@ -465,70 +499,80 @@ zipoisson = function(lphi="logit", llambda="loge", iphi=NULL, zero=NULL)
if(is.Numeric(iphi))
if(!is.Numeric(iphi, allow=1, posit=TRUE) || iphi >= 1)
stop("iphi must be a single number inside the interval (0,1)")
+ if(!is.list(ephi)) ephi = list()
+ if(!is.list(elambda)) elambda = list()
new("vglmff",
blurb=c("Zero-inflated Poisson\n\n",
- "Links: ", namesof("phi", lphi), ", ",
- namesof("lambda", llambda), "\n",
+ "Links: ", namesof("phi", lphi, earg= ephi), ", ",
+ namesof("lambda", llambda, earg= elambda), "\n",
"Mean: (1-phi)*lambda"),
constraints=eval(substitute(expression({
constraints <- cm.zero.vgam(constraints, x, .zero, M)
}), list( .zero=zero ))),
initialize=eval(substitute(expression({
if(ncol(as.matrix(y)) != 1) stop("multivariate responses not allowed")
- predictors.names = c( namesof("phi", .lphi, tag=FALSE),
- namesof("lambda", .llambda, tag=FALSE))
+ predictors.names = c(
+ namesof("phi", .lphi, earg= .ephi, tag=FALSE),
+ namesof("lambda", .llambda, earg= .ephi, tag=FALSE))
if(!length(etastart)) {
phi.init = if(length( .iphi)) .iphi else {
sum(w[y==0]) / sum(w)
}
if(phi.init <= 0 || phi.init >=1) phi.init = 0.1 # Last resort
lambda.init = y + 1/8
- etastart = cbind(theta2eta(rep(phi.init, len=n), .lphi),
- theta2eta(lambda.init, .llambda))
+ etastart = cbind(theta2eta(rep(phi.init, len=n), .lphi, earg= .ephi ),
+ theta2eta(lambda.init, .llambda, earg= .ephi ))
}
- }), list( .lphi=lphi, .llambda=llambda, .iphi=iphi ))),
+ }), list( .lphi=lphi, .llambda=llambda,
+ .ephi=ephi, .elambda=elambda,
+ .iphi=iphi ))),
inverse=eval(substitute(function(eta, extra=NULL) {
- phi = eta2theta(eta[,1], .lphi)
- lambda = eta2theta(eta[,2], .llambda)
+ phi = eta2theta(eta[,1], .lphi, earg= .ephi )
+ lambda = eta2theta(eta[,2], .llambda, earg= .elambda )
(1-phi) * lambda
- }, list( .lphi=lphi, .llambda=llambda ))),
+ }, list( .lphi=lphi, .llambda=llambda,
+ .ephi=ephi, .elambda=elambda ))),
last=eval(substitute(expression({
misc$link <- c("phi" = .lphi, "lambda" = .llambda)
+ misc$earg <- list("phi" = .ephi, "lambda" = .elambda)
if(intercept.only) {
- phi = eta2theta(eta[1,1], .lphi)
- lambda = eta2theta(eta[1,2], .llambda)
+ phi = eta2theta(eta[1,1], .lphi, earg= .ephi )
+ lambda = eta2theta(eta[1,2], .llambda, earg= .elambda )
misc$prob0 = phi + (1-phi) * exp(-lambda) # P(Y=0)
}
- }), list( .lphi=lphi, .llambda=llambda ))),
+ }), list( .lphi=lphi, .llambda=llambda,
+ .ephi=ephi, .elambda=elambda ))),
loglikelihood=eval(substitute(
function(mu,y,w,residuals=FALSE, eta, extra=NULL) {
- phi = eta2theta(eta[,1], .lphi)
- lambda = eta2theta(eta[,2], .llambda)
+ phi = eta2theta(eta[,1], .lphi, earg= .ephi )
+ lambda = eta2theta(eta[,2], .llambda, earg= .elambda )
index = (y==0)
tmp8 = phi + (1-phi)*exp(-lambda)
ell0 = log(tmp8[index])
ell1 = log((1-phi[!index]) * dpois(y[!index], lambda= lambda[!index]))
sum(w[index] * ell0) + sum(w[!index] * ell1)
- }, list( .lphi=lphi, .llambda=llambda ))),
+ }, list( .lphi=lphi, .llambda=llambda,
+ .ephi=ephi, .elambda=elambda ))),
vfamily=c("zipoisson"),
deriv=eval(substitute(expression({
- phi = eta2theta(eta[,1], .lphi)
- lambda = eta2theta(eta[,2], .llambda)
+ phi = eta2theta(eta[,1], .lphi, earg= .ephi )
+ lambda = eta2theta(eta[,2], .llambda, earg= .elambda )
tmp8 = phi + (1-phi)*exp(-lambda)
index = (y==0)
dl.dphi = (1-exp(-lambda)) / tmp8
dl.dphi[!index] = -1 / (1-phi[!index])
dl.dlambda = -(1-phi) * exp(-lambda) / tmp8
dl.dlambda[!index] = (y[!index] - lambda[!index]) / lambda[!index]
- dphi.deta = dtheta.deta(phi, .lphi)
- dlambda.deta = dtheta.deta(lambda, .llambda)
+ dphi.deta = dtheta.deta(phi, .lphi, earg= .ephi)
+ dlambda.deta = dtheta.deta(lambda, .llambda, earg= .elambda )
ans = w * cbind(dl.dphi * dphi.deta, dl.dlambda * dlambda.deta)
if(.llambda == "loge" && (any(lambda[!index] < .Machine$double.eps))) {
ans[!index,2] = w[!index] * (y[!index] - lambda[!index])
}
ans
- }), list( .lphi=lphi, .llambda=llambda ))),
+ }), list( .lphi=lphi, .llambda=llambda,
+ .ephi=ephi, .elambda=elambda ))),
weight=eval(substitute(expression({
wz = matrix(as.numeric(NA), nrow=n, ncol=dimm(M))
d2l.dphi2 = (1-exp(-lambda)) / ((1-phi)*tmp8)
@@ -543,13 +587,15 @@ zipoisson = function(lphi="logit", llambda="loge", iphi=NULL, zero=NULL)
wz[ind5,iam(2,2,M)] = (1-phi[ind5]) * .Machine$double.eps
}
w * wz
- }), list( .lphi=lphi, .llambda=llambda ))))
+ }), list( .lphi=lphi, .llambda=llambda,
+ .ephi=ephi, .elambda=elambda ))))
}
zibinomial = function(lphi="logit", link.mu="logit",
+ ephi=list(), emu=list(),
iphi=NULL, zero=1, mv=FALSE)
{
if(as.logical(mv)) stop("argument \"mv\" must be FALSE")
@@ -560,11 +606,13 @@ zibinomial = function(lphi="logit", link.mu="logit",
if(is.Numeric(iphi))
if(!is.Numeric(iphi, allow=1, posit=TRUE) || iphi >= 1)
stop("iphi must be a single number inside the interval (0,1)")
+ if(!is.list(ephi)) ephi = list()
+ if(!is.list(emu)) emu = list()
new("vglmff",
blurb=c("Zero-inflated binomial\n\n",
- "Links: ", namesof("phi", lphi), ", ",
- namesof("mu", link.mu), "\n",
+ "Links: ", namesof("phi", lphi, earg= ephi ), ", ",
+ namesof("mu", link.mu, earg= emu ), "\n",
"Mean: (1-phi) * mu / (1 - (1-mu)^w)"),
constraints=eval(substitute(expression({
constraints <- cm.zero.vgam(constraints, x, .zero, M)
@@ -595,45 +643,53 @@ zibinomial = function(lphi="logit", link.mu="logit",
stop("Response not of the right form (1 or 2 columns required)")
}
- predictors.names = c( namesof("phi", .lphi, tag=FALSE),
- namesof("mu", .link.mu, tag=FALSE))
+ predictors.names = c( namesof("phi", .lphi, earg= .ephi, tag=FALSE),
+ namesof("mu", .link.mu, earg= .emu, tag=FALSE))
phi.init = if(length( .iphi)) .iphi else {
sum(w[y==0]) / sum(w)
}
if(phi.init <= 0 || phi.init >=1) phi.init = 0.1 # Last resort
mustart = cbind(rep(phi.init, len=n), mustart) # 1st coln not a real mu
- }), list( .lphi=lphi, .link.mu=link.mu, .iphi=iphi ))),
+ }), list( .lphi=lphi, .link.mu=link.mu,
+ .ephi=ephi, .emu=emu,
+ .iphi=iphi ))),
inverse=eval(substitute(function(eta, extra=NULL) {
- phi = eta2theta(eta[,1], .lphi)
- mubin = eta2theta(eta[,2], .link.mu)
+ phi = eta2theta(eta[,1], .lphi, earg= .ephi )
+ mubin = eta2theta(eta[,2], .link.mu, earg= .emu )
(1-phi) * mubin
- }, list( .lphi=lphi, .link.mu=link.mu ))),
+ }, list( .lphi=lphi, .link.mu=link.mu,
+ .ephi=ephi, .emu=emu ))),
last=eval(substitute(expression({
misc$link <- c("phi" = .lphi, "mu" = .link.mu)
+ misc$earg <- list("phi" = .ephi, "mu" = .emu )
if(intercept.only && all(w==w[1])) {
- phi = eta2theta(eta[1,1], .lphi)
- mubin = eta2theta(eta[1,2], .link.mu)
+ phi = eta2theta(eta[1,1], .lphi, earg= .ephi )
+ mubin = eta2theta(eta[1,2], .link.mu, earg= .emu )
misc$p0 = phi + (1-phi) * (1-mubin)^w[1] # P(Y=0)
}
- }), list( .lphi=lphi, .link.mu=link.mu ))),
+ }), list( .lphi=lphi, .link.mu=link.mu,
+ .ephi=ephi, .emu=emu ))),
link=eval(substitute(function(mu, extra=NULL)
- cbind(theta2eta(mu[,1], .lphi), theta2eta(mu[,2], .link.mu))
- , list( .lphi=lphi, .link.mu=link.mu) )),
+ cbind(theta2eta(mu[,1], .lphi, earg= .ephi ),
+ theta2eta(mu[,2], .link.mu, earg= .emu ))
+ , list( .lphi=lphi, .link.mu=link.mu,
+ .ephi=ephi, .emu=emu ))),
loglikelihood=eval(substitute(
function(mu,y,w,residuals=FALSE, eta, extra=NULL) {
- phi = eta2theta(eta[,1], .lphi)
- mubin = eta2theta(eta[,2], .link.mu)
+ phi = eta2theta(eta[,1], .lphi, earg= .ephi )
+ mubin = eta2theta(eta[,2], .link.mu, earg= .emu )
index = (y==0)
tmp8 = phi + (1-phi)*(1-mubin)^w
ell0 = log(tmp8[index])
ell1 = log(1-phi[!index]) + dbinom(x=round(w[!index]*y[!index]),
size=w[!index], prob=mubin[!index], log=TRUE)
sum(ell0) + sum(ell1)
- }, list( .lphi=lphi, .link.mu=link.mu ))),
+ }, list( .lphi=lphi, .link.mu=link.mu,
+ .ephi=ephi, .emu=emu ))),
vfamily=c("zibinomial"),
deriv=eval(substitute(expression({
- phi = eta2theta(eta[,1], .lphi)
- mubin = eta2theta(eta[,2], .link.mu)
+ phi = eta2theta(eta[,1], .lphi, earg= .ephi )
+ mubin = eta2theta(eta[,2], .link.mu, earg= .emu )
prob0 = (1-mubin)^w # Actually q^w
tmp8 = phi + (1-phi)*prob0
index = (y==0)
@@ -642,14 +698,15 @@ zibinomial = function(lphi="logit", link.mu="logit",
dl.dmubin = -w * (1-phi) * (1-mubin)^(w-1) / tmp8
dl.dmubin[!index] = w[!index] * (y[!index]/mubin[!index] -
(1-y[!index]) / (1-mubin[!index]))
- dphi.deta = dtheta.deta(phi, .lphi)
- dmubin.deta = dtheta.deta(mubin, .link.mu)
+ dphi.deta = dtheta.deta(phi, .lphi, earg= .ephi )
+ dmubin.deta = dtheta.deta(mubin, .link.mu, earg= .emu )
ans = cbind(dl.dphi * dphi.deta, dl.dmubin * dmubin.deta)
if(.link.mu == "logit") {
ans[!index,2] = w[!index] * (y[!index] - mubin[!index])
}
ans
- }), list( .lphi=lphi, .link.mu=link.mu ))),
+ }), list( .lphi=lphi, .link.mu=link.mu,
+ .ephi=ephi, .emu=emu ))),
weight=eval(substitute(expression({
wz = matrix(as.numeric(NA), nrow=n, ncol=dimm(M))
d2l.dphi2 = (1-mubin^w) / ((1-phi) * tmp8)
@@ -665,7 +722,8 @@ zibinomial = function(lphi="logit", link.mu="logit",
wz[ind6,iam(2,2,M)] = .Machine$double.eps
}
wz
- }), list( .lphi=lphi, .link.mu=link.mu ))))
+ }), list( .lphi=lphi, .link.mu=link.mu,
+ .ephi=ephi, .emu=emu ))))
}
@@ -714,3 +772,7 @@ rzibinom = function(n, size, prob, phi=0) {
}
+
+
+
+
diff --git a/R/links.q b/R/links.q
index 8782a99..5070705 100644
--- a/R/links.q
+++ b/R/links.q
@@ -4,6 +4,12 @@
+ ToString = function(x) paste(x, collapse = ",")
+
+
+
+
+
@@ -116,7 +122,7 @@ d2theta.deta2 <- function(theta, link, earg=list())
"logc", "loge", "logit", "loglog",
"logoff", "nreciprocal", "nloge",
"powl", "probit", "reciprocal", "rhobit",
- "golf", "polf", "nbolf")
+ "golf", "polf", "nbolf", "nbolf2")
loglog <- function(theta, earg=list(), inverse=FALSE, deriv=0,
@@ -130,11 +136,11 @@ loglog <- function(theta, earg=list(), inverse=FALSE, deriv=0,
string <- paste("Log-Log:", string)
return(string)
}
- if(!inverse && is.list(earg) && length(earg))
+ if(!inverse && is.list(earg) && length(earg$bval))
theta[theta <= 1.0] <- earg$bval
if(inverse) {
if(deriv>0) {
- 1 / Recall(theta=theta, earg=earg, inverse=FALSE, deriv)
+ 1 / Recall(theta=theta, earg=earg, inverse=FALSE, deriv=deriv)
} else {
exp(exp(theta))
}
@@ -163,13 +169,13 @@ cloglog <- function(theta, earg=list(), inverse=FALSE, deriv=0,
string <- paste("Complementary log-log:", string)
return(string)
}
- if(!inverse && is.list(earg) && length(earg)) {
+ if(!inverse && is.list(earg) && length(earg$bval)) {
theta[theta <= 0.0] <- earg$bval
theta[theta >= 1.0] <- 1.0 - earg$bval
}
if(inverse) {
if(deriv>0) {
- 1 / Recall(theta=theta, earg=earg, inverse=FALSE, deriv)
+ 1 / Recall(theta=theta, earg=earg, inverse=FALSE, deriv=deriv)
} else {
junk <- exp(theta)
1 - exp(-junk)
@@ -199,13 +205,13 @@ probit <- function(theta, earg=list(), inverse=FALSE, deriv=0,
string <- paste("Probit:", string)
return(string)
}
- if(!inverse && is.list(earg) && length(earg)) {
+ if(!inverse && is.list(earg) && length(earg$bval)) {
theta[theta <= 0.0] <- earg$bval
theta[theta >= 1.0] <- 1-earg$bval
}
if(inverse) {
if(deriv>0) {
- 1/Recall(theta=theta, earg=earg, inverse=FALSE, deriv)
+ 1/Recall(theta=theta, earg=earg, inverse=FALSE, deriv=deriv)
} else {
ans <- pnorm(theta)
if(is.matrix(theta))
@@ -259,11 +265,11 @@ loge <- function(theta, earg=list(), inverse=FALSE, deriv=0,
string <- paste("Log:", string)
return(string)
}
- if(!inverse && is.list(earg) && length(earg))
+ if(!inverse && is.list(earg) && length(earg$bval))
theta[theta <= 0.0] <- earg$bval
if(inverse) {
if(deriv>0) {
- 1/Recall(theta=theta, earg=earg, inverse=FALSE, deriv)
+ 1/Recall(theta=theta, earg=earg, inverse=FALSE, deriv=deriv)
} else {
exp(theta)
}
@@ -289,7 +295,7 @@ identity <- function(theta, earg=list(), inverse=FALSE, deriv=0,
}
if(inverse) {
if(deriv>0) {
- 1 / Recall(theta=theta, earg=earg, inverse=FALSE, deriv)
+ 1 / Recall(theta=theta, earg=earg, inverse=FALSE, deriv=deriv)
} else {
theta
}
@@ -312,7 +318,7 @@ nidentity <- function(theta, earg=list(), inverse=FALSE, deriv=0,
}
if(inverse) {
if(deriv>0) {
- 1 / Recall(theta=theta, earg=earg, inverse=FALSE, deriv)
+ 1 / Recall(theta=theta, earg=earg, inverse=FALSE, deriv=deriv)
} else {
-theta
}
@@ -334,11 +340,11 @@ reciprocal <- function(theta, earg=list(), inverse.arg=FALSE, deriv=0,
string <- paste("Reciprocal:", string)
return(string)
}
- if(!inverse.arg && is.list(earg) && length(earg))
+ if(!inverse.arg && is.list(earg) && length(earg$bval))
theta[theta == 0.0] <- earg$bval
if(inverse.arg) {
if(deriv>0) {
- 1 / Recall(theta=theta, earg=earg, inverse.arg=FALSE, deriv)
+ 1 / Recall(theta=theta, earg=earg, inverse.arg=FALSE, deriv=deriv)
} else {
1/theta
}
@@ -362,11 +368,11 @@ nloge <- function(theta, earg=list(), inverse=FALSE, deriv=0,
string <- paste("Negative log:", string)
return(string)
}
- if(!inverse && is.list(earg) && length(earg))
+ if(!inverse && is.list(earg) && length(earg$bval))
theta[theta <= 0.0] <- earg$bval
if(inverse) {
if(deriv>0) {
- 1/Recall(theta=theta, earg=earg, inverse=FALSE, deriv)
+ 1/Recall(theta=theta, earg=earg, inverse=FALSE, deriv=deriv)
} else {
exp(-theta)
}
@@ -389,7 +395,7 @@ nreciprocal <- function(theta, earg=list(), inverse.arg=FALSE, deriv=0,
string <- paste("Negative reciprocal:", string)
return(string)
}
- if(!inverse.arg && is.list(earg) && length(earg))
+ if(!inverse.arg && is.list(earg) && length(earg$bval))
theta[theta == 0.0] <- earg$bval
if(inverse.arg) {
if(deriv>0) {
@@ -455,7 +461,7 @@ rhobit <- function(theta, earg=list(), inverse=FALSE, deriv=0,
if(inverse) {
if(deriv>0) {
- 1/Recall(theta=theta, earg=earg, inverse=FALSE, deriv)
+ 1/Recall(theta=theta, earg=earg, inverse=FALSE, deriv=deriv)
} else {
junk <- exp(theta)
(junk-1.0) / (junk+1.0)
@@ -491,7 +497,7 @@ fisherz <- function(theta, earg=list(), inverse=FALSE, deriv=0,
if(inverse) {
if(deriv>0) {
- 1/Recall(theta=theta, earg=earg, inverse=FALSE, deriv)
+ 1/Recall(theta=theta, earg=earg, inverse=FALSE, deriv=deriv)
} else {
junk <- exp(2*theta)
(junk-1.0)/(junk+1.0)
@@ -507,38 +513,53 @@ fisherz <- function(theta, earg=list(), inverse=FALSE, deriv=0,
-fsqrt <- function(theta, earg=list(), inverse=FALSE, deriv=0,
- short=TRUE, tag=FALSE)
+fsqrt <- function(theta, earg=list(min=0, max=1, mux=sqrt(2)),
+ inverse=FALSE, deriv=0, short=TRUE, tag=FALSE)
{
+ min=0; max=1; mux=sqrt(2)
+ if(!is.list(earg)) stop("earg must be a list")
+ if(is.Numeric(earg$min)) min = earg$min
+ if(is.Numeric(earg$max)) max = earg$max
+ if(is.Numeric(earg$mux)) mux = earg$mux
+ if(!is.Numeric(min,allow=1)) stop("bad input for 'min' component")
+ if(!is.Numeric(max,allow=1)) stop("bad input for 'max' component")
+ if(!is.Numeric(mux,allow=1,posit=TRUE)) stop("bad input for 'mux' component")
+ if(min >= max) stop("'min' >= 'max' is not allowed")
+
if(is.character(theta)) {
string <- if(short)
- paste("fsqrt(",theta,")", sep="") else
- paste("sqrt(2*",theta,") - sqrt(2*(1-",theta,"))", sep="")
+ paste("fsqrt(",theta,")", sep="") else {
+ if(abs(mux-sqrt(2)) < 1.0e-10)
+ paste("sqrt(2*",theta,") - sqrt(2*(1-",theta,"))", sep="") else
+ paste(as.character(mux),
+ " * (sqrt(",theta,"-",min,") - sqrt(",max,"-",theta,"))", sep="")
+ }
if(tag)
string <- paste("Folded Square Root:", string)
return(string)
}
- if(!inverse && is.list(earg) && length(earg)) {
- theta[theta <= 0.0] <- earg$bval
- theta[theta >= 1.0] <- 1.0 - earg$bval
- }
-
if(inverse) {
if(deriv>0) {
1/Recall(theta=theta, earg=earg, inverse=FALSE, deriv=deriv)
} else {
- temp <- theta * sqrt(4-theta^2) / 4
- ans <- 0.5 - temp
- ans[ans<0] <- 0.5 + temp[ans<0]
- ans[ans>1] <- 0.5 + temp[ans>1]
+ mid = (min + max) / 2
+ boundary = mux * sqrt(max - min)
+ temp = pmax(0, (theta/mux)^2 * (2*(max-min) - (theta/mux)^2))
+ ans = theta
+ if(any(ind5 <- theta < 0))
+ ans[ind5] = mid - 0.5 * sqrt(temp[ind5])
+ if(any(ind5 <- theta >= 0))
+ ans[ind5] = mid + 0.5 * sqrt(temp[ind5])
+ ans[theta < -boundary] <- NA
+ ans[theta > boundary] <- NA
ans
}
} else {
switch(deriv+1,
- sqrt(2*theta) - sqrt(2*(1-theta)),
- 1/(1/sqrt(2*theta) + 1/sqrt(2*(1-theta))),
- -sqrt(8) / (theta^(-3/2) - (1-theta)^(-3/2)))
+ mux * (sqrt(theta-min) - sqrt(max-theta)),
+ (2 / mux) / (1/sqrt(theta-min) + 1/sqrt(max-theta)),
+ -(4 / mux) / ((theta-min)^(-3/2) - (max-theta)^(-3/2)))
}
}
@@ -558,7 +579,8 @@ powl <- function(theta, earg=list(power=1), inverse=FALSE, deriv=0,
if(is.character(theta)) {
string <- if(short)
- paste("powl(",theta,",", as.character(exponent), ")", sep="") else
+ paste("powl(",theta,", earg=list(power=", as.character(exponent),
+ "))", sep="") else
paste(theta, "^(", as.character(exponent), ")", sep="")
if(tag)
string <- paste("Power:", string)
@@ -566,7 +588,7 @@ powl <- function(theta, earg=list(power=1), inverse=FALSE, deriv=0,
}
if(inverse) {
if(deriv>0) {
- 1/Recall(theta=theta, earg=earg, inverse=FALSE, deriv)
+ 1/Recall(theta=theta, earg=earg, inverse=FALSE, deriv=deriv)
} else {
theta^(1/exponent)
}
@@ -612,7 +634,7 @@ elogit <- function(theta, earg=list(min=0, max=1), inverse=FALSE, deriv=0,
}
if(inverse) {
if(deriv>0) {
- 1/Recall(theta=theta, earg=earg, inverse=FALSE, deriv)
+ 1/Recall(theta=theta, earg=earg, inverse=FALSE, deriv=deriv)
} else {
junk <- if(is.R()) care.exp(theta) else care.exp(theta)
(A + B*junk) / (1 + junk)
@@ -638,13 +660,13 @@ logit <- function(theta, earg=list(), inverse=FALSE, deriv=0,
string <- paste("Logit:", string)
return(string)
}
- if(!inverse && is.list(earg) && length(earg)) {
+ if(!inverse && is.list(earg) && length(earg$bval)) {
theta[theta <= 0.0] <- earg$bval;
theta[theta >= 1.0] <- 1.0 - earg$bval;
}
if(inverse) {
if(deriv>0) {
- 1/Recall(theta=theta, earg=earg, inverse=FALSE, deriv)
+ 1/Recall(theta=theta, earg=earg, inverse=FALSE, deriv=deriv)
} else {
eta <- care.exp(theta)
eta / (1 + eta)
@@ -669,12 +691,14 @@ logc <- function(theta, earg=list(), inverse=FALSE, deriv=0,
string <- paste("Log Complementary:", string)
return(string)
}
- if(!inverse && is.list(earg) && length(earg)) {
+
+
+ if(!inverse && is.list(earg) && length(earg$bval)) {
theta[theta >= 1.0] <- earg$bval;
}
if(inverse) {
if(deriv>0) {
- 1 / Recall(theta=theta, earg=earg, inverse=FALSE, deriv)
+ 1 / Recall(theta=theta, earg=earg, inverse=FALSE, deriv=deriv)
} else {
1 - exp(theta)
}
@@ -702,7 +726,8 @@ logoff <- function(theta, earg=list(offset=0), inverse=FALSE, deriv=0,
if(is.character(theta)) {
string <- if(short)
- paste("logoff(",theta,", ",as.character(offset),")", sep="") else
+ paste("logoff(",theta,
+ ", list(offset=",as.character(offset),"))", sep="") else
paste("log(", as.character(offset), "+", theta, ")", sep="")
if(tag)
string <- paste("Log with offset:", string)
@@ -766,13 +791,13 @@ cauchit <- function(theta, earg=list(bvalue= .Machine$double.eps),
string <- paste("Cauchit:", string)
return(string)
}
- if(!inverse && is.list(earg) && length(earg)) {
+ if(!inverse && is.list(earg) && length(earg$bval)) {
theta[theta <= 0.0] <- earg$bval
theta[theta >= 1.0] <- 1.0 - earg$bval
}
if(inverse) {
if(deriv>0) {
- 1/Recall(theta=theta, earg=earg, inverse=FALSE, deriv)
+ 1/Recall(theta=theta, earg=earg, inverse=FALSE, deriv=deriv)
} else {
0.5 + atan(theta)/pi
}
@@ -802,10 +827,25 @@ golf <- function(theta, earg=list(lambda=1), inverse=FALSE, deriv=0,
stop("'earg' must be a list")
if(!is.Numeric(lambda, posit=TRUE))
stop('could not determine lambda or lambda has negative values')
+ if(is.Numeric(cutpoint))
+ if(any(cutpoint < 0) || !is.Numeric(cutpoint, integer=TRUE))
+ warning("'cutpoint' should contain non-negative integer values")
if(is.character(theta)) {
- string <- if(short)
- paste("golf(",theta,")", sep="") else {
+ string <- if(short) {
+ lenl = length(lambda) > 1
+ lenc = length(cutpoint) > 1
+ paste("golf(",theta,", earg=list(lambda=",
+ if(lenl) "c(" else "",
+ ToString(lambda),
+ if(lenl) ")" else "",
+ if(is.Numeric(cutpoint))
+ paste(", cutpoint=",
+ if(lenc) "c(" else "",
+ ToString(cutpoint),
+ if(lenc) ")" else "",
+ sep="") else "",
+ "))", sep="") } else {
if(is.Numeric(cutpoint)) {
paste("-3*log(1-qnorm(",theta,")/(3*sqrt(lambda)))",
" + log(cutpoint)", sep="")
@@ -821,8 +861,6 @@ golf <- function(theta, earg=list(lambda=1), inverse=FALSE, deriv=0,
thmat = cbind(theta)
lambda = rep(lambda, len=ncol(thmat)) # Allow recycling for lambda
if(is.Numeric(cutpoint)) cutpoint = rep(cutpoint, len=ncol(thmat))
- if(length(lambda) != ncol(thmat))
- stop(paste("'lambda' should be of length", ncol(thmat)))
if(ncol(thmat) > 1) {
answer = thmat
for(ii in 1:ncol(thmat))
@@ -833,9 +871,10 @@ golf <- function(theta, earg=list(lambda=1), inverse=FALSE, deriv=0,
return(answer)
}
+ answer =
if(inverse) {
if(deriv>0) {
- 1 / Recall(theta=theta, earg=earg, inverse=FALSE, deriv)
+ 1 / Recall(theta=theta, earg=earg, inverse=FALSE, deriv=deriv)
} else {
if(is.Numeric(cutpoint)) {
pnorm((1-care.exp(-(theta-log(cutpoint))/3)) * 3 * sqrt(lambda))
@@ -846,6 +885,8 @@ golf <- function(theta, earg=list(lambda=1), inverse=FALSE, deriv=0,
} else {
smallno = 1 * .Machine$double.eps
Theta = theta
+ Theta = pmin(Theta, 1 - smallno) # Since theta==1 is a possibility
+ Theta = pmax(Theta, smallno) # Since theta==0 is a possibility
Ql = qnorm(Theta)
switch(deriv+1, {
temp = Ql / (3*sqrt(lambda))
@@ -855,28 +896,38 @@ golf <- function(theta, earg=list(lambda=1), inverse=FALSE, deriv=0,
{ stop('cannot handle deriv=2') },
stop("'deriv' unmatched"))
}
+ if(!is.Numeric(answer)) stop("the answer contains some NAs")
+ answer
}
polf <- function(theta, earg=stop("'earg' must be given"),
inverse=FALSE, deriv=0, short=TRUE, tag=FALSE)
{
- if(ncol(cbind(theta)) > 1) {
- }
+ cutpoint = NULL
+ if(is.Numeric(earg)) cutpoint = earg
+ if(is.list(earg)) cutpoint = earg$cutpoint
+ if(!is.Numeric(cutpoint))
+ stop('could not determine the cutpoint')
+ if(any(cutpoint < 0) || !is.Numeric(cutpoint, integer=TRUE))
+ warning("'cutpoint' should contain non-negative integer values")
+
+
if(is.character(theta)) {
- string <- if(short)
- paste("polf(",theta,")", sep="") else
+ string <- if(short) {
+ lenc = length(cutpoint) > 1
+ paste("polf(",theta,", earg=list(cutpoint=",
+ if(lenc) "c(" else "",
+ ToString(cutpoint),
+ if(lenc) ")" else "",
+ "))", sep="")
+ } else
paste("2*log(0.5*qnorm(",theta,") + sqrt(cutpoint+7/8))", sep="")
if(tag)
string <- paste("Poisson-ordinal link function:", string)
return(string)
}
- cutpoint = NULL
- if(is.Numeric(earg)) cutpoint = earg
- if(is.list(earg)) cutpoint = earg$cutpoint
- if(!is.Numeric(cutpoint))
- stop('could not determine the cutpoint')
thmat = cbind(theta)
if(ncol(thmat) > 1) {
@@ -888,55 +939,81 @@ polf <- function(theta, earg=stop("'earg' must be given"),
return(answer)
}
+ answer =
if(inverse) {
if(deriv>0) {
- 1 / Recall(theta=theta, earg=earg, inverse=FALSE, deriv)
+ 1 / Recall(theta=theta, earg=earg, inverse=FALSE, deriv=deriv)
} else {
- pnorm(2 * care.exp(theta/2) - 2 * sqrt(cutpoint + 7/8))
+ if(cutpoint == 0) {
+ cloglog(theta=theta, earg=earg, inverse=inverse, deriv=deriv)
+ } else {
+ pnorm(2 * exp(theta/2) - 2 * sqrt(cutpoint + 7/8))
+ }
}
} else {
- smallno = 1 * .Machine$double.eps
- SMALLNO = 1 * .Machine$double.xmin
- Theta = theta
- Ql = qnorm(Theta)
- switch(deriv+1, {
+ if(cutpoint == 0) {
+ cloglog(theta=theta, earg=earg, inverse=inverse, deriv=deriv)
+ } else {
+ smallno = 1 * .Machine$double.eps
+ SMALLNO = 1 * .Machine$double.xmin
+ Theta = theta
+ Theta = pmin(Theta, 1 - smallno) # Since theta==1 is a possibility
+ Theta = pmax(Theta, smallno) # Since theta==0 is a possibility
+ Ql = qnorm(Theta)
+ switch(deriv+1, {
temp = 0.5 * Ql + sqrt(cutpoint + 7/8)
temp = pmax(temp, SMALLNO)
2 * log(temp)},
(Ql/2 + sqrt(cutpoint + 7/8)) * dnorm(Ql),
{ stop('cannot handle deriv=2') },
stop("'deriv' unmatched"))
+ }
}
+ if(!is.Numeric(answer)) stop("the answer contains some NAs")
+ answer
}
nbolf <- function(theta, earg=stop("'earg' must be given"),
inverse=FALSE, deriv=0, short=TRUE, tag=FALSE)
{
- if(is.character(theta)) {
- string <- if(short)
- paste("nbolf(",theta,")", sep="") else
- paste("2*log(sqrt(k) * sinh(qnorm(",theta,")/(2*sqrt(k)) + ",
- "asinh(sqrt(cutpoint/k))))", sep="")
- if(tag)
- string <- paste("Negative binomial-ordinal link function:", string)
- return(string)
- }
cutpoint = kay = NULL
if(is.list(earg)) {
cutpoint = earg$cutpoint
kay = earg$k
}
+ if(!is.Numeric(kay, positive=TRUE))
+ stop("could not determine 'k' or it is not positive-valued")
if(!is.Numeric(cutpoint))
stop("could not determine the cutpoint")
- if(!is.Numeric(kay))
- stop("could not determine 'k'")
+ if(any(cutpoint < 0) || !is.Numeric(cutpoint, integer=TRUE))
+ warning("'cutpoint' should contain non-negative integer values")
+
+ if(is.character(theta)) {
+ string <- if(short) {
+ lenc = length(cutpoint) > 1
+ lenk = length(kay) > 1
+ paste("nbolf(",theta,", earg=list(cutpoint=",
+ if(lenc) "c(" else "",
+ ToString(cutpoint),
+ if(lenc) ")" else "",
+ ", k=",
+ if(lenk) "c(" else "",
+ ToString(kay),
+ if(lenk) ")" else "",
+ "))", sep="")
+ } else
+ paste("2*log(sqrt(k) * sinh(qnorm(",theta,")/(2*sqrt(k)) + ",
+ "asinh(sqrt(cutpoint/k))))", sep="")
+ if(tag)
+ string <- paste("Negative binomial-ordinal link function:", string)
+ return(string)
+ }
thmat = cbind(theta)
kay = rep(kay, len=ncol(thmat)) # Allow recycling for kay
- if(length(cutpoint) != ncol(thmat))
- stop(paste("'cutpoint' should be of length", ncol(thmat)))
+ cutpoint = rep(cutpoint, len=ncol(thmat)) # Allow recycling for cutpoint
if(ncol(thmat) > 1) {
answer = thmat
for(ii in 1:ncol(thmat))
@@ -946,28 +1023,47 @@ nbolf <- function(theta, earg=stop("'earg' must be given"),
return(answer)
}
+ answer =
if(inverse) {
if(deriv>0) {
- 1 / Recall(theta=theta, earg=earg, inverse=FALSE, deriv)
+ 1 / Recall(theta=theta, earg=earg, inverse=FALSE, deriv=deriv)
} else {
- pnorm((asinh(care.exp(theta/2)/sqrt(kay)) -
- asinh(sqrt(cutpoint/kay))) * 2 * sqrt(kay))
+ if(cutpoint == 0) {
+ 1.0 - (kay / (kay + care.exp(theta)))^kay
+ } else {
+ pnorm((asinh(exp(theta/2)/sqrt(kay)) -
+ asinh(sqrt(cutpoint/kay))) * 2 * sqrt(kay))
+ }
}
} else {
smallno = 1 * .Machine$double.eps
SMALLNO = 1 * .Machine$double.xmin
Theta = theta
- Ql = qnorm(Theta)
- switch(deriv+1, {
- temp = sqrt(kay) * sinh(Ql/(2*sqrt(kay)) +
- asinh(sqrt(cutpoint/kay)))
+ Theta = pmin(Theta, 1 - smallno) # Since theta==1 is a possibility
+ Theta = pmax(Theta, smallno) # Since theta==0 is a possibility
+ if(cutpoint == 0) {
+ switch(deriv+1, {
+ temp = (1 - Theta)^(-1/kay) - 1
temp = pmax(temp, SMALLNO)
- 2 * log(temp)}, {
- arg1 = (Ql/(2*sqrt(kay)) + asinh(sqrt(cutpoint/kay)))
- sqrt(kay) * tanh(arg1) * dnorm(Ql) },
+ log(kay) + log(temp)},
+ (kay / (1 - Theta)^(1/kay) - kay) * (1 - Theta)^(kay+1/kay),
{ stop('cannot handle deriv=2') },
stop("'deriv' unmatched"))
+ } else {
+ Ql = qnorm(Theta)
+ switch(deriv+1, {
+ temp = sqrt(kay) * sinh(Ql/(2*sqrt(kay)) +
+ asinh(sqrt(cutpoint/kay)))
+ temp = pmax(temp, SMALLNO)
+ 2 * log(temp)}, {
+ arg1 = (Ql/(2*sqrt(kay)) + asinh(sqrt(cutpoint/kay)))
+ sqrt(kay) * tanh(arg1) * dnorm(Ql) },
+ { stop('cannot handle deriv=2') },
+ stop("'deriv' unmatched"))
+ }
}
+ if(!is.Numeric(answer)) stop("the answer contains some NAs")
+ answer
}
@@ -977,29 +1073,41 @@ nbolf <- function(theta, earg=stop("'earg' must be given"),
nbolf2 <- function(theta, earg=stop("'earg' must be given"),
inverse=FALSE, deriv=0, short=TRUE, tag=FALSE)
{
- if(is.character(theta)) {
- string <- if(short)
- paste("nbolf2(",theta,")", sep="") else
- paste("3*log(<a complicated expression>)", sep="")
- if(tag)
- string = paste("Negative binomial-ordinal link function 2:", string)
- return(string)
- }
cutpoint = kay = NULL
if(is.list(earg)) {
cutpoint = earg$cutpoint
kay = earg$k
}
+ if(!is.Numeric(kay, positive=TRUE))
+ stop("could not determine 'k' or it is not positive-valued")
if(!is.Numeric(cutpoint))
stop("could not determine the cutpoint")
- if(!is.Numeric(kay))
- stop("could not determine 'k'")
+ if(any(cutpoint < 0) || !is.Numeric(cutpoint, integer=TRUE))
+ warning("'cutpoint' should contain non-negative integer values")
+
+ if(is.character(theta)) {
+ string <- if(short) {
+ lenc = length(cutpoint) > 1
+ lenk = length(kay) > 1
+ paste("nbolf2(",theta,", earg=list(cutpoint=",
+ if(lenc) "c(" else "",
+ ToString(cutpoint),
+ if(lenc) ")" else "",
+ ", k=",
+ if(lenk) "c(" else "",
+ ToString(kay),
+ if(lenk) ")" else "",
+ "))", sep="")
+ } else
+ paste("3*log(<a complicated expression>)", sep="")
+ if(tag)
+ string = paste("Negative binomial-ordinal link function 2:", string)
+ return(string)
+ }
thmat = cbind(theta)
kay = rep(kay, len=ncol(thmat)) # Allow recycling for kay
- if(length(cutpoint) != ncol(thmat))
- stop(paste("'cutpoint' should be of length", ncol(thmat)))
if(ncol(thmat) > 1) {
answer = thmat
for(ii in 1:ncol(thmat))
@@ -1009,16 +1117,20 @@ nbolf2 <- function(theta, earg=stop("'earg' must be given"),
return(answer)
}
+ answer =
if(inverse) {
if(deriv>0) {
- 1 / Recall(theta=theta, earg=earg, inverse=FALSE, deriv)
+ 1 / Recall(theta=theta, earg=earg, inverse=FALSE, deriv=deriv)
} else {
+ if(cutpoint == 0) {
+ 1.0 - (kay / (kay + care.exp(theta)))^kay
+ } else {
a1 = -(9*cutpoint+8) / (cutpoint+1)
a2 = (9*kay-1) / (kay * (cutpoint+1)^(1/3))
a3 = 9 / (kay * (cutpoint+1)^(2/3))
a4 = 9 / (cutpoint+1)
- B = care.exp(theta/3)
+ B = exp(theta/3)
mymat = rbind(a1^2*a2^2 + 2*a1*a2^3*B + B^2*a2^4, 0,
-2*a1*a2*a3*B - 2*a2^2*a3*B^2 - a1^2*a3 - a2^2*a4, 0,
B^2 * a3^2 + a3 * a4)
@@ -1036,33 +1148,48 @@ nbolf2 <- function(theta, earg=stop("'earg' must be given"),
}
}
invfun[,1]
+ }
}
} else {
smallno = 1 * .Machine$double.eps
SMALLNO = 1 * .Machine$double.xmin
Theta = theta
- Ql = qnorm(Theta)
- a1 = -(9*cutpoint+8) / (cutpoint+1)
- a2 = (9*kay-1) / (kay * (cutpoint+1)^(1/3))
- a3 = 9 / (kay * (cutpoint+1)^(2/3))
- a4 = 9 / (cutpoint+1)
- discrim = a1^2 * a3 + a2^2 * a4 - Ql^2 * a3 * a4
- denomin = Ql^2 * a3 - a2^2
- numerat = (a1*a2 - Ql * sqrt(discrim))
- argmax1 = numerat / denomin
- switch(deriv+1, {
- argmax2 = (a1*a2 + Ql * sqrt(discrim)) / denomin
- temp = ifelse(argmax1 > 0, argmax1, argmax2)
+ Theta = pmin(Theta, 1 - smallno) # Since theta==1 is a possibility
+ Theta = pmax(Theta, smallno) # Since theta==0 is a possibility
+ if(cutpoint == 0) {
+ switch(deriv+1, {
+ temp = (1 - Theta)^(-1/kay) - 1
temp = pmax(temp, SMALLNO)
- 3 * log(temp)}, {
- BB = (sqrt(discrim) - Ql^2 * a3 * a4 / sqrt(discrim)) / dnorm(Ql)
- CC = 2 * Ql * a3 / dnorm(Ql)
- dA.dtheta = (-denomin * BB - numerat * CC) / denomin^2
- argmax1 / (3 * dA.dtheta)
- },
+ log(kay) + log(temp)},
+ (kay / (1 - Theta)^(1/kay) - kay) * (1 - Theta)^(kay+1/kay),
{ stop('cannot handle deriv=2') },
stop("'deriv' unmatched"))
+ } else {
+ Ql = qnorm(Theta)
+ a1 = -(9*cutpoint+8) / (cutpoint+1)
+ a2 = (9*kay-1) / (kay * (cutpoint+1)^(1/3))
+ a3 = 9 / (kay * (cutpoint+1)^(2/3))
+ a4 = 9 / (cutpoint+1)
+ discrim = a1^2 * a3 + a2^2 * a4 - Ql^2 * a3 * a4
+ denomin = Ql^2 * a3 - a2^2
+ numerat = (a1*a2 - Ql * sqrt(discrim))
+ argmax1 = numerat / denomin
+ switch(deriv+1, {
+ argmax2 = (a1*a2 + Ql * sqrt(discrim)) / denomin
+ temp = ifelse(argmax1 > 0, argmax1, argmax2)
+ temp = pmax(temp, SMALLNO)
+ 3 * log(temp)}, {
+ BB = (sqrt(discrim) - Ql^2 * a3 * a4 / sqrt(discrim)) / dnorm(Ql)
+ CC = 2 * Ql * a3 / dnorm(Ql)
+ dA.dtheta = (-denomin * BB - numerat * CC) / denomin^2
+ argmax1 / (3 * dA.dtheta)
+ },
+ { stop('cannot handle deriv=2') },
+ stop("'deriv' unmatched"))
+ }
}
+ if(!is.Numeric(answer)) stop("the answer contains some NAs")
+ answer
}
diff --git a/R/plot.vglm.q b/R/plot.vglm.q
index 4ba388f..203d790 100644
--- a/R/plot.vglm.q
+++ b/R/plot.vglm.q
@@ -63,7 +63,7 @@ plotvgam <- function(x, newdata=NULL, y=NULL, residuals=NULL, rugplot=TRUE,
for(rtype in type.residuals)
if(!is.null(residuals <- resid(x, type=rtype))) break
} else {
- residuals=resid(x,typ=type.residuals) #Get the prespecified type
+ residuals=resid(x,typ=type.residuals) #Get the prespecified type
if(!length(residuals))
warning("residuals are NULL. Ignoring residuals=T")
}
@@ -502,6 +502,7 @@ vplot.numeric <- function(x, y, se.y=NULL, xlab, ylab,
+
ylim0 <- ylim
if(length(y)/length(x) != round(length(y)/length(x)))
@@ -609,12 +610,16 @@ vplot.numeric <- function(x, y, se.y=NULL, xlab, ylab,
if(!length(which.cf) ||
(length(which.cf) && any(which.cf==i))) {
- ylim <- range(ylim0, uy[,i], na.rm= TRUE)
- if(se && !is.null(se.y))
- ylim <- range(ylim0, se.lower[,i], se.upper[,i], na.rm= TRUE)
- if(!is.null(residuals))
- ylim <- range(c(ylim, residuals[,i]), na.rm= TRUE)
- ylim <- ylim.scale(ylim, scale)
+ if(is.Numeric(ylim0, allow=2)) {
+ ylim = ylim0
+ } else {
+ ylim <- range(ylim0, uy[,i], na.rm= TRUE)
+ if(se && !is.null(se.y))
+ ylim <- range(ylim0, se.lower[,i], se.upper[,i], na.rm= TRUE)
+ if(!is.null(residuals))
+ ylim <- range(c(ylim, residuals[,i]), na.rm= TRUE)
+ ylim <- ylim.scale(ylim, scale)
+ }
if(ncol(uy)>1 && length(separator))
YLAB <- paste(ylab, separator, i, sep="")
if(!add.arg) {
diff --git a/R/predict.vlm.q b/R/predict.vlm.q
index ffa17e4..df72664 100644
--- a/R/predict.vlm.q
+++ b/R/predict.vlm.q
@@ -142,9 +142,9 @@ predict.vlm <- function(object, newdata=NULL, type=c("response","terms"),
attr(X, "assign") = as.save # Restored
}
- offset <- if (!is.null(off.num<-attr(tt,"offset")))
+ offset <- if (!is.null(off.num<-attr(tt,"offset"))) {
eval(attr(tt,"variables")[[off.num+1]], newdata)
- else if (!is.null(object at offset))
+ } else if (!is.null(object at offset))
eval(object at call$offset, newdata)
if(is.smart(object) && length(object at smart.prediction)) {
@@ -246,12 +246,13 @@ predict.vlm <- function(object, newdata=NULL, type=c("response","terms"),
constant <- attr(pred, "constant")
- if(length(offset) && any(offset != 0))
+ if(type != "terms" && length(offset) && any(offset != 0)) {
if(se.fit) {
pred$fitted.values <- pred$fitted.values + offset
} else {
pred <- pred + offset
}
+ }
if(type == "terms") {
Blist <- subconstraints(object at misc$orig.assign, object at constraints)
diff --git a/R/summary.vgam.q b/R/summary.vgam.q
index 00a36b0..189a8ca 100644
--- a/R/summary.vgam.q
+++ b/R/summary.vgam.q
@@ -110,8 +110,7 @@ printsummary.vgam <- function(x, quote=TRUE, prefix="", digits=options()$digits-
presid <- x at pearson.resid
rdf <- x at df[2]
- if(F && !is.null(presid) && all(!is.na(presid)))
- {
+ if(FALSE && !is.null(presid) && all(!is.na(presid))) {
cat("\nPearson Residuals:\n")
if(rdf/M > 5) {
rq <- apply(as.matrix(presid), 2, quantile) # 5 x M
@@ -170,7 +169,7 @@ printsummary.vgam <- function(x, quote=TRUE, prefix="", digits=options()$digits-
cat("\nNumber of Iterations: ", x at iter, "\n")
if(length(x at anova)) {
- print.vanova(x at anova, dig=digits) # ".vanova" for Splus6
+ printvanova(x at anova, dig=digits) # ".vanova" for Splus6
}
invisible(NULL)
@@ -196,7 +195,7 @@ printsummary.vgam <- function(x, quote=TRUE, prefix="", digits=options()$digits-
-print.vanova <- function(x, digits=.Options$digits, ...)
+printvanova <- function(x, digits=.Options$digits, ...)
{
rrr <- row.names(x)
heading <- attr(x, "heading")
@@ -211,7 +210,8 @@ print.vanova <- function(x, digits=.Options$digits, ...)
x[[i]] <- xx
}
if(is.R()) {
- invisible(NextMethod("print"))
+ print.data.frame(as.data.frame(x, row.names=rrr))
+ invisible(x)
} else {
print.data.frame(as.data.frame(x, row.names=rrr))
invisible(x)
@@ -225,7 +225,7 @@ as.vanova <- function(x, heading)
rrr <- row.names(x)
attr(x, "heading") <- heading
if(is.R()) {
- class(x) <- c("vanova", class(x))
+ x <- as.data.frame(x, row.names=rrr)
} else {
x <- as.data.frame(x, row.names=rrr)
}
@@ -237,7 +237,7 @@ if(!is.R()) {
setMethod("print", "vanova",
function(x, ...)
- print.vanova(x, ...))
+ printvanova(x, ...))
}
diff --git a/R/summary.vglm.q b/R/summary.vglm.q
index deeefee..e78e17f 100644
--- a/R/summary.vglm.q
+++ b/R/summary.vglm.q
@@ -202,6 +202,9 @@ vcovvlm <- function(object, dispersion=NULL, untransform=FALSE) {
if(!object at misc$intercept.only)
stop("object must be an intercept-only fit, i.e., y ~ 1 is the response")
+ if(!all(trivial.constraints(constraints(object))))
+ stop("object must have trivial constraints")
+
M = object at misc$M
Links = object at misc$link
if(length(Links) != M && length(Links) != 1)
diff --git a/data/ruge.R b/data/ruge.R
new file mode 100644
index 0000000..560691f
--- /dev/null
+++ b/data/ruge.R
@@ -0,0 +1,5 @@
+"ruge" <-
+structure(list(counts = c(57,203,383,525,532,408,273,139,45,27,10,4,0,1,1),
+number = c(0,1,2,3,4,5,6,7,8,9,10,11,12,13,14), .Names = c("counts",
+"number"), class = "data.frame", row.names = c("1",
+"2", "3", "4", "5", "6", "7", "8", "9", "10", "11", "12", "13", "14")))
diff --git a/man/AA.Aa.aa.Rd b/man/AA.Aa.aa.Rd
index 9cd267f..cfc72ce 100644
--- a/man/AA.Aa.aa.Rd
+++ b/man/AA.Aa.aa.Rd
@@ -7,7 +7,7 @@
AA-Aa-aa blood group system.
}
\usage{
-AA.Aa.aa(link = "logit", init.pA = NULL)
+AA.Aa.aa(link = "logit", earg=list(), init.pA = NULL)
}
%- maybe also 'usage' for other objects documented here.
\arguments{
@@ -16,6 +16,11 @@ AA.Aa.aa(link = "logit", init.pA = NULL)
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{init.pA}{ Optional initial value for \code{pA}. }
}
\details{
@@ -54,8 +59,6 @@ argument is used to specify the total number of counts for each row.
y = cbind(53, 95, 38)
fit = vglm(y ~ 1, AA.Aa.aa(link="logit"), trace=TRUE)
fit = vglm(y ~ 1, AA.Aa.aa(link="probit"), trace=TRUE)
-fit = vglm(y ~ 1, AA.Aa.aa(link="cloglog", init.p=0.9), trace=TRUE)
-fit = vglm(y ~ 1, AA.Aa.aa(link="identity"), trace=TRUE)
rbind(y, sum(y)*fitted(fit))
Coef(fit) # Estimated pA
summary(fit)
diff --git a/man/AB.Ab.aB.ab.Rd b/man/AB.Ab.aB.ab.Rd
index 314c875..d38d59d 100644
--- a/man/AB.Ab.aB.ab.Rd
+++ b/man/AB.Ab.aB.ab.Rd
@@ -7,7 +7,7 @@
AB-Ab-aB-ab blood group system.
}
\usage{
-AB.Ab.aB.ab(link = "logit", init.p = NULL)
+AB.Ab.aB.ab(link = "logit", earg=list(), init.p = NULL)
}
%- maybe also 'usage' for other objects documented here.
\arguments{
@@ -16,6 +16,11 @@ AB.Ab.aB.ab(link = "logit", init.p = NULL)
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{init.p}{ Optional initial value for \code{p}. }
}
\details{
diff --git a/man/AB.Ab.aB.ab2.Rd b/man/AB.Ab.aB.ab2.Rd
index cd1827d..fe63061 100644
--- a/man/AB.Ab.aB.ab2.Rd
+++ b/man/AB.Ab.aB.ab2.Rd
@@ -7,7 +7,7 @@
the AB-Ab-aB-ab2 blood group system.
}
\usage{
-AB.Ab.aB.ab2(link = "logit", init.p = NULL)
+AB.Ab.aB.ab2(link = "logit", earg=list(), init.p = NULL)
}
%- maybe also 'usage' for other objects documented here.
\arguments{
@@ -16,6 +16,11 @@ AB.Ab.aB.ab2(link = "logit", init.p = NULL)
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{init.p}{ Optional initial value for \code{p}. }
}
\details{
@@ -58,8 +63,6 @@ family function.
# Estimated variance is approx 0.0021
y = cbind(68, 11, 13, 21)
fit = vglm(y ~ 1, AB.Ab.aB.ab2(link=logit), trace=TRUE, crit="coef")
-fit = vglm(y ~ 1, AB.Ab.aB.ab2(link=probit), trace=TRUE, crit="coef")
-fit = vglm(y ~ 1, AB.Ab.aB.ab2(link=identity), trace=TRUE, crit="coef")
fit = vglm(y ~ 1, AB.Ab.aB.ab2(link=cloglog), trace=TRUE, crit="coef")
Coef(fit) # Estimated p
rbind(y, sum(y)*fitted(fit))
diff --git a/man/ABO.Rd b/man/ABO.Rd
index c30294a..af8f545 100644
--- a/man/ABO.Rd
+++ b/man/ABO.Rd
@@ -7,7 +7,7 @@
the ABO blood group system.
}
\usage{
-ABO(link = "logit", ir = NULL, ip = NULL)
+ABO(link = "logit", earg=list(), ir = NULL, ip = NULL)
}
%- maybe also 'usage' for other objects documented here.
\arguments{
@@ -16,6 +16,11 @@ ABO(link = "logit", ir = NULL, ip = NULL)
See \code{\link{Links}} for more choices.
}
+ \item{earg}{
+ List. Extra argument applied to each of the links.
+ See \code{earg} in \code{\link{Links}} for general information.
+
+ }
\item{ir, ip}{ Optional initial value for \code{r} and \code{p}.
A \code{NULL} value means values are computed internally. }
}
@@ -58,8 +63,6 @@ ABO(link = "logit", ir = NULL, ip = NULL)
\examples{
y = cbind(A=725, B=258, AB=72, O=1073) # Order matters, not the name
fit = vglm(y ~ 1, ABO(link=logit), trace=TRUE, cri="coef")
-fit = vglm(y ~ 1, ABO(link=probit), trace=TRUE, cri="coef")
-fit = vglm(y ~ 1, ABO(link=cloglog), trace=TRUE, cri="coef")
fit = vglm(y ~ 1, ABO(link=identity), trace=TRUE, cri="coef")
coef(fit, matrix=TRUE)
Coef(fit) # Estimated p and q
diff --git a/man/Coef.qrrvglm-class.Rd b/man/Coef.qrrvglm-class.Rd
index 8caec11..af12152 100644
--- a/man/Coef.qrrvglm-class.Rd
+++ b/man/Coef.qrrvglm-class.Rd
@@ -103,10 +103,10 @@ canonical Gaussian ordination.
}
\examples{
-x1 = rnorm(n <- 100)
-x2 = rnorm(n)
+x2 = rnorm(n <- 100)
x3 = rnorm(n)
-lv1 = 0 + x2 - 2*x3
+x4 = rnorm(n)
+lv1 = 0 + x3 - 2*x4
lambda1 = exp(3 - 0.5 * (lv1-0)^2)
lambda2 = exp(2 - 0.5 * (lv1-1)^2)
lambda3 = exp(2 - 0.5 * ((lv1+4)/2)^2)
@@ -114,7 +114,7 @@ y1 = rpois(n, lambda1)
y2 = rpois(n, lambda2)
y3 = rpois(n, lambda3)
yy = cbind(y1,y2,y3)
-p1 = cqo(yy ~ x1 + x2 + x3, fam=poissonff, trace=FALSE)
+p1 = cqo(yy ~ x2 + x3 + x4, fam=poissonff, trace=FALSE)
\dontrun{
lvplot(p1, y=TRUE, lcol=1:3, pch=1:3, pcol=1:3)
}
diff --git a/man/Coef.qrrvglm.Rd b/man/Coef.qrrvglm.Rd
index 5849177..1feb168 100644
--- a/man/Coef.qrrvglm.Rd
+++ b/man/Coef.qrrvglm.Rd
@@ -105,13 +105,11 @@ about how much information the parameters contain.
}
\examples{
-\dontrun{
set.seed(123)
-n = 100
-x1 = rnorm(n)
-x2 = rnorm(n)
+x2 = rnorm(n <- 100)
x3 = rnorm(n)
-lv1 = 0 + x2 - 2*x3
+x4 = rnorm(n)
+lv1 = 0 + x3 - 2*x4
lambda1 = exp(3 - 0.5 * (lv1-0)^2)
lambda2 = exp(2 - 0.5 * (lv1-1)^2)
lambda3 = exp(2 - 0.5 * ((lv1+4)/2)^2) # Unequal tolerances
@@ -119,12 +117,13 @@ y1 = rpois(n, lambda1)
y2 = rpois(n, lambda2)
y3 = rpois(n, lambda3)
set.seed(111)
-p1 = cqo(cbind(y1,y2,y3) ~ x1 + x2 + x3, poissonff, trace=FALSE)
+p1 = cqo(cbind(y1,y2,y3) ~ x2 + x3 + x4, poissonff, trace=FALSE)
+\dontrun{
lvplot(p1, y=TRUE, lcol=1:3, pch=1:3, pcol=1:3)
+}
Coef(p1)
print(Coef(p1), digits=3)
}
-}
\keyword{models}
\keyword{regression}
diff --git a/man/G1G2G3.Rd b/man/G1G2G3.Rd
index 4f52dcf..1245765 100644
--- a/man/G1G2G3.Rd
+++ b/man/G1G2G3.Rd
@@ -5,9 +5,10 @@
\description{
Estimates the three independent parameters of the
the G1G2G3 blood group system.
+
}
\usage{
-G1G2G3(link = "logit", ip1 = NULL, ip2 = NULL, iF = NULL)
+G1G2G3(link = "logit", earg=list(), ip1 = NULL, ip2 = NULL, iF = NULL)
}
%- maybe also 'usage' for other objects documented here.
\arguments{
@@ -16,6 +17,11 @@ G1G2G3(link = "logit", ip1 = NULL, ip2 = NULL, iF = NULL)
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{ip1, ip2, iF}{
Optional initial value for \code{p1}, \code{p2} and \code{f}.
@@ -65,7 +71,8 @@ argument is used to specify the total number of counts for each row.
\examples{
y = cbind(108, 196, 429, 143, 513, 559)
fit = vglm(y ~ 1, G1G2G3(link=probit), trace=TRUE, crit="coef")
-fit = vglm(y ~ 1, G1G2G3(link=logit, .3, .3, .02), trace=TRUE, crit="coef")
+fit = vglm(y ~ 1, G1G2G3(link=logit, ip1=.3, ip2=.3, iF=.02),
+ trace=TRUE, crit="coef")
fit = vglm(y ~ 1, G1G2G3(link="identity"), trace=TRUE)
Coef(fit) # Estimated p1, p2 and f
rbind(y, sum(y)*fitted(fit))
diff --git a/man/Inv.gaussian.Rd b/man/Inv.gaussian.Rd
index 8c97b52..b42988e 100644
--- a/man/Inv.gaussian.Rd
+++ b/man/Inv.gaussian.Rd
@@ -2,29 +2,30 @@
\alias{Inv.gaussian}
\alias{dinv.gaussian}
\alias{pinv.gaussian}
+\alias{rinv.gaussian}
\title{The Inverse Gaussian Distribution}
\description{
- Density and distribution function
- for the inverse Gaussian distribution with parameters
- \code{mu} and \code{lambda}.
+ Density, distribution function and random generation
+ for the inverse Gaussian distribution.
+
}
\usage{
dinv.gaussian(x, mu, lambda)
pinv.gaussian(q, mu, lambda)
+rinv.gaussian(n, mu, lambda)
}
\arguments{
\item{x, q}{vector of quantiles.}
%%\item{p}{vector of probabilities.}
-%%\item{n}{number of observations. If \code{length(n) > 1}, the length
-%% is taken to be the number required.}
+ \item{n}{number of observations. Must be a single positive integer. }
\item{mu}{the mean parameter.}
\item{lambda}{the \eqn{\lambda}{lambda} parameter.}
}
\value{
\code{dinv.gaussian} gives the density,
- \code{pinv.gaussian} gives the distribution function.
+ \code{pinv.gaussian} gives the distribution function, and
% \code{qinv.gaussian} gives the quantile function, and
-% \code{rinv.gaussian} generates random deviates.
+ \code{rinv.gaussian} generates random deviates.
}
\references{
Johnson, N. L. and Kotz, S. and Balakrishnan, N. (1994)
@@ -32,15 +33,25 @@ Johnson, N. L. and Kotz, S. and Balakrishnan, N. (1994)
2nd edition,
Volume 1,
New York: Wiley.
+
+ Taraldsen, G. and Lindqvist, B. H. (2005)
+ The multiple roots simulation algorithm,
+ the inverse Gaussian distribution, and the
+ sufficient conditional Monte Carlo method.
+ \emph{Preprint Statistics No. 4/2005},
+ Norwegian University of Science and Technology,
+ Trondheim, Norway.
+
}
\author{ T. W. Yee }
\details{
See \code{\link{inv.gaussianff}}, the \pkg{VGAM} family function
for estimating both parameters by maximum likelihood estimation,
for the formula of the probability density function.
+
}
\note{
- Currently \code{qinv.gaussian} and \code{rinv.gaussian} are unavailable.
+ Currently \code{qinv.gaussian} is unavailable.
}
\seealso{
\code{\link{inv.gaussianff}}.
diff --git a/man/Links.Rd b/man/Links.Rd
index b6c0590..f14a6b4 100644
--- a/man/Links.Rd
+++ b/man/Links.Rd
@@ -4,7 +4,7 @@
\title{Link functions for VGLM/VGAM/etc. families}
\description{
The \pkg{VGAM} package provides a number of (parameter) link functions
- which are described in general here. Collectively they offer the user
+ which are described in general here. Collectively, they offer the user
considerable flexibility for modelling data.
}
@@ -13,8 +13,11 @@ TypicalVGAMlinkFunction(theta, earg=list(), inverse=FALSE,
deriv=0, short=TRUE, tag=FALSE)
}
\arguments{
- All \pkg{VGAM} link functions have the same argument list as given
- above. In the following we have \eqn{\eta=g(\theta)}{eta=g(theta)}
+ Almost all \pkg{VGAM} link functions have something similar to
+ the argument list as given above.
+ That is, there is a matching \code{earg} for each \code{link}
+ argument.
+ In the following we have \eqn{\eta=g(\theta)}{eta=g(theta)}
where \eqn{g} is the link function, \eqn{\theta}{theta} is the parameter
and \eqn{\eta}{eta} is the linear/additive predictor.
@@ -34,6 +37,16 @@ TypicalVGAMlinkFunction(theta, earg=list(), inverse=FALSE,
always a list with \emph{named} components. See each specific link
function to find the component names for the list.
+ Almost all \pkg{VGAM} family functions with a single link
+ function have an argument (often called \code{earg}) which will
+ allow parameters to be inputted for that link function.
+ For \pkg{VGAM} family functions with more than one link
+ function there usually will be an \code{earg}-type argument for
+ each link. For example, if there are two links called
+ \code{lshape} and \code{lscale} then
+ the \code{earg}-type arguments for these might be called
+ \code{eshape} and \code{escale}, say.
+
}
\item{inverse}{
Logical. If \code{TRUE} the inverse link value
@@ -88,7 +101,7 @@ TypicalVGAMlinkFunction(theta, earg=list(), inverse=FALSE,
\code{\link{cloglog}},
\code{\link{cauchit}},
\code{\link{loglog}},
- \code{fsqrt},
+ \code{\link{fsqrt}},
\code{\link{logc}},
\code{\link{golf}},
\code{\link{polf}},
@@ -97,7 +110,7 @@ TypicalVGAMlinkFunction(theta, earg=list(), inverse=FALSE,
For positive parameters (i.e., greater than 0):
\code{\link{loge}},
\code{\link{nloge}},
- \code{powl}.
+ \code{\link{powl}}.
For parameters greater than 1:
\code{\link{loglog}}.
@@ -158,8 +171,8 @@ logit("a")
logit("a", short=FALSE)
logit("a", short=FALSE, tag=TRUE)
-logoff(2:5, earg=list(offset=1)) # Same as log(2:5 + 1)
-powl(2:5, earg=list(power=2)) # Same as (2:5)^2
+logoff(1:5, earg=list(offset=1)) # Same as log(1:5 + 1)
+powl(1:5, earg=list(power=2)) # Same as (1:5)^2
data(hunua)
fit1 = vgam(agaaus ~ altitude, binomialff(link=cloglog), hunua) # ok
@@ -169,6 +182,18 @@ fit2 = vgam(agaaus ~ altitude, binomialff(link="cloglog"), hunua) # ok
# This no longer works since "clog" is not a valid VGAM link function:
fit3 = vgam(agaaus ~ altitude, binomialff(link="clog"), hunua) # not ok
+
+# No matter what the link is 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)),
+ trace = TRUE, crit="c")
+vcov(fit1, untran=TRUE)
+vcov(fit1, untran=TRUE)-vcov(fit2, untran=TRUE) # Should be all 0s
+fit1 at misc$earg # No 'special' parameters
+fit2 at misc$earg # Some 'special' parameters are here
+
+
par(mfrow=c(2,2))
p = seq(0.01, 0.99, len=200)
x = seq(-4, 4, len=200)
diff --git a/man/MNSs.Rd b/man/MNSs.Rd
index 8d2d0e3..dc0760d 100644
--- a/man/MNSs.Rd
+++ b/man/MNSs.Rd
@@ -7,7 +7,7 @@
the MNSs blood group system.
}
\usage{
-MNSs(link = "logit", imS = NULL, ims = NULL, inS = NULL)
+MNSs(link = "logit", earg=list(), imS = NULL, ims = NULL, inS = NULL)
}
%- maybe also 'usage' for other objects documented here.
\arguments{
@@ -16,6 +16,11 @@ MNSs(link = "logit", imS = NULL, ims = NULL, inS = NULL)
See \code{\link{Links}} for more choices.
}
+ \item{earg}{
+ List. Extra argument applied to each of the links.
+ See \code{earg} in \code{\link{Links}} for general information.
+
+ }
\item{imS, ims, inS}{
Optional initial value for \code{mS}, \code{ms}
and \code{nS} respectively.
diff --git a/man/RayleighUC.Rd b/man/RayleighUC.Rd
index 0f7ba58..b151a48 100644
--- a/man/RayleighUC.Rd
+++ b/man/RayleighUC.Rd
@@ -40,9 +40,11 @@ New York: Wiley-Interscience, Third edition.
for estimating the parameter \eqn{a} by maximum likelihood estimation,
for the formula of the probability density function and range restrictions
on the parameter \eqn{a}.
+
}
\note{
The Rayleigh distribution is related to the Maxwell distribution.
+
}
\seealso{
\code{\link{rayleigh}},
diff --git a/man/VGAM-package.Rd b/man/VGAM-package.Rd
deleted file mode 100644
index 3787e12..0000000
--- a/man/VGAM-package.Rd
+++ /dev/null
@@ -1,444 +0,0 @@
-\name{VGAM-package}
-\alias{VGAM-package}
-\alias{VGAM}
-\docType{package}
-\title{
-Vector Generalized Linear and Additive Models
-}
-\description{
-Vector generalized linear and additive models, and associated models
-(Reduced-Rank VGLMs, Quadratic RR-VGLMs, Reduced-Rank VGAMs). This package
-fits many models and distribution by maximum likelihood estimation (MLE)
-or penalized MLE. Also fits constrained ordination models in ecology.
-
-}
-\details{
-\tabular{ll}{
-Package: \tab VGAM\cr
-Version: \tab 0.7-1\cr
-Date: \tab 2006-10-24\cr
-Depends: \tab R (>= 2.4.0), splines, methods, stats, stats4\cr
-License: \tab GPL version 2\cr
-URL: \tab http://www.stat.auckland.ac.nz/~yee/VGAM\cr
-LazyLoad: \tab yes\cr
-LazyData: \tab yes\cr
-Packaged: \tab Tue Oct 24 15:36:03 2006; yee\cr
-Built: \tab R 2.4.0; i686-pc-linux-gnu; 2006-10-24 15:44:11; unix\cr
-}
-
-Index:
-\preformatted{
-AA.Aa.aa The AA-Aa-aa Blood Group System
-AB.Ab.aB.ab The AB-Ab-aB-ab Blood Group System
-AB.Ab.aB.ab2 The AB-Ab-aB-ab2 Blood Group System
-ABO The ABO Blood Group System
-Benini The Benini Distribution
-Betabin The Beta-Binomial Distribution
-Betageom The Beta-Geometric Distribution
-Betanorm The Beta-Normal Distribution
-Bisa The Birnbaum-Saunders Distribution
-Brat Inputting Data to fit a Bradley Terry Model
-Coef Computes Model Coefficients and Quantities
-Coef.qrrvglm Returns Important Matrices etc. of a QO Object
-Coef.qrrvglm-class Class "Coef.qrrvglm"
-Coef.rrvglm Returns Important Matrices etc. of a RR-VGLM
- Object
-Coef.rrvglm-class Class "Coef.rrvglm"
-Coef.vlm Extract Model Coefficients for VLM Objects
-Dagum The Dagum Distribution
-Fisk The Fisk Distribution
-Frank Frank's Bivariate Distribution
-Frechet The Frechet Distribution
-G1G2G3 The G1G2G3 Blood Group System
-Hzeta Haight's Zeta Function
-Inv.gaussian The Inverse Gaussian Distribution
-Invlomax The Inverse Lomax Distribution
-Invparalogistic The Inverse Paralogistic Distribution
-Links Link functions for VGLM/VGAM/etc. families
-Lino The Generalized Beta Distribution (Libby and
- Novick, 1982)
-Log Logarithmic Distribution
-Lomax The Lomax Distribution
-MNSs The MNSs Blood Group System
-Max Maxima
-Maxwell The Maxwell Distribution
-Nakagami Nakagami Distribution
-Opt Maxima
-Paralogistic The Paralogistic Distribution
-Pareto The Pareto Distribution
-ParetoIV The Pareto(IV/III/II) Distributions
-Polono The Poisson Lognormal Distribution
-Posbinom Positive-Binomial Distribution
-Posnorm The Positive-Normal Distribution
-Pospois Positive-Poisson Distribution
-Rayleigh The Rayleigh Distribution
-Sinmad The Singh-Maddala Distribution
-Tikuv A Short-tailed Symmetric Distribution
-Tol Tolerances
-Tpareto The Truncated Pareto Distribution
-Zeta The Zeta Distribution
-Zibinom Zero-Inflated Binomial Distribution
-Zipf The Zipf Distribution
-Zipois Zero-Inflated Poisson Distribution
-acat Ordinal Regression with Adjacent Categories
- Probabilities
-auuc Auckland University Undergraduate Counts
-benini Benini Distribution Family Function
-betaII Beta Distribution of the Second Kind
-betabin.ab Beta-binomial Distribution Family Function
-betabinomial Beta-binomial Distribution Family Function
-betaff The Two-parameter Beta Distribution Family
- Function
-betageometric Beta-geometric Distribution Family Function
-betaprime The Beta-Prime Distribution
-bilogis4 Bivariate Logistic Distribution
-bilogistic4 Bivariate Logistic Distribution Family Function
-binom2.or Bivariate Logistic Regression
-binom2.rho Bivariate Probit Model
-binomialff Binomial Family Function
-bisa Birnbaum-Saunders Distribution Family Function
-bminz Body Mass Index of New Zealand Adults
-brat Bradley Terry Model
-bratt Bradley Terry Model With Ties
-calibrate Model Calibrations
-calibrate.qrrvglm Calibration for CQO, UQO and CAO models
-calibrate.qrrvglm.control
- Control function for CQO/UQO/CAO calibration
-cao Fitting Constrained Additive Ordination (CAO)
-cao.control Control Function for RR-VGAMs (CAO)
-cauchit Cauchit Link Function
-cauchy1 Cauchy Distribution Family Function
-ccoef Extract Model Constrained/Canonical
- Coefficients
-cdf.lmscreg Cumulative Distribution Function for LMS
- Quantile Regression
-cexpon Censored Exponential Distribution
-cgo Redirects the user to cqo
-cgumbel Censored Gumbel Distribution
-chest Chest Pain in NZ Adults
-chisq Chi-squared Distribution
-clo Redirects the user to rrvglm
-cloglog Complementary Log-log Link Function
-cnormal1 Censored Normal Distribution
-coalminers Breathlessness and Wheeze Amongst Coalminers
-constraints Constraint Matrices
-cqo Fitting Constrained Quadratic Ordination (CQO)
-cratio Ordinal Regression with Continuation Ratios
-cumulative Ordinal Regression with Cumulative
- Probabilities
-dagum Dagum Distribution Family Function
-dcnormal1 Univariate Normal Distribution with Double
- Censoring
-deplot.lmscreg Density Plot for LMS Quantile Regression
-dgumbel The Gumbel Distribution
-dirichlet Fitting a Dirichlet Distribution
-dirmul.old Fitting a Dirichlet-Multinomial Distribution
-dirmultinomial Fitting a Dirichlet-Multinomial Distribution
-dlaplace The Laplace Distribution
-enzyme Enzyme data
-erf Error Function
-erlang Erlang Distribution
-expexp Exponentiated Exponential Distribution
-expexp1 Exponentiated Exponential Distribution
-exponential Exponential Distribution
-fff F Distribution Family Function
-fill Creates a Matrix of Appropriate Dimension
-fisherz Fisher's Z Link Function
-fisk Fisk Distribution family function
-fitted.vlm Fitted Values of a VLM object
-frank Frank's Bivariate Distribution Family Function
-frechet2 Frechet Distribution Family Function
-freund61 Freund's (1961) Bivariate Extension of the
- Exponential Distribution
-gamma1 1-parameter Gamma Distribution
-gamma2 2-parameter Gamma Distribution
-gamma2.ab 2-parameter Gamma Distribution
-gammahyp Gamma Hyperbola Bivariate Distribution
-garma GARMA (Generalized Autoregressive
- Moving-Average) Models
-gaussianff Gaussian (normal) Family Function
-genbetaII Generalized Beta Distribution of the Second
- Kind
-genpoisson Generalized Poisson distribution
-geometric Geometric Distribution
-get.smart Retrieve One Component of ".smart.prediction"
-get.smart.prediction Retrieves ".smart.prediction"
-gev Generalized Extreme Value Distribution Family
- Function
-gevUC The Generalized Extreme Value Distribution
-gew General Electric and Westinghouse Data
-ggamma Generalized Gamma distribution family function
-ggammaUC The Generalized Gamma Distribution
-golf Gamma-Ordinal Link Function
-gpd Generalized Pareto Distribution Family Function
-gpdUC The Generalized Pareto Distribution
-grc Fitting Goodman's RC Association Model
-gumbel Gumbel Distribution Family Function
-guplot Gumbel Plot
-hspider Hunting Spider Data
-hunua Hunua Ranges data
-hyper Hypergeometric Family Function
-hzeta Haight's Zeta Family Function
-iam Index from Array to Matrix
-identity Identity Link Function
-inv.gaussianff Inverse Gaussian Distribution Family Function
-invlomax Inverse Lomax Distribution Family Function
-invparalogistic Inverse Paralogistic Distribution Family
- Function
-is.smart Test For a Smart Object
-leipnik Leipnik Distribution Family Function
-lerch Lerch Phi Function
-levy Levy Distribution Family Function
-lgammaUC The Log-Gamma Distribution
-lgammaff Log-gamma Distribution Family Function
-lino Generalized Beta Distribution Family Function
-lirat Low-iron Rat Teratology Data
-lms.bcg LMS Quantile Regression with a Box-Cox
- transformation to a Gamma Distribution
-lms.bcn LMS Quantile Regression with a Box-Cox
- Transformation to Normality
-lms.yjn LMS Quantile Regression with a Yeo-Johnson
- Transformation to Normality
-logc Complementary-log Link Function
-loge Log link function
-logff Logarithmic Distribution
-logistic Logistic Distribution Family Function
-logit Logit Link Function
-loglinb2 Loglinear Model for Two Binary Responses
-loglinb3 Loglinear Model for Three Binary Responses
-loglog Log-log Link Function
-lognormal Lognormal Distribution
-logoff Log link function with an offset
-lomax Lomax Distribution Family Function
-lv Latent Variables
-lvplot Latent Variable Plot
-lvplot.qrrvglm Latent Variable Plot for QO models
-lvplot.rrvglm Latent Variable Plot for RR-VGLMs
-maxwell Maxwell Distribution Family Function
-mccullagh89 McCullagh (1989) Distribution Family Function
-mckaygamma2 McKay's Bivariate Gamma Distribution
-meplot Mean Excess Plot
-micmen Michaelis-Menten Model
-mix2normal1 Mixture of Two Univariate Normal Distributions
-mix2poisson Mixture of Two Poisson Distributions
-model.framevlm Construct the Model Frame of a VLM Object
-model.matrixvlm Construct the Design Matrix of a VLM Object
-multinomial Multinomial Logit Model
-nakagami Nakagami Distribution Family Function
-nbolf Negative Binomial-Ordinal Link Function
-negbinomial Negative Binomial Distribution Family Function
-normal1 Univariate normal distribution
-notdocumentedyet Undocumented and Internally Used Functions and
- Classes
-nzc Chinese Population in New Zealand 1867-2001
-oxtemp Oxford Temperature Data
-paralogistic Paralogistic Distribution Family Function
-pareto1 Pareto and Truncated Pareto Distribution Family
- Functions
-paretoIV Pareto(IV/III/II) Distribution Family Functions
-persp.qrrvglm Perspective plot for QRR-VGLMs
-plotdeplot.lmscreg Density Plot for LMS Quantile Regression
-plotqrrvglm Model Diagnostic Plots for QRR-VGLMs
-plotqtplot.lmscreg Quantile Plot for LMS Quantile Regression
-plotvgam Default VGAM Plotting
-plotvgam.control Control Function for plotvgam()
-pneumo Pneumoconiosis amongst a group of coalminers
-poissonff Poisson Family Function
-polf Poisson-Ordinal Link Function
-posbinomial Positive Binomial Distribution Family Function
-posnegbinomial Positive Negative Binomial Distribution Family
- Function
-posnormal1 Positive Normal Distribution Family Function
-pospoisson Positive Poisson Distribution Family Function
-predict.vglm Predict Method for a VGLM fit
-prentice74 Prentice (1974) Log-gamma Distribution
-probit Probit Link Function
-put.smart Adds a List to the End of the List
- ".smart.prediction"
-qrrvglm.control Control function for QRR-VGLMs (CQO)
-qtplot.gumbel Quantile Plot for Gumbel Regression
-qtplot.lmscreg Quantile Plot for LMS Quantile Regression
-quasibinomialff Quasi-Binomial Family Function
-quasipoissonff Quasi-Poisson Family Function
-rayleigh Rayleigh Distribution Family Function
-rcqo Constrained Quadratic Ordination
-rdiric The Dirichlet distribution
-recexp1 Upper Record Values from a 1-parameter
- Exponential Distribution
-reciprocal Reciprocal link function
-recnormal1 Upper Record Values from a Univariate Normal
- Distribution
-rhobit Rhobit Link Function
-rig Reciprocal Inverse Gaussian distribution
-rlplot.egev Return Level Plot for GEV Fits
-rposnegbin Positive-negative binomial distribution random
- variates
-rrar Nested reduced-rank autoregressive models for
- multiple time series
-rrvglm Fitting Reduced-Rank Vector Generalized Linear
- Models (RR-VGLMs)
-rrvglm-class Class "rrvglm"
-rrvglm.control Control function for rrvglm
-rrvglm.optim.control Control function for rrvglm() calling optim()
-s Defining smooths in VGAM formulae
-setup.smart Smart Prediction Setup
-simplex Simplex distribution
-sinmad Singh-Maddala Distribution Family Function
-skewnormal1 Univariate Skew-Normal Distribution Family
- Function
-smart.expression S Expression for Smart Functions
-smart.mode.is Determine What Mode the Smart Prediction is In
-smartpred Smart Prediction
-snorm Skew-Normal Distribution
-sratio Ordinal Regression with Stopping Ratios
-studentt Student t Distribution
-tikuv Short-tailed Symmetric Distribution Family
- Function
-tobit Tobit Model
-trplot Trajectory Plot
-trplot.qrrvglm Trajectory plot for QRR-VGLMs
-uqo Fitting Unconstrained Quadratic Ordination
- (UQO)
-uqo.control Control Function for UQO models
-usagrain USA grain prices
-venice Venice Maximum Sea Levels
-vgam Fitting Vector Generalized Additive Models
-vgam-class Class "vgam"
-vgam.control Control function for vgam
-vglm Fitting Vector Generalized Linear Models
-vglm-class Class "vglm"
-vglm.control Control function for vglm
-vglmff-class Class "vglmff"
-vonmises von Mises Distribution Family Function
-vsmooth.spline Vector cubic smoothing spline
-waitakere Waitakere Ranges data
-wald Wald Distribution Family Function
-weibull Weibull Distribution Family Function
-weightsvglm Prior and Working Weights of a VGLM fit
-wrapup.smart Cleans Up After Smart Prediction
-yeo.johnson Yeo-Johnson Transformation
-yip88 Zero-Inflated Poisson Distribution (Yip (1988)
- algorithm)
-zanegbinomial Zero-Altered Negative Binomial Distribution
-zapoisson Zero-Altered Poisson Distribution
-zero The zero Argument in VGAM Family Functions
-zeta Riemann's Zeta Function
-zetaff Zeta Distribution Family Function
-zibinomial Zero-Inflated Binomial Distribution Family
- Function
-zipf Zipf Distribution Family Function
-zipoisson Zero-Inflated Poisson Distribution Family
- Function
-}
-
-%~~ An overview of how to use the package, including the most important ~~
-%~~ functions ~~
-
-
-}
-\author{
-Thomas W. Yee <t.yee at auckland.ac.nz>
-
-Maintainer: Thomas Yee <t.yee at auckland.ac.nz>
-}
-\references{
-
-Yee, T. W. and Hastie, T. J. (2003)
-Reduced-rank vector generalized linear models.
-\emph{Statistical Modelling},
-\bold{3}, 15--41.
-
-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.
-
-Yee, T. W. (2004)
-A new technique for maximum-likelihood
-canonical Gaussian ordination.
-\emph{Ecological Monographs},
-\bold{74}, 685--701.
-
-Yee, T. W. (2006)
-Constrained additive ordination.
-\emph{Ecology}, \bold{87}, 203--213.
-
-}
-
-\keyword{ package }
-\keyword{models}
-\keyword{regression}
-%\seealso{
-%~~ Optional links to other man pages, e.g. ~~
-%~~ \code{\link[<pkg>:<pkg>-package]{<pkg>}} ~~
-%}
-\examples{
-# Fit the proportional odds model, p.179, in McCullagh and Nelder (1989)
-data(pneumo)
-pneumo = transform(pneumo, let=log(exposure.time))
-(fit = vglm(cbind(normal, mild, severe) ~ let,
- cumulative(parallel=TRUE, reverse=TRUE), pneumo))
-fit at y # Sample proportions
-weights(fit, type="prior") # Number of observations
-coef(fit, matrix=TRUE)
-constraints(fit) # Constraint matrices
-
-
-# Fit a two species GAM simultaneously
-data(hunua)
-fit2 = vgam(cbind(agaaus, kniexc) ~ s(altitude),
- fam = binomialff(mv=TRUE), hunua)
-coef(fit2, mat=TRUE) # Not really interpretable
-\dontrun{
-plot(fit2, se=TRUE, overlay=TRUE, lcol=1:2, scol=1:2)
-attach(hunua)
-o = order(altitude)
-matplot(altitude[o], fitted(fit2)[o,], type="l", lwd=2, las=1,
- xlab="Altitude (m)", ylab="Probability of presence",
- main="Two plant species' response curves", ylim=c(0,.8))
-rug(altitude)
-detach(hunua)
-}
-
-
-
-# LMS quantile regression
-data(bminz)
-fit = vgam(BMI ~ s(age, df=c(4,2)), fam=lms.bcn(zero=1), data=bminz, tr=TRUE)
-predict(fit)[1:3,]
-fitted(fit)[1:3,]
-bminz[1:3,]
-# Person 1 is near the lower quartile of BMI amongst people his age
-cdf(fit)[1:3]
-
-\dontrun{
-# Quantile plot
-par(bty="l", mar=c(5,4,4,3)+0.1, xpd=TRUE)
-qtplot(fit, percentiles=c(5,50,90,99), main="Quantiles",
- xlim=c(15,90), las=1, ylab="BMI", lwd=2, lcol=4)
-
-# Density plot
-ygrid = seq(15, 43, len=100) # BMI ranges
-par(mfrow=c(1,1), lwd=2)
-a = deplot(fit, x0=20, y=ygrid, xlab="BMI", col="black",
- main="Density functions at Age = 20 (black), 42 (red) and 55 (blue)")
-a
-a = deplot(fit, x0=42, y=ygrid, add=TRUE, llty=2, col="red")
-a = deplot(fit, x0=55, y=ygrid, add=TRUE, llty=4, col="blue", Attach=TRUE)
-a at post$deplot # Contains density function values
-}
-
-
-# GEV distribution for extremes
-data(oxtemp)
-(fit = vglm(maxtemp ~ 1, egev, data=oxtemp, trace=TRUE))
-fitted(fit)[1:3,]
-coef(fit, mat=TRUE)
-Coef(fit)
-vcov(fit)
-vcov(fit, untransform=TRUE)
-sqrt(diag(vcov(fit))) # Approximate standard errors
-\dontrun{ rlplot(fit) }
-}
-
-
diff --git a/man/acat.Rd b/man/acat.Rd
index 81dc9ae..d0ac30c 100644
--- a/man/acat.Rd
+++ b/man/acat.Rd
@@ -7,7 +7,8 @@
(preferably) factor response.
}
\usage{
-acat(link = "loge", parallel = FALSE, reverse = FALSE, zero = NULL)
+acat(link = "loge", earg = list(),
+ parallel = FALSE, reverse = FALSE, zero = NULL)
}
%- maybe also 'usage' for other objects documented here.
\arguments{
@@ -22,7 +23,11 @@ acat(link = "loge", parallel = FALSE, reverse = FALSE, zero = NULL)
See \code{\link{Links}} for more choices.
}
+ \item{earg}{
+ List. Extra argument for the link function.
+ See \code{earg} in \code{\link{Links}} for general information.
+ }
\item{parallel}{
A logical, or formula specifying which terms have
equal/unequal coefficients.
diff --git a/man/benini.Rd b/man/benini.Rd
index eb9c251..a17b5cb 100644
--- a/man/benini.Rd
+++ b/man/benini.Rd
@@ -9,11 +9,13 @@
}
\usage{
benini(y0=stop("argument \"y0\" must be specified"),
- lshape="loge", ishape=NULL, method.init=1)
+ lshape="loge", earg=list(), ishape=NULL, method.init=1)
}
%- maybe also 'usage' for other objects documented here.
\arguments{
- \item{y0}{ Positive scale parameter.
+ \item{y0}{
+ Positive scale parameter.
+
}
\item{lshape}{
Parameter link function applied to the parameter \eqn{b},
@@ -22,6 +24,11 @@ benini(y0=stop("argument \"y0\" must be specified"),
A log link is the default because \eqn{b} is positive.
}
+ \item{earg}{
+ List. Extra argument for the link.
+ See \code{earg} in \code{\link{Links}} for general information.
+
+ }
\item{ishape}{
Optional initial value for the shape parameter.
The default is to compute the value internally.
diff --git a/man/betaII.Rd b/man/betaII.Rd
index b241c03..5831eda 100644
--- a/man/betaII.Rd
+++ b/man/betaII.Rd
@@ -8,6 +8,7 @@
}
\usage{
betaII(link.scale = "loge", link.p = "loge", link.q = "loge",
+ earg.scale=list(), earg.p=list(), earg.q=list(),
init.scale = NULL, init.p = 1, init.q = 1, zero = NULL)
}
%- maybe also 'usage' for other objects documented here.
@@ -18,6 +19,11 @@ betaII(link.scale = "loge", link.p = "loge", link.q = "loge",
See \code{\link{Links}} for more choices.
}
+ \item{earg.scale, earg.p, earg.q}{
+ List. Extra argument for each of the links.
+ See \code{earg} in \code{\link{Links}} for general information.
+
+ }
\item{init.scale, init.p, init.q}{
Optional initial values for \code{scale}, \code{p} and \code{q}.
diff --git a/man/betabin.ab.Rd b/man/betabin.ab.Rd
index 22f15af..f0941cd 100644
--- a/man/betabin.ab.Rd
+++ b/man/betabin.ab.Rd
@@ -9,7 +9,8 @@
}
\usage{
-betabin.ab(link.shape12 = "loge", i1 = 1, i2 = NULL, zero = NULL)
+betabin.ab(link.shape12 = "loge", earg = list(),
+ i1 = 1, i2 = NULL, zero = NULL)
}
%- maybe also 'usage' for other objects documented here.
\arguments{
@@ -19,6 +20,11 @@ betabin.ab(link.shape12 = "loge", i1 = 1, i2 = NULL, zero = NULL)
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{i1, i2}{
Initial value for the shape parameters.
The first must be positive, and is recyled to the necessary length.
diff --git a/man/betabinomial.Rd b/man/betabinomial.Rd
index ce1f93d..99fb56d 100644
--- a/man/betabinomial.Rd
+++ b/man/betabinomial.Rd
@@ -8,7 +8,8 @@
}
\usage{
-betabinomial(lmu="logit", lrho="logit", irho=0.5, zero=2)
+betabinomial(lmu="logit", lrho="logit", emu=list(), erho=list(),
+ irho=0.5, zero=2)
}
%- maybe also 'usage' for other objects documented here.
\arguments{
@@ -18,6 +19,11 @@ betabinomial(lmu="logit", lrho="logit", irho=0.5, zero=2)
The defaults ensure the parameters remain in \eqn{(0,1)}.
}
+ \item{emu, erho}{
+ List. Extra argument for each of the links.
+ See \code{earg} in \code{\link{Links}} for general information.
+
+ }
\item{irho}{
Optional initial value for the correlation parameter.
If given, it must be in \eqn{(0,1)}, and is recyled to the necessary
diff --git a/man/betaff.Rd b/man/betaff.Rd
index 6278870..9218447 100644
--- a/man/betaff.Rd
+++ b/man/betaff.Rd
@@ -8,8 +8,9 @@
}
\usage{
-betaff(link = "loge", i1 = NULL, i2 = NULL, trim = 0.05,
- A = 0, B = 1, earg=list(), zero = NULL)
+betaff(link = "loge", earg=list(),
+ i1 = NULL, i2 = NULL, trim = 0.05,
+ A = 0, B = 1, zero = NULL)
}
%- maybe also 'usage' for other objects documented here.
\arguments{
@@ -19,6 +20,11 @@ betaff(link = "loge", i1 = NULL, i2 = NULL, trim = 0.05,
A log link (default) ensures that the parameters are positive.
}
+ \item{earg}{
+ List. Extra argument for the link.
+ 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.
@@ -37,13 +43,6 @@ betaff(link = "loge", i1 = NULL, i2 = NULL, trim = 0.05,
where the response lies between 0 and 1.
}
- \item{earg}{
- List. Extra argument associated with \code{link}
- containing any extra information.
- See \code{\link{Links}} for general information about \pkg{VGAM} link
- functions.
-
- }
\item{zero}{
An integer-valued vector specifying which
linear/additive predictors are modelled as intercepts only.
@@ -124,7 +123,7 @@ betaff(link = "loge", i1 = NULL, i2 = NULL, trim = 0.05,
\code{beta4}.
}
\examples{
-y = rbeta(n=1000, shape1=1, shape2=3)
+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")
coef(fit, matrix=TRUE)
@@ -138,3 +137,9 @@ fitted(fit)[1:4,]
\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/betageometric.Rd b/man/betageometric.Rd
index cd84b18..bd40af9 100644
--- a/man/betageometric.Rd
+++ b/man/betageometric.Rd
@@ -8,6 +8,7 @@
}
\usage{
betageometric(lprob="logit", lshape="loge",
+ eprob=list(), eshape=list(),
iprob = NULL, ishape = 0.1,
moreSummation=c(2,100), tolerance=1.0e-10, zero=NULL)
}
@@ -21,6 +22,11 @@ betageometric(lprob="logit", lshape="loge",
See \code{\link{Links}} for more choices.
}
+ \item{eprob, eshape}{
+ List. Extra argument for each of the links.
+ See \code{earg} in \code{\link{Links}} for general information.
+
+ }
\item{iprob, ishape}{
Numeric.
Initial values for the two parameters.
diff --git a/man/betaprime.Rd b/man/betaprime.Rd
index 29b36ca..954fc52 100644
--- a/man/betaprime.Rd
+++ b/man/betaprime.Rd
@@ -8,7 +8,7 @@
}
\usage{
-betaprime(link = "loge", i1 = 2, i2 = NULL, zero = NULL)
+betaprime(link = "loge", earg=list(), i1 = 2, i2 = NULL, zero = NULL)
}
%- maybe also 'usage' for other objects documented here.
\arguments{
@@ -17,6 +17,11 @@ betaprime(link = "loge", i1 = 2, i2 = NULL, zero = NULL)
See \code{\link{Links}} for more choices.
}
+ \item{earg}{
+ List. Extra argument for each of the links.
+ See \code{earg} in \code{\link{Links}} for general information.
+
+ }
\item{i1, i2}{
Initial values for the first and second shape parameters.
A \code{NULL} value means it is obtained in the \code{initialize} slot.
diff --git a/man/binom2.or.Rd b/man/binom2.or.Rd
index d20c27c..b2e1e19 100644
--- a/man/binom2.or.Rd
+++ b/man/binom2.or.Rd
@@ -9,23 +9,21 @@
}
\usage{
-binom2.or(lp = "logit", lp1 = lp, lp2 = lp, lor = "loge",
+binom2.or(lmu = "logit", lmu1 = lmu, lmu2 = lmu, lor = "loge",
+ emu=list(), emu1=emu, emu2=emu, eor=list(),
zero = 3, exchangeable = FALSE, tol = 0.001)
}
%- maybe also 'usage' for other objects documented here.
\arguments{
- \item{lp}{
+ \item{lmu}{
Link function applied to the two marginal probabilities.
See \code{\link{Links}} for more choices.
See the note below.
}
- \item{lp1}{
- Link function applied to the first of the two marginal probabilities.
-
- }
- \item{lp2}{
- Link function applied to the second of the two marginal probabilities.
+ \item{lmu1, lmu2}{
+ Link function applied to the first and second of the two marginal
+ probabilities.
}
\item{lor}{
@@ -33,6 +31,11 @@ binom2.or(lp = "logit", lp1 = lp, lp2 = lp, lor = "loge",
See \code{\link{Links}} for more choices.
}
+ \item{emu, emu1, emu2, eor}{
+ List. Extra argument for each of the links.
+ See \code{earg} in \code{\link{Links}} for general information.
+
+ }
\item{zero}{
Which linear/additive predictor is modelled as an intercept only? A
\code{NULL} means none.
@@ -127,12 +130,12 @@ binom2.or(lp = "logit", lp1 = lp, lp2 = lp, lor = "loge",
function of the explanatory variables; however, numerical problems
are more likely to occur.
- The argument \code{lp}, which is actually redundant, is used for
- convenience and for upward compatibility: specifying \code{lp} only
- means the link function will be applied to \code{lp1} and \code{lp2}.
+ The argument \code{lmu}, which is actually redundant, is used for
+ convenience and for upward compatibility: specifying \code{lmu} only
+ means the link function will be applied to \code{lmu1} and \code{lmu2}.
Users who want a different link function for each of the two marginal
- probabilities should use the \code{lp1} and \code{lp2} arguments,
- and the argument \code{lp} is then ignored. It doesn't make sense
+ probabilities should use the \code{lmu1} and \code{lmu2} arguments,
+ and the argument \code{lmu} is then ignored. It doesn't make sense
to specify \code{exchangeable=TRUE} and have different link functions
for the two marginal probabilities.
diff --git a/man/binom2.rho.Rd b/man/binom2.rho.Rd
index 0bbfe82..87232fc 100644
--- a/man/binom2.rho.Rd
+++ b/man/binom2.rho.Rd
@@ -6,7 +6,8 @@
Fits a bivariate probit model to two binary responses.
}
\usage{
-binom2.rho(lrho = "rhobit", init.rho = 0.4, zero = 3, exchangeable = FALSE)
+binom2.rho(lrho = "rhobit", erho=list(),
+ init.rho = 0.4, zero = 3, exchangeable = FALSE)
}
%- maybe also 'usage' for other objects documented here.
\arguments{
@@ -15,6 +16,11 @@ binom2.rho(lrho = "rhobit", init.rho = 0.4, zero = 3, exchangeable = FALSE)
See \code{\link{Links}} for more choices.
}
+ \item{erho}{
+ List. Extra argument for the \code{lrho} link.
+ See \code{earg} in \code{\link{Links}} for general information.
+
+ }
\item{init.rho}{
Initial value for \eqn{\rho}{rho}.
This should lie between \eqn{-1} and \eqn{1}.
diff --git a/man/binomialff.Rd b/man/binomialff.Rd
index 785c670..a280344 100644
--- a/man/binomialff.Rd
+++ b/man/binomialff.Rd
@@ -9,8 +9,9 @@
}
\usage{
-binomialff(link = "logit", dispersion = 1, mv = FALSE, onedpar = !mv,
- parallel = FALSE, earg = NULL, zero = NULL)
+binomialff(link = "logit", earg = list(),
+ dispersion = 1, mv = FALSE, onedpar = !mv,
+ parallel = FALSE, zero = NULL)
}
%- maybe also 'usage' for other objects documented here.
@@ -22,6 +23,11 @@ binomialff(link = "logit", dispersion = 1, mv = FALSE, onedpar = !mv,
Link function. 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{dispersion}{
Dispersion parameter. By default, maximum likelihood is used to
estimate the model because it is known. However, the user can specify
@@ -54,11 +60,6 @@ binomialff(link = "logit", dispersion = 1, mv = FALSE, onedpar = !mv,
linear/additive predictors.
}
- \item{earg}{
- Extra argument optionally used by the link function.
- See \code{\link{Links}} for more information.
-
- }
\item{zero}{
An integer-valued vector specifying which linear/additive predictors
are modelled as intercepts only. The values must be from the set
diff --git a/man/bisa.Rd b/man/bisa.Rd
index 2300428..5f7e0ae 100644
--- a/man/bisa.Rd
+++ b/man/bisa.Rd
@@ -9,6 +9,7 @@
}
\usage{
bisa(lshape = "loge", lscale = "loge",
+ eshape = list(), escale = list(),
ishape = NULL, iscale = 1, method.init = 1,
fsmax=9001, zero = NULL)
}
@@ -21,6 +22,11 @@ bisa(lshape = "loge", lscale = "loge",
A log link is the default for both because they are positive.
}
+ \item{escale, eshape}{
+ List. Extra argument for each of the links.
+ See \code{earg} in \code{\link{Links}} for general information.
+
+ }
\item{iscale, ishape}{
Initial values for \eqn{a} and \eqn{b}.
A \code{NULL} means an initial value is chosen internally using
@@ -125,14 +131,14 @@ New York: Wiley.
}
\examples{
y = rbisa(n=1000, shape=exp(-0.5), scale=exp(0.5))
-fit1 = vglm(y ~ 1, bisa, trace=TRUE)
-coef(fit1, matrix=TRUE)
+fit = vglm(y ~ 1, bisa, trace=TRUE)
+coef(fit, matrix=TRUE)
mean(y)
-fitted(fit1)[1:4]
+fitted(fit)[1:4]
\dontrun{hist(y, prob=TRUE)
x = seq(0, max(y), len=200)
-lines(x, dbisa(x, Coef(fit1)[1], Coef(fit1)[2]), col="red")
+lines(x, dbisa(x, Coef(fit)[1], Coef(fit)[2]), col="red")
}
}
\keyword{models}
diff --git a/man/cauchy1.Rd b/man/cauchy1.Rd
index 230b5a0..b9cf024 100644
--- a/man/cauchy1.Rd
+++ b/man/cauchy1.Rd
@@ -9,7 +9,7 @@
}
\usage{
cauchy1(scale.arg=1, llocation="identity",
- ilocation=NULL, method.init=1)
+ elocation=list(), ilocation=NULL, method.init=1)
}
%- maybe also 'usage' for other objects documented here.
\arguments{
@@ -22,6 +22,11 @@ cauchy1(scale.arg=1, llocation="identity",
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.
diff --git a/man/chisq.Rd b/man/chisq.Rd
index 003c1a2..8cb776c 100644
--- a/man/chisq.Rd
+++ b/man/chisq.Rd
@@ -7,7 +7,7 @@
a chi-squared distribution.
}
\usage{
-chisq(link = "loge")
+chisq(link = "loge", earg=list())
}
%- maybe also 'usage' for other objects documented here.
\arguments{
@@ -16,6 +16,11 @@ chisq(link = "loge")
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.
+
+ }
}
\details{
The degrees of freedom is treated as a parameter to be estimated.
@@ -37,8 +42,9 @@ New York: Wiley-Interscience, Third edition.
\author{ T. W. Yee }
\note{
-There may be convergence problems if the degrees of freedom
-is very large.
+ There may be convergence problems if the degrees of freedom
+ is very large.
+
}
\seealso{
diff --git a/man/cratio.Rd b/man/cratio.Rd
index 8fc3a7a..d51f533 100644
--- a/man/cratio.Rd
+++ b/man/cratio.Rd
@@ -7,7 +7,8 @@
regression model to an ordered (preferably) factor response.
}
\usage{
-cratio(link = "logit", parallel = FALSE, reverse = FALSE, zero = NULL)
+cratio(link = "logit", earg = list(),
+ parallel = FALSE, reverse = FALSE, zero = NULL)
}
%- maybe also 'usage' for other objects documented here.
\arguments{
@@ -21,6 +22,11 @@ cratio(link = "logit", parallel = FALSE, reverse = FALSE, zero = NULL)
See \code{\link{Links}} for more choices.
}
+ \item{earg}{
+ List. Extra argument for the link function.
+ See \code{earg} in \code{\link{Links}} for general information.
+
+ }
\item{parallel}{
A logical, or formula specifying which terms have
equal/unequal coefficients.
diff --git a/man/cumulative.Rd b/man/cumulative.Rd
index 2d75b27..4e11c9c 100644
--- a/man/cumulative.Rd
+++ b/man/cumulative.Rd
@@ -8,8 +8,9 @@
}
\usage{
-cumulative(link = "logit", parallel = FALSE, reverse = FALSE,
- earg = list(), mv = FALSE, intercept.apply = FALSE)
+cumulative(link = "logit", earg = list(),
+ parallel = FALSE, reverse = FALSE,
+ mv = FALSE, intercept.apply = FALSE)
}
%- maybe also 'usage' for other objects documented here.
\arguments{
@@ -23,6 +24,11 @@ cumulative(link = "logit", parallel = FALSE, reverse = FALSE,
See \code{\link{Links}} for more choices.
}
+ \item{earg}{
+ List. Extra argument for the link function.
+ See \code{earg} in \code{\link{Links}} for general information.
+
+ }
\item{parallel}{
A logical, or formula specifying which terms have
equal/unequal coefficients.
@@ -45,11 +51,6 @@ cumulative(link = "logit", parallel = FALSE, reverse = FALSE,
if \code{reverse=FALSE} for then the cutpoints must be an decreasing sequence.
}
- \item{earg}{
- List. Extra argument for the link function.
- See \code{earg} in \code{\link{Links}} for general information.
-
- }
\item{mv}{
Logical.
Multivariate response? If \code{TRUE} then the input should be
diff --git a/man/dagum.Rd b/man/dagum.Rd
index 6113cd1..c20330c 100644
--- a/man/dagum.Rd
+++ b/man/dagum.Rd
@@ -8,6 +8,7 @@
}
\usage{
dagum(link.a = "loge", link.scale = "loge", link.p = "loge",
+ earg.a=list(), earg.scale=list(), earg.p=list(),
init.a = NULL, init.scale = NULL, init.p = 1, zero = NULL)
}
%- maybe also 'usage' for other objects documented here.
@@ -18,6 +19,11 @@ dagum(link.a = "loge", link.scale = "loge", link.p = "loge",
See \code{\link{Links}} for more choices.
}
+ \item{earg.a, earg.scale, earg.p}{
+ List. Extra argument for each of the links.
+ See \code{earg} in \code{\link{Links}} for general information.
+
+ }
\item{init.a, init.scale, init.p}{
Optional initial values for \code{a}, \code{scale}, and \code{p}.
diff --git a/man/dcnormal1.Rd b/man/dcnormal1.Rd
index 83ac6bd..a1ac9b7 100644
--- a/man/dcnormal1.Rd
+++ b/man/dcnormal1.Rd
@@ -8,7 +8,8 @@
}
\usage{
-dcnormal1(r1 = 0, r2 = 0, link.sd = "loge", isd = NULL, zero = NULL)
+dcnormal1(r1 = 0, r2 = 0, link.sd = "loge",
+ earg=list(), isd = NULL, zero = NULL)
}
%- maybe also 'usage' for other objects documented here.
\arguments{
@@ -22,6 +23,11 @@ dcnormal1(r1 = 0, r2 = 0, link.sd = "loge", isd = NULL, zero = NULL)
Being a positive quantity, a log link is the default.
}
+ \item{earg}{
+ List. Extra argument for the link.
+ See \code{earg} in \code{\link{Links}} for general information.
+
+ }
\item{isd}{
Numeric. Initial value for the standard deviation.
The default value \code{NULL} means an initial value is
diff --git a/man/dirichlet.Rd b/man/dirichlet.Rd
index e3d7cc0..58b449a 100644
--- a/man/dirichlet.Rd
+++ b/man/dirichlet.Rd
@@ -7,7 +7,7 @@
}
\usage{
-dirichlet(link = "loge", zero=NULL)
+dirichlet(link = "loge", earg=list(), zero=NULL)
}
%- maybe also 'usage' for other objects documented here.
\arguments{
@@ -23,6 +23,11 @@ dirichlet(link = "loge", zero=NULL)
The default gives \eqn{\eta_j=\log(\alpha_j)}{eta_j=log(alpha_j)}.
}
+ \item{earg}{
+ List. Extra argument for the link.
+ See \code{earg} in \code{\link{Links}} for general information.
+
+ }
\item{zero}{
An integer-valued vector specifying which
linear/additive predictors are modelled as intercepts only.
diff --git a/man/dirmul.old.Rd b/man/dirmul.old.Rd
index 3859480..e97e30b 100644
--- a/man/dirmul.old.Rd
+++ b/man/dirmul.old.Rd
@@ -7,7 +7,8 @@
non-negative integers.
}
\usage{
-dirmul.old(link = "loge", init.alpha = 0.01, parallel = FALSE, zero = NULL)
+dirmul.old(link = "loge", earg = list(),
+ init.alpha = 0.01, parallel = FALSE, zero = NULL)
}
%- maybe also 'usage' for other objects documented here.
\arguments{
@@ -18,6 +19,11 @@ dirmul.old(link = "loge", init.alpha = 0.01, parallel = FALSE, zero = NULL)
Here, \eqn{M} is the number of columns of the response matrix.
}
+ \item{earg}{
+ List. Extra argument for \code{link}.
+ See \code{earg} in \code{\link{Links}} for general information.
+
+ }
\item{init.alpha}{
Numeric vector. Initial values for the
\code{alpha} vector. Must be positive.
diff --git a/man/dirmultinomial.Rd b/man/dirmultinomial.Rd
index 6ff1949..62ca52a 100644
--- a/man/dirmultinomial.Rd
+++ b/man/dirmultinomial.Rd
@@ -7,7 +7,8 @@
}
\usage{
-dirmultinomial(lphi="logit", iphi = 0.10, parallel= FALSE, zero="M")
+dirmultinomial(lphi="logit", ephi = list(), iphi = 0.10,
+ parallel= FALSE, zero="M")
}
%- maybe also 'usage' for other objects documented here.
\arguments{
@@ -17,6 +18,11 @@ dirmultinomial(lphi="logit", iphi = 0.10, parallel= FALSE, zero="M")
See \code{\link{Links}} for more choices.
}
+ \item{ephi}{
+ List. Extra argument for \code{lphi}.
+ See \code{earg} in \code{\link{Links}} for general information.
+
+ }
\item{iphi}{
Numeric. Initial value for \eqn{\phi}{phi}.
Must be in the open unit interval \eqn{(0,1)}.
diff --git a/man/erlang.Rd b/man/erlang.Rd
index f87e050..f8449de 100644
--- a/man/erlang.Rd
+++ b/man/erlang.Rd
@@ -7,7 +7,7 @@
by maximum likelihood estimation.
}
\usage{
-erlang(shape.arg, link = "loge", method.init = 1)
+erlang(shape.arg, link = "loge", earg=list(), method.init = 1)
}
%- maybe also 'usage' for other objects documented here.
\arguments{
@@ -21,6 +21,11 @@ erlang(shape.arg, link = "loge", method.init = 1)
See \code{\link{Links}} for more choices.
}
+ \item{earg}{
+ List. Extra argument for the link.
+ See \code{earg} in \code{\link{Links}} for general information.
+
+ }
\item{method.init}{
An integer with value \code{1} or \code{2} which
specifies the initialization method. If failure to converge occurs
diff --git a/man/expexp.Rd b/man/expexp.Rd
index 9d2ec76..09cb265 100644
--- a/man/expexp.Rd
+++ b/man/expexp.Rd
@@ -9,6 +9,7 @@
}
\usage{
expexp(lshape = "loge", lscale = "loge",
+ eshape=list(), escale=list(),
ishape = 1.1, iscale = NULL,
tolerance = 1.0e-6, zero = NULL)
}
@@ -21,6 +22,11 @@ expexp(lshape = "loge", lscale = "loge",
The defaults ensure both parameters are positive.
}
+ \item{eshape, escale}{
+ List. Extra argument for each of the links.
+ See \code{earg} in \code{\link{Links}} for general information.
+
+ }
\item{ishape}{
Initial value for the \eqn{\alpha}{shape}
parameter. If convergence fails try setting a different
diff --git a/man/expexp1.Rd b/man/expexp1.Rd
index e391b08..eff089c 100644
--- a/man/expexp1.Rd
+++ b/man/expexp1.Rd
@@ -5,9 +5,10 @@
\description{
Estimates the two parameters of the exponentiated exponential
distribution by maximizing a profile (concentrated) likelihood.
+
}
\usage{
-expexp1(lscale = "loge", iscale = NULL, ishape = 1)
+expexp1(lscale = "loge", escale=list(), iscale = NULL, ishape = 1)
}
%- maybe also 'usage' for other objects documented here.
\arguments{
@@ -16,6 +17,11 @@ expexp1(lscale = "loge", iscale = NULL, ishape = 1)
See \code{\link{Links}} for more choices.
}
+ \item{escale}{
+ List. Extra argument for the link.
+ See \code{earg} in \code{\link{Links}} for general information.
+
+ }
\item{iscale}{
Initial value for the \eqn{\lambda}{scale} parameter.
By default, an initial value is chosen internally using \code{ishape}.
@@ -28,17 +34,15 @@ expexp1(lscale = "loge", iscale = NULL, ishape = 1)
}
}
\details{
- See \code{\link{expexp}} for details about the
- exponentiated exponential distribution. This
- family function uses a different algorithm for fitting
- the model. Given \eqn{\lambda}{scale}, the MLE of
- \eqn{\alpha}{shape} can easily be solved in terms of
- \eqn{\lambda}{scale}. This family function maximizes
- a profile (concentrated) likelihood with respect to \eqn{\lambda}{scale}.
- Newton-Raphson is used, which compares with Fisher scoring
- with \code{\link{expexp}}.
+ See \code{\link{expexp}} for details about the exponentiated
+ exponential distribution. This family function uses a different
+ algorithm for fitting the model. Given \eqn{\lambda}{scale},
+ the MLE of \eqn{\alpha}{shape} can easily be solved in terms of
+ \eqn{\lambda}{scale}. This family function maximizes a profile
+ (concentrated) likelihood with respect to \eqn{\lambda}{scale}.
+ Newton-Raphson is used, which compares with Fisher scoring with
+ \code{\link{expexp}}.
-
}
\value{
An object of class \code{"vglmff"} (see \code{\link{vglmff-class}}).
diff --git a/man/exponential.Rd b/man/exponential.Rd
index c681adb..6186851 100644
--- a/man/exponential.Rd
+++ b/man/exponential.Rd
@@ -7,7 +7,7 @@
}
\usage{
-exponential(link = "loge", location = 0, expected = TRUE, earg = NULL)
+exponential(link = "loge", earg = list(), location = 0, expected = TRUE)
}
%- maybe also 'usage' for other objects documented here.
\arguments{
@@ -16,6 +16,11 @@ exponential(link = "loge", location = 0, expected = TRUE, earg = NULL)
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{location}{
Numeric of length 1, the known location parameter, \eqn{A}, say.
@@ -25,11 +30,6 @@ exponential(link = "loge", location = 0, expected = TRUE, earg = NULL)
otherwise Newton-Raphson. The latter is usually faster.
}
- \item{earg}{
- Extra argument for the \pkg{VGAM} link function.
- See \code{\link{Links}} for more details.
-
- }
}
\details{
diff --git a/man/fff.Rd b/man/fff.Rd
index ff615bf..bfb857e 100644
--- a/man/fff.Rd
+++ b/man/fff.Rd
@@ -6,7 +6,8 @@
Maximum likelihood estimation of the (2-parameter) F distribution.
}
\usage{
-fff(link="loge", idf1=NULL, idf2=NULL, method.init=1, zero=NULL)
+fff(link="loge", earg=list(), idf1=NULL, idf2=NULL,
+ method.init=1, zero=NULL)
}
%- maybe also 'usage' for other objects documented here.
\arguments{
@@ -16,7 +17,12 @@ fff(link="loge", idf1=NULL, idf2=NULL, method.init=1, zero=NULL)
The default keeps the parameters positive.
}
- \item{idf1,idf2}{
+ \item{earg}{
+ List. Extra argument for the link.
+ See \code{earg} in \code{\link{Links}} for general information.
+
+ }
+ \item{idf1, idf2}{
Numeric and positive.
Initial value for the parameters.
The default is to choose each value internally.
@@ -84,6 +90,7 @@ df1 = exp(2+0.5*x)
df2 = exp(2-0.5*x)
y = rf(n, df1, df2)
fit = vglm(y ~ x, fff, trace=TRUE)
+fit = vglm(y ~ x, fff(link="logoff", earg=list(offset=0.5)), trace=TRUE)
coef(fit, matrix=TRUE)
Coef(fit)
vcov(fit) # caution needed!
@@ -91,3 +98,16 @@ vcov(fit) # caution needed!
\keyword{models}
\keyword{regression}
+
+
+%# Another simpler example
+%set.seed(123)
+%df1 = exp(2)
+%df2 = exp(2)
+%y = rf(n <- 1000, df1, df2)
+%fit1 = vglm(y ~ 1, fff, trace=TRUE)
+%fit2 = vglm(y ~ 1, fff(link="logoff", earg=list(offset=0.5)), trace=TRUE)
+%vcov(fit1) # caution needed!
+%vcov(fit2) # caution needed!
+
+
diff --git a/man/fgm.Rd b/man/fgm.Rd
new file mode 100644
index 0000000..540ae60
--- /dev/null
+++ b/man/fgm.Rd
@@ -0,0 +1,100 @@
+\name{fgm}
+\alias{fgm}
+%- Also NEED an '\alias' for EACH other topic documented here.
+\title{ Farlie-Gumbel-Morgenstern's Bivariate Distribution Family Function }
+\description{
+ Estimate the association parameter of
+ Farlie-Gumbel-Morgenstern's bivariate
+ distribution using maximum likelihood estimation.
+
+}
+\usage{
+fgm(lapar="identity", earg=list(), iapar=NULL, method.init=1)
+}
+%- maybe also 'usage' for other objects documented here.
+\arguments{
+ \item{lapar}{
+ Link function applied to the association parameter
+ \eqn{\alpha}{alpha}, which is real.
+ 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{iapar}{
+ 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.
+ Assigning a value will override the argument \code{method.init}.
+
+ }
+ \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}.
+
+ }
+}
+\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).
+ 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
+ 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.
+
+}
+\value{
+ An object of class \code{"vglmff"} (see \code{\link{vglmff-class}}).
+ The object is used by modelling functions such as \code{\link{vglm}}
+ and \code{\link{vgam}}.
+}
+
+\references{
+
+Castillo, E., Hadi, A. S., Balakrishnan, N. Sarabia, J. S. (2005)
+\emph{Extreme Value and Related Models with Applications in Engineering and Science},
+Hoboken, N.J.: Wiley-Interscience.
+
+}
+\author{ T. W. Yee }
+\note{
+ 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}}.
+}
+\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)
+Coef(fit)
+fitted(fit)[1:5,]
+}
+\keyword{models}
+\keyword{regression}
+
diff --git a/man/fisk.Rd b/man/fisk.Rd
index 03e5aa4..4b941d0 100644
--- a/man/fisk.Rd
+++ b/man/fisk.Rd
@@ -8,6 +8,7 @@
}
\usage{
fisk(link.a = "loge", link.scale = "loge",
+ earg.a=list(), earg.scale=list(),
init.a = NULL, init.scale = NULL, zero = NULL)
}
%- maybe also 'usage' for other objects documented here.
@@ -18,6 +19,11 @@ fisk(link.a = "loge", link.scale = "loge",
See \code{\link{Links}} for more choices.
}
+ \item{earg.a, earg.scale}{
+ List. Extra argument for each of the links.
+ See \code{earg} in \code{\link{Links}} for general information.
+
+ }
\item{init.a, init.scale}{
Optional initial values for \code{a} and \code{scale}.
diff --git a/man/frank.Rd b/man/frank.Rd
index 5014ad6..31192a3 100644
--- a/man/frank.Rd
+++ b/man/frank.Rd
@@ -3,22 +3,27 @@
%- Also NEED an '\alias' for EACH other topic documented here.
\title{ Frank's Bivariate Distribution Family Function }
\description{
- Estimate the correlation parameter of Frank's bivariate distribution
+ Estimate the association parameter of Frank's bivariate distribution
using maximum likelihood estimation.
}
\usage{
-frank(lcorp="loge", icorp=2)
+frank(lapar="loge", eapar=list(), iapar=2)
}
%- maybe also 'usage' for other objects documented here.
\arguments{
- \item{lcorp}{
- Link function applied to the (positive) correlation parameter
+ \item{lapar}{
+ Link function applied to the (positive) association parameter
\eqn{\alpha}{alpha}.
See \code{\link{Links}} for more choices.
}
- \item{icorp}{
+ \item{eapar}{
+ List. Extra argument for the link.
+ See \code{earg} in \code{\link{Links}} for general information.
+
+ }
+ \item{iapar}{
Numeric. Initial value for \eqn{\alpha}{alpha}.
If a convergence failure occurs try assigning a different value.
@@ -79,7 +84,8 @@ Frank's family of bivariate distributions.
}
\seealso{
- \code{\link{rfrank}}.
+ \code{\link{rfrank}},
+ \code{\link{fgm}}.
}
\examples{
ymat = rfrank(n=2000, alpha=exp(4))
diff --git a/man/frankUC.Rd b/man/frankUC.Rd
index c65511a..dac9dcc 100644
--- a/man/frankUC.Rd
+++ b/man/frankUC.Rd
@@ -7,6 +7,7 @@
\description{
Density, distribution function, quantile function and random
generation for the one parameter Frank distribution.
+
}
\usage{
dfrank(x1, x2, alpha)
@@ -17,7 +18,7 @@ rfrank(n, alpha)
\item{x1, x2, q1, q2}{vector of quantiles.}
\item{n}{number of observations.
Must be a positive integer of length 1.}
- \item{alpha}{the positive correlation parameter \eqn{\alpha}{alpha}.}
+ \item{alpha}{the positive association parameter \eqn{\alpha}{alpha}.}
}
\value{
\code{dfrank} gives the density,
@@ -35,7 +36,7 @@ Frank's family of bivariate distributions.
\author{ T. W. Yee }
\details{
See \code{\link{frank}}, the \pkg{VGAM}
- family functions for estimating the correlation
+ family functions for estimating the association
parameter by maximum likelihood estimation, for the formula of the
cumulative distribution function and other details.
diff --git a/man/fsqrt.Rd b/man/fsqrt.Rd
new file mode 100644
index 0000000..a070ba7
--- /dev/null
+++ b/man/fsqrt.Rd
@@ -0,0 +1,167 @@
+\name{fsqrt}
+\alias{fsqrt}
+%- Also NEED an '\alias' for EACH other topic documented here.
+\title{ Folded Square Root Link Function }
+\description{
+ Computes the folded square root transformation, including its inverse
+ and the first two derivatives.
+
+}
+\usage{
+fsqrt(theta, earg = list(min=0, max=1, mux=sqrt(2)),
+ inverse = FALSE, deriv = 0, short = TRUE, tag = FALSE)
+}
+%- maybe also 'usage' for other objects documented here.
+\arguments{
+ \item{theta}{
+ Numeric or character.
+ See below for further details.
+
+ }
+ \item{earg}{
+ List with components \code{min}, \code{max} and \code{mux}.
+ These are called \eqn{L}, \eqn{U} and \eqn{K} below.
+
+ }
+ \item{inverse}{
+ Logical. If \code{TRUE} the inverse function is computed.
+
+ }
+ \item{deriv}{
+ Order of the derivative. Integer with value 0, 1 or 2.
+
+ }
+ \item{short}{
+ Used for labelling the \code{blurb} slot of a
+ \code{\link{vglmff-class}} object.
+
+ }
+ \item{tag}{
+ Used for labelling the linear/additive predictor in the
+ \code{initialize} slot of a \code{\link{vglmff-class}} object.
+ Contains a little more information if \code{TRUE}.
+
+ }
+}
+\details{
+ The folded square root link function can be applied to
+ parameters that lie between \eqn{L} and \eqn{U} inclusive.
+ Numerical values of \code{theta}
+ out of range result in \code{NA} or \code{NaN}.
+
+ The arguments \code{short} and \code{tag} are used only if
+ \code{theta} is character.
+
+}
+\value{
+ For \code{fsqrt} with \code{deriv = 0}:
+ \eqn{K (\sqrt{\theta-L} - \sqrt{U-\theta})}{K *
+ (sqrt(theta-L) - sqrt(U-theta))}
+ or
+ \code{mux * (sqrt(theta-min) - sqrt(max-theta))}
+ when \code{inverse = FALSE},
+ and if \code{inverse = TRUE} then some more
+ complicated function that returns a \code{NA} unless
+ \code{theta} is between \code{-mux*sqrt(max-min)} and
+ \code{mux*sqrt(max-min)}.
+
+ For \code{deriv = 1}, then the function returns
+ \emph{d} \code{theta} / \emph{d} \code{eta} as a function of \code{theta}
+ if \code{inverse = FALSE},
+ else if \code{inverse = TRUE} then it returns the reciprocal.
+
+}
+%\references{
+%
+%}
+\author{ Thomas W. Yee }
+
+\note{
+ The default has, if \code{theta} is 0 or 1, the link function
+ value is \code{-sqrt(2)} and \code{+sqrt(2)} respectively.
+ These are finite values, therefore one cannot use this link function for
+ general modelling of probabilities because of numerical problem,
+ e.g., with \code{\link{binomialff}}, \code{\link{cumulative}}. See
+ the example below.
+
+}
+
+\seealso{
+ \code{\link{Links}}.
+}
+\examples{
+p = seq(0.01, 0.99, by=0.01)
+fsqrt(p)
+max(abs(fsqrt(fsqrt(p), inverse=TRUE) - p)) # Should be 0
+
+p = c(seq(-0.02, 0.02, by=0.01), seq(0.97, 1.02, by=0.01))
+fsqrt(p) # Has NAs
+
+\dontrun{
+p = seq(0.01, 0.99, by=0.01)
+par(mfrow=c(2,2))
+y = seq(-4, 4, length=100)
+for(d in 0:1) {
+ matplot(p, cbind(logit(p, deriv=d), fsqrt(p, deriv=d)),
+ type="n", col="purple", ylab="transformation",
+ lwd=2, las=1,
+ main=if(d==0) "Some probability link functions"
+ else "First derivative")
+ lines(p, logit(p, deriv=d), col="limegreen", lwd=2)
+ lines(p, probit(p, deriv=d), col="purple", lwd=2)
+ lines(p, cloglog(p, deriv=d), col="chocolate", lwd=2)
+ lines(p, fsqrt(p, deriv=d), col="tan", lwd=2)
+ if(d==0) {
+ abline(v=0.5, h=0, lty="dashed")
+ legend(0, 4.5, c("logit", "probit", "cloglog", "fsqrt"),
+ col=c("limegreen","purple","chocolate", "tan"), lwd=2)
+ } else
+ abline(v=0.5, lty="dashed")
+}
+
+for(d in 0) {
+ matplot(y, cbind(logit(y, deriv=d, inverse=TRUE),
+ fsqrt(y, deriv=d, inverse=TRUE)),
+ type="n", col="purple", xlab="transformation", ylab="p",
+ lwd=2, las=1,
+ main=if(d==0) "Some inverse probability link functions"
+ else "First derivative")
+ lines(y, logit(y, deriv=d, inverse=TRUE), col="limegreen", lwd=2)
+ lines(y, probit(y, deriv=d, inverse=TRUE), col="purple", lwd=2)
+ lines(y, cloglog(y, deriv=d, inverse=TRUE), col="chocolate", lwd=2)
+ lines(y, fsqrt(y, deriv=d, inverse=TRUE), col="tan", lwd=2)
+ if(d==0) {
+ abline(h=0.5, v=0, lty="dashed")
+ legend(-4, 1, c("logit", "probit", "cloglog", "fsqrt"),
+ col=c("limegreen","purple","chocolate", "tan"), lwd=2)
+ }
+}
+}
+
+# This is lucky to converge
+earg = list(min=0, max=1, mux=5)
+data(hunua)
+fit.h = vglm(agaaus ~ bs(altitude),
+ fam= binomialff(link="fsqrt", earg=earg),
+ data=hunua, trace=TRUE, crit="d")
+\dontrun{
+plotvgam(fit.h, se=TRUE, lcol="red", scol="red",
+ main="Red is Hunua, Blue is Waitakere")
+}
+predict(fit.h, hunua, type="response")[1:3]
+
+
+\dontrun{
+# The following fails.
+data(pneumo)
+pneumo = transform(pneumo, let=log(exposure.time))
+earg = list(min=0, max=1, mux=10)
+fit = vglm(cbind(normal, mild, severe) ~ let,
+ cumulative(link="fsqrt", earg=earg, par=TRUE, rev=TRUE),
+ data = pneumo, trace=TRUE, maxit=200)
+}
+}
+\keyword{math}
+\keyword{models}
+\keyword{regression}
+
diff --git a/man/gamma1.Rd b/man/gamma1.Rd
index f6aed9e..303d4dc 100644
--- a/man/gamma1.Rd
+++ b/man/gamma1.Rd
@@ -8,7 +8,7 @@
}
\usage{
-gamma1(link = "loge")
+gamma1(link = "loge", earg=list())
}
%- maybe also 'usage' for other objects documented here.
\arguments{
@@ -17,6 +17,11 @@ gamma1(link = "loge")
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.
+
+ }
}
\details{
The density function is given by
diff --git a/man/gamma2.Rd b/man/gamma2.Rd
index 823173a..12a4f02 100644
--- a/man/gamma2.Rd
+++ b/man/gamma2.Rd
@@ -9,6 +9,7 @@
}
\usage{
gamma2(lmu = "loge", lshape = "loge",
+ emu = list(), eshape = list(),
method.init = 1, deviance.arg = FALSE,
ishape = NULL, zero = -2)
}
@@ -20,6 +21,11 @@ gamma2(lmu = "loge", lshape = "loge",
See \code{\link{Links}} for more choices.
}
+ \item{emu, eshape}{
+ List. Extra argument for each of the links.
+ See \code{earg} in \code{\link{Links}} for general information.
+
+ }
\item{ishape}{
Optional initial value for \emph{shape}.
A \code{NULL} means a value is computed internally.
diff --git a/man/gamma2.ab.Rd b/man/gamma2.ab.Rd
index b67229b..ee5aa0c 100644
--- a/man/gamma2.ab.Rd
+++ b/man/gamma2.ab.Rd
@@ -7,6 +7,7 @@
}
\usage{
gamma2.ab(lrate = "loge", lshape = "loge",
+ erate=list(), eshape=list(),
irate=NULL, ishape=NULL, expected = TRUE, zero = 2)
}
%- maybe also 'usage' for other objects documented here.
@@ -17,6 +18,11 @@ gamma2.ab(lrate = "loge", lshape = "loge",
See \code{\link{Links}} for more choices.
}
+ \item{erate, eshape}{
+ List. Extra arguments for the links.
+ See \code{earg} in \code{\link{Links}} for general information.
+
+ }
\item{expected}{
Logical. Use Fisher scoring? The default is yes, otherwise
Newton-Raphson is used.
diff --git a/man/garma.Rd b/man/garma.Rd
index 7e78689..f8b313e 100644
--- a/man/garma.Rd
+++ b/man/garma.Rd
@@ -8,8 +8,9 @@
\usage{
garma(link = c("identity", "loge", "reciprocal",
"logit", "probit", "cloglog", "cauchit"),
+ earg=list(),
p.ar.lag = 1, q.lag.ma = 0,
- coefstart = NULL, step = 1, constant = 0.1)
+ coefstart = NULL, step = 1)
}
%- maybe also 'usage' for other objects documented here.
\arguments{
@@ -23,6 +24,18 @@ garma(link = c("identity", "loge", "reciprocal",
\code{\link{cauchit}} are suitable for binary responses.
}
+ \item{earg}{
+ List. Extra argument for the link.
+ See \code{earg} in \code{\link{Links}} for general information.
+ In particular, this argument is useful
+ when the log or logit link is chosen:
+ for log and logit,
+ zero values can be replaced by \code{bvalue} which
+ is inputted as \code{earg=list(bvalue = bvalue)}.
+ See \code{\link{loge}} and \code{\link{logit}} etc. for specific
+ information about each link function.
+
+ }
\item{p.ar.lag}{
A positive integer,
the lag for the autoregressive component.
@@ -45,13 +58,13 @@ garma(link = c("identity", "loge", "reciprocal",
Numeric. Step length, e.g., \code{0.5} means half-stepsizing.
}
- \item{constant}{
- Used when the log or logit link is chosen.
- For log, zero values are replaced by \code{constant}.
- For logit, zero values are replaced by \code{constant} and
- unit values replaced by \code{1-constant}.
+% \item{constant}{
+% Used when the log or logit link is chosen.
+% For log, zero values are replaced by \code{constant}.
+% For logit, zero values are replaced by \code{constant} and
+% unit values replaced by \code{1-constant}.
- }
+% }
}
\details{
This function draws heavily on Benjamin \emph{et al.} (1998).
@@ -162,7 +175,9 @@ interspike = c(68, 41, 82, 66, 101, 66, 57, 41, 27, 78,
23, 24, 35, 22, 29, 28, 17, 30, 34, 17,
20, 49, 29, 35, 49, 25, 55, 42, 29, 16)
spikenum = seq(interspike)
-fit = vglm(interspike ~ 1, garma("loge",p=2,coef=c(4,.3,.4)), tra=TRUE)
+bvalue = 0.1 # .Machine$double.xmin # Boundary value
+fit = vglm(interspike ~ 1, trace=TRUE,
+ garma("loge", earg=list(bvalue=bvalue), p=2, coef=c(4,.3,.4)))
summary(fit)
coef(fit, matrix=TRUE)
Coef(fit) # A bug here
diff --git a/man/genbetaII.Rd b/man/genbetaII.Rd
index 5629bd4..2f560d3 100644
--- a/man/genbetaII.Rd
+++ b/man/genbetaII.Rd
@@ -9,6 +9,7 @@
\usage{
genbetaII(link.a = "loge", link.scale = "loge",
link.p = "loge", link.q = "loge",
+ earg.a=list(), earg.scale=list(), earg.p=list(), earg.q=list(),
init.a = NULL, init.scale = NULL, init.p = 1, init.q = 1,
zero = NULL)
}
@@ -24,6 +25,11 @@ genbetaII(link.a = "loge", link.scale = "loge",
See \code{\link{Links}} for more choices.
}
+ \item{earg.a, earg.scale, earg.p, earg.q}{
+ List. Extra argument for each of the links.
+ See \code{earg} in \code{\link{Links}} for general information.
+
+ }
\item{init.a, init.scale}{
Optional initial values for \code{a} and \code{scale}.
A \code{NULL} means a value is computed internally.
diff --git a/man/genpoisson.Rd b/man/genpoisson.Rd
index a265019..10f4315 100644
--- a/man/genpoisson.Rd
+++ b/man/genpoisson.Rd
@@ -7,6 +7,7 @@
}
\usage{
genpoisson(llambda = "logit", ltheta = "loge",
+ elambda=list(), etheta=list(),
ilambda = 0.5, itheta = NULL, zero = NULL)
}
%- maybe also 'usage' for other objects documented here.
@@ -24,6 +25,11 @@ genpoisson(llambda = "logit", ltheta = "loge",
The parameter is positive, therefore the default is the log link.
}
+ \item{elambda, etheta}{
+ List. Extra argument for each of the links.
+ 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,
diff --git a/man/geometric.Rd b/man/geometric.Rd
index 43e8dae..f1d9963 100644
--- a/man/geometric.Rd
+++ b/man/geometric.Rd
@@ -6,7 +6,7 @@
Maximum likelihood estimation for the geometric distribution.
}
\usage{
-geometric(link = "logit", expected = TRUE)
+geometric(link = "logit", earg=list(), expected = TRUE)
}
%- maybe also 'usage' for other objects documented here.
\arguments{
@@ -16,6 +16,11 @@ geometric(link = "logit", expected = TRUE)
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{expected}{
Logical.
Fisher scoring is used if \code{expected = TRUE}, else Newton-Raphson.
diff --git a/man/gev.Rd b/man/gev.Rd
index 630d13b..e8b65cc 100644
--- a/man/gev.Rd
+++ b/man/gev.Rd
@@ -33,7 +33,7 @@ egev(llocation = "identity", lscale = "loge", lshape = "logoff",
}
\item{elocation, escale, eshape}{
- Extra argument for the respective links.
+ List. Extra argument for the respective links.
See \code{earg} in \code{\link{Links}} for general information.
For the shape parameter,
if the \code{\link{logoff}} link is chosen then the offset is
@@ -251,7 +251,7 @@ plot(fit1, se=TRUE, lcol="blue", scol="forestgreen",
main="Fitted mu(year) function (centered)")
attach(venice)
matplot(year, y[,1:2], ylab="Sea level (cm)", col=1:2,
- main="Highest 2 annual sealevels & fitted 95 percentile")
+ main="Highest 2 annual sealevels and fitted 95 percentile")
lines(year, fitted(fit1)[,1], lty="dashed", col="blue")
detach(venice)
}
diff --git a/man/ggamma.Rd b/man/ggamma.Rd
index 79c8c81..6e08fd5 100644
--- a/man/ggamma.Rd
+++ b/man/ggamma.Rd
@@ -9,6 +9,7 @@
}
\usage{
ggamma(lscale="loge", ld="loge", lk="loge",
+ escale=list(), ed=list(), ek=list(),
iscale=NULL, id=NULL, ik=NULL, zero=NULL)
}
%- maybe also 'usage' for other objects documented here.
@@ -19,6 +20,11 @@ ggamma(lscale="loge", ld="loge", lk="loge",
See \code{\link{Links}} for more choices.
}
+ \item{escale, ed, ek}{
+ List. Extra argument for each of the links.
+ See \code{earg} in \code{\link{Links}} for general information.
+
+ }
\item{iscale, id, ik}{
Initial value for \eqn{b}, \eqn{d} and \eqn{k}, respectively.
The defaults mean an initial value is determined internally for each.
diff --git a/man/golf.Rd b/man/golf.Rd
index a800d42..ceb08d2 100644
--- a/man/golf.Rd
+++ b/man/golf.Rd
@@ -25,6 +25,7 @@ golf(theta, earg = list(lambda = 1), inverse = FALSE, deriv = 0,
in \code{\link{gamma2}}.
A component in the list called \code{cutpoint} is optional; if omitted
then \code{cutpoint} is ignored from the GOLF definition.
+ If given, the cutpoints should be non-negative integers.
If \code{golf()} is used as the link function in
\code{\link{cumulative}} then, if the cutpoints are known, then
one should choose
@@ -73,7 +74,7 @@ golf(theta, earg = list(lambda = 1), inverse = FALSE, deriv = 0,
}
\references{
Yee, T. W. (2006)
- \emph{Link functions for ordinal count data},
+ \emph{Ordinal ordination with normalizing link functions for count data},
(submitted for publication).
}
@@ -108,11 +109,11 @@ golf(theta, earg = list(lambda = 1), inverse = FALSE, deriv = 0,
}
\examples{
-golf("prob", short=FALSE)
-golf("prob", tag=TRUE)
+earg = list(lambda=1)
+golf("p", earg=earg, short=FALSE)
+golf("p", earg=earg, tag=TRUE)
p = seq(0.02, 0.98, len=201)
-earg = list(lambda=1)
y = golf(p, earg=earg)
y. = golf(p, earg=earg, deriv=1)
max(abs(golf(y, earg=earg, inv=TRUE) - p)) # Should be 0
@@ -137,6 +138,7 @@ y1 = rgamma(nn, shape=lambda, scale=mymu/lambda)
cutpoints = c(-Inf, 10, 20, Inf)
cuty = Cut(y1, breaks=cutpoints)
\dontrun{
+par(mfrow=c(1,1), las=1)
plot(x2, x3, col=cuty, pch=as.character(cuty))
}
table(cuty) / sum(table(cuty))
diff --git a/man/gumbelIbiv.Rd b/man/gumbelIbiv.Rd
new file mode 100644
index 0000000..c242d06
--- /dev/null
+++ b/man/gumbelIbiv.Rd
@@ -0,0 +1,96 @@
+\name{gumbelIbiv}
+\alias{gumbelIbiv}
+%- Also NEED an '\alias' for EACH other topic documented here.
+\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.
+
+}
+\usage{
+gumbelIbiv(lapar="identity", earg=list(), iapar=NULL, method.init=1)
+}
+%- maybe also 'usage' for other objects documented here.
+\arguments{
+ \item{lapar}{
+ Link function applied to the association parameter
+ \eqn{\alpha}{alpha}.
+ 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{iapar}{
+ 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.
+ Assigning a value will override the argument \code{method.init}.
+
+ }
+ \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}.
+
+ }
+}
+\details{
+ The cumulative distribution function is
+ \deqn{P(Y_1 \leq y_1, Y_2 \leq y_2) = e^{-y_1-y_2+\alpha y_1 y_2}
+ + 1 - e^{-y_1} - e^{-y_2} }{%
+ P(Y1 <= y1, Y2 <= y2) =
+ exp(-y1-y2+alpha*y1*y2) + 1 - exp(-y1) - exp(-y2) }
+ for real \eqn{\alpha}{alpha}.
+ The support of the function is for \eqn{y_1>0}{y1>0} and
+ \eqn{y_2>0}{y2>0}.
+ The marginal distributions are an exponential distribution with
+ unit mean.
+
+ 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}.
+
+}
+\value{
+ An object of class \code{"vglmff"} (see \code{\link{vglmff-class}}).
+ The object is used by modelling functions such as \code{\link{vglm}}
+ and \code{\link{vgam}}.
+}
+
+\references{
+
+Castillo, E., Hadi, A. S., Balakrishnan, N. Sarabia, J. S. (2005)
+\emph{Extreme Value and Related Models with Applications in Engineering and Science},
+Hoboken, N.J.: Wiley-Interscience.
+
+}
+\author{ T. W. Yee }
+\note{
+ 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.
+
+ This \pkg{VGAM} family function should be used with caution.
+
+}
+
+\seealso{
+ \code{\link{morgenstern}}.
+}
+\examples{
+n = 1000
+ymat = cbind(rexp(n), rexp(n))
+\dontrun{plot(ymat)}
+fit = vglm(ymat ~ 1, fam=gumbelIbiv, trace=TRUE)
+fit = vglm(ymat ~ 1, fam=gumbelIbiv, trace=TRUE, crit="coef")
+coef(fit, matrix=TRUE)
+Coef(fit)
+fitted(fit)[1:5,]
+}
+\keyword{models}
+\keyword{regression}
+
diff --git a/man/hyper.Rd b/man/hyperg.Rd
similarity index 88%
rename from man/hyper.Rd
rename to man/hyperg.Rd
index 635db2c..b0ab0ad 100644
--- a/man/hyper.Rd
+++ b/man/hyperg.Rd
@@ -1,6 +1,6 @@
-\name{hyper}
-%\alias{hyper}
-\alias{hyper}
+\name{hyperg}
+%\alias{hyperg}
+\alias{hyperg}
%- Also NEED an '\alias' for EACH other topic documented here.
\title{ Hypergeometric Family Function }
\description{
@@ -10,7 +10,7 @@
}
\usage{
-hyper(N=NULL, D=NULL, lprob="logit", iprob=NULL)
+hyperg(N=NULL, D=NULL, lprob="logit", earg=list(), iprob=NULL)
}
%- maybe also 'usage' for other objects documented here.
\arguments{
@@ -32,6 +32,11 @@ hyper(N=NULL, D=NULL, lprob="logit", iprob=NULL)
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{iprob}{
Optional initial value for the probabilities.
The default is to choose initial values internally.
@@ -109,12 +114,12 @@ y = rhyper(nn=nn, m=m, n=n, k=k)
yprop = y / k # sample proportions
# N is unknown, D is known. Both models are equivalent:
-fit = vglm(cbind(y,k-y) ~ 1, hyper(D=m), trace=TRUE, crit="c")
-fit = vglm(yprop ~ 1, hyper(D=m), weight=k, trace=TRUE, crit="c")
+fit = vglm(cbind(y,k-y) ~ 1, hyperg(D=m), trace=TRUE, crit="c")
+fit = vglm(yprop ~ 1, hyperg(D=m), weight=k, trace=TRUE, crit="c")
# N is known, D is unknown. Both models are equivalent:
-fit = vglm(cbind(y,k-y) ~ 1, hyper(N=m+n), trace=TRUE, crit="l")
-fit = vglm(yprop ~ 1, hyper(N=m+n), weight=k, trace=TRUE, crit="l")
+fit = vglm(cbind(y,k-y) ~ 1, hyperg(N=m+n), trace=TRUE, crit="l")
+fit = vglm(yprop ~ 1, hyperg(N=m+n), weight=k, trace=TRUE, crit="l")
coef(fit, matrix=TRUE)
Coef(fit) # Should be equal to the true population proportion
diff --git a/man/hypersecant.Rd b/man/hypersecant.Rd
new file mode 100644
index 0000000..307ea1b
--- /dev/null
+++ b/man/hypersecant.Rd
@@ -0,0 +1,95 @@
+\name{hypersecant}
+\alias{hypersecant}
+\alias{hypersecant.1}
+%- Also NEED an '\alias' for EACH other topic documented here.
+\title{ Hyperbolic Secant Distribution Family Function }
+\description{
+ Estimation of the parameter of the hyperbolic secant
+ distribution.
+
+}
+\usage{
+hypersecant(link.theta="elogit", earg=if(link.theta=="elogit")
+ list(min=-pi/2, max=pi/2) else list(), init.theta=NULL)
+hypersecant.1(link.theta="elogit", earg=if(link.theta=="elogit")
+ list(min=-pi/2, max=pi/2) else list(), init.theta=NULL)
+}
+%- maybe also 'usage' for other objects documented here.
+\arguments{
+ \item{link.theta}{
+ Parameter link function applied to the parameter \eqn{\theta}{theta}.
+ 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{init.theta}{
+ Optional initial value for \eqn{\theta}{theta}.
+ If failure to converge occurs, try some other value.
+ The default means an initial value is determined internally.
+
+ }
+}
+\details{
+ The probability density function of the hyperbolic secant distribution
+ is given by
+ \deqn{f(y)=\exp(\theta y + \log(\cos(\theta ))) / (2 \cosh(\pi y/2)),}{%
+ f(y) =exp(theta*y + log(cos(theta ))) / (2*cosh(pi*y/2)),}
+ for parameter \eqn{-\pi/2 < \theta < \pi/2}{pi/2 < theta < pi/2}
+ and all real \eqn{y}.
+ The mean of \eqn{Y} is \eqn{\tan(\theta)}{tan(theta)} (returned as
+ the fitted values).
+
+ Another parameterization is used for \code{hypersecant.1()}.
+ This uses
+ \deqn{f(y)=(\cos(\theta)/\pi) \times y^{-0.5+\theta/\pi} \times
+ (1-y)^{-0.5-\theta/\pi},}{%
+ f(y) =(cos(theta)/pi) * y^(-0.5+theta/pi) * (1-y)^(-0.5-theta/pi),}
+ for parameter \eqn{-\pi/2 < \theta < \pi/2}{pi/2 < theta < pi/2}
+ and \eqn{0 < y < 1}.
+ Then the mean of \eqn{Y} is \eqn{0.5 + \theta/\pi}{0.5 + theta/pi}
+ (returned as the fitted values) and the variance is
+ \eqn{(\pi^2 - 4 \theta^2) / (8\pi^2)}{(pi^2 - 4*theta^2) / (8*pi^2)}.
+
+ For both parameterizations Newton-Raphson is same as Fisher scoring.
+
+}
+
+\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{
+ Jorgensen, B. (1997)
+ \emph{The Theory of Dispersion Models}.
+ London: Chapman & Hall.
+% p.101, Eqn (3.37).
+
+}
+
+\author{ T. W. Yee }
+%\note{
+
+%}
+\seealso{
+ \code{\link{elogit}}.
+}
+\examples{
+x = rnorm(n <- 200)
+y = rnorm(n) # Not very good data!
+fit = vglm(y ~ x, hypersecant, trace=TRUE, crit="c")
+coef(fit, matrix=TRUE)
+fit at misc$earg
+
+# Not recommended
+fit = vglm(y ~ x, hypersecant(link="identity"), trace=TRUE, crit="c")
+coef(fit, matrix=TRUE)
+fit at misc$earg
+}
+\keyword{models}
+\keyword{regression}
diff --git a/man/hzeta.Rd b/man/hzeta.Rd
index 5b37a82..c0ed513 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", init.alpha = NULL)
+hzeta(link = "loglog", earg=list(), init.alpha = NULL)
}
%- maybe also 'usage' for other objects documented here.
\arguments{
@@ -17,6 +17,11 @@ hzeta(link = "loglog", init.alpha = NULL)
the mean is finite.
}
+ \item{earg}{
+ List. Extra argument for the link.
+ See \code{earg} in \code{\link{Links}} for general information.
+
+ }
\item{init.alpha}{
Optional initial value for the (positive) parameter.
The default is to obtain an initial value internally. Use this argument
@@ -67,8 +72,8 @@ hzeta(link = "loglog", init.alpha = NULL)
\code{\link{loglog}}.
}
\examples{
-alpha = exp(0.1) # The parameter
-y = rhzeta(n=400, alpha) # Generate some hzeta random variates
+alpha = exp(exp(0.5)) # 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
diff --git a/man/iam.Rd b/man/iam.Rd
index 624f2c5..01d7c8d 100644
--- a/man/iam.Rd
+++ b/man/iam.Rd
@@ -6,24 +6,43 @@
Maps the elements of an array containing symmetric positive-definite
matrices to a matrix with sufficient columns to hold them
(called matrix-band format.)
+
}
\usage{
iam(j, k, M, hbw = M, both = FALSE, diagonal = TRUE)
}
%- maybe also 'usage' for other objects documented here.
\arguments{
- \item{j}{ An integer from the set \{\code{1:M}\} giving the row number
- of an element.}
- \item{k}{ An integer from the set \{\code{1:M}\} giving the column number
- of an element.}
- \item{M}{ The number of linear/additive predictors. This is the
- dimension of each positive-definite symmetric matrix. }
- \item{hbw}{ Defunct. }
- \item{both}{ Logical. Return both the row and column indices?
- See below for more details. }
- \item{diagonal}{ Logical. Return the indices for the diagonal elements?
+ \item{j}{
+ An integer from the set \{\code{1:M}\} giving the row number
+ of an element.
+
+ }
+ \item{k}{
+ An integer from the set \{\code{1:M}\} giving the column number
+ of an element.
+
+ }
+ \item{M}{
+ The number of linear/additive predictors. This is the
+ dimension of each positive-definite symmetric matrix.
+
+ }
+ \item{hbw}{
+ Defunct.
+
+ }
+ \item{both}{
+ Logical. Return both the row and column indices?
+ See below for more details.
+
+ }
+ \item{diagonal}{
+ Logical. Return the indices for the diagonal elements?
If \code{FALSE} then only the strictly upper triangular part of the matrix
- elements are used. }
+ elements are used.
+
+ }
}
\details{
Suppose we have \eqn{n} symmetric positive-definite square matrices,
@@ -44,30 +63,37 @@ iam(j, k, M, hbw = M, both = FALSE, diagonal = TRUE)
}
\value{
-This function has a dual purpose depending on the value of \code{both}.
- If \code{both=FALSE} then the column number corresponding to the
- \code{j}-\code{k} element of the matrix is returned.
+ This function has a dual purpose depending on the value of \code{both}.
+ If \code{both=FALSE} then the column number corresponding
+ to the \code{j}-\code{k} element of the matrix is returned.
If \code{both=TRUE} then \code{j} and \code{k} are ignored and a list
- with the following components are returned.
- \item{row.index}{The row indices of the upper triangular part of the
- matrix (This may or may not include the diagonal elements, depending
- on the argument \code{diagonal}).
+ with the following components are returned.
+
+ \item{row.index}{
+ The row indices of the upper triangular part of the
+ matrix (This may or may not include the diagonal elements, depending
+ on the argument \code{diagonal}).
+
}
- \item{col.index}{The column indices of the upper triangular part of the
- matrix (This may or may not include the diagonal elements, depending
- on the argument \code{diagonal}).
+ \item{col.index}{
+ The column indices of the upper triangular part of the
+ matrix (This may or may not include the diagonal elements, depending
+ on the argument \code{diagonal}).
+
}
}
\references{
-The website \url{http://www.stat.auckland.ac.nz/~yee} contains
-some additional information.
+ The website \url{http://www.stat.auckland.ac.nz/~yee} contains
+ some additional information.
+
}
\author{ T. W. Yee }
\note{
-This function is used in the \code{weight} slot of many
-\pkg{VGAM} family functions (see \code{\link{vglmff-class}}),
-especially those whose \eqn{M} is determined by the data,
-e.g., \code{\link{dirichlet}}, \code{\link{multinomial}}.
+ This function is used in the \code{weight} slot of many \pkg{VGAM}
+ family functions (see \code{\link{vglmff-class}}), especially those
+ whose \eqn{M} is determined by the data, e.g., \code{\link{dirichlet}},
+ \code{\link{multinomial}}.
+
}
\seealso{
@@ -76,7 +102,7 @@ e.g., \code{\link{dirichlet}}, \code{\link{multinomial}}.
}
\examples{
iam(1, 2, M=3) # The 4th column represents element (1,2) of a 3x3 matrix
-iam(NULL, NULL, M=3, both=TRUE) # Return the row & column indices
+iam(NULL, NULL, M=3, both=TRUE) # Return the row and column indices
dirichlet()@weight
diff --git a/man/identity.Rd b/man/identity.Rd
index e99d90d..1c25f30 100644
--- a/man/identity.Rd
+++ b/man/identity.Rd
@@ -88,8 +88,8 @@ nidentity(theta, earg = list(), inverse = FALSE, deriv = 0,
\code{\link{loge}},
\code{\link{logit}},
\code{\link{probit}},
- \code{powl}.
- }
+ \code{\link{powl}}.
+}
\examples{
identity((-5):5)
identity((-5):5, deriv=1)
diff --git a/man/inv.gaussianff.Rd b/man/inv.gaussianff.Rd
index 3d0d527..c7a287f 100644
--- a/man/inv.gaussianff.Rd
+++ b/man/inv.gaussianff.Rd
@@ -8,7 +8,9 @@
}
\usage{
-inv.gaussianff(lmu="loge", llambda="loge", ilambda=1, zero=NULL)
+inv.gaussianff(lmu="loge", llambda="loge",
+ emu=list(), elambda=list(),
+ ilambda=1, zero=NULL)
}
%- maybe also 'usage' for other objects documented here.
\arguments{
@@ -18,6 +20,11 @@ inv.gaussianff(lmu="loge", llambda="loge", ilambda=1, zero=NULL)
See \code{\link{Links}} for more choices.
}
+ \item{emu, elambda}{
+ List. Extra argument for each of the links.
+ See \code{earg} in \code{\link{Links}} for general information.
+
+ }
\item{ilambda}{
Initial value for the \eqn{\lambda}{lambda} parameter.
@@ -65,11 +72,10 @@ New York: Wiley-Interscience, Third edition.
}
\author{ T. W. Yee }
\note{
- The inverse Gaussian distribution can be fitted (to a
- certain extent) using the usual GLM framework involving
- a scale parameter. This family function is different from
- that approach in that it estimates both parameters by
- full maximum likelihood estimation.
+ The inverse Gaussian distribution can be fitted (to a certain extent)
+ using the usual GLM framework involving a scale parameter. This family
+ function is different from that approach in that it estimates both
+ parameters by full maximum likelihood estimation.
}
@@ -85,9 +91,9 @@ New York: Wiley-Interscience, Third edition.
}
\examples{
n = 1000
-shape = 5
-y = rgamma(n=n, shape=shape) # Not inverse Gaussian!!
-fit = vglm(y ~ 1, inv.gaussianff, trace=TRUE, crit="coef")
+shape = exp(3)
+y = rinv.gaussian(n=n, mu=exp(2), lambda=shape)
+fit = vglm(y ~ 1, inv.gaussianff(ilam=shape), trace=TRUE)
coef(fit, matrix=TRUE)
Coef(fit)
summary(fit)
diff --git a/man/invlomax.Rd b/man/invlomax.Rd
index 17e7c54..8abe52c 100644
--- a/man/invlomax.Rd
+++ b/man/invlomax.Rd
@@ -8,6 +8,7 @@
}
\usage{
invlomax(link.scale = "loge", link.p = "loge",
+ earg.scale=list(), earg.p=list(),
init.scale = NULL, init.p = 1, zero = NULL)
}
%- maybe also 'usage' for other objects documented here.
@@ -19,6 +20,11 @@ invlomax(link.scale = "loge", link.p = "loge",
See \code{\link{Links}} for more choices.
}
+ \item{earg.scale, earg.p}{
+ List. Extra argument for each of the links.
+ See \code{earg} in \code{\link{Links}} for general information.
+
+ }
\item{init.scale, init.p}{
Optional initial values for \code{scale} and \code{p}.
diff --git a/man/invparalogistic.Rd b/man/invparalogistic.Rd
index 85799cc..139af16 100644
--- a/man/invparalogistic.Rd
+++ b/man/invparalogistic.Rd
@@ -8,6 +8,7 @@
}
\usage{
invparalogistic(link.a = "loge", link.scale = "loge",
+ earg.a=list(), earg.scale=list(),
init.a = 1, init.scale = NULL, zero = NULL)
}
%- maybe also 'usage' for other objects documented here.
@@ -19,6 +20,11 @@ invparalogistic(link.a = "loge", link.scale = "loge",
See \code{\link{Links}} for more choices.
}
+ \item{earg.a, earg.scale}{
+ List. Extra argument for each of the links.
+ See \code{earg} in \code{\link{Links}} for general information.
+
+ }
\item{init.a, init.scale}{
Optional initial values for \code{a} and \code{scale}.
diff --git a/man/leipnik.Rd b/man/leipnik.Rd
index ed6787c..38dcadb 100644
--- a/man/leipnik.Rd
+++ b/man/leipnik.Rd
@@ -8,7 +8,9 @@
}
\usage{
-leipnik(lmu = "logit", llambda = "loge", imu = NULL, ilambda = NULL)
+leipnik(lmu = "logit", llambda = "loge",
+ emu=list(), elambda=list(),
+ imu = NULL, ilambda = NULL)
}
%- maybe also 'usage' for other objects documented here.
\arguments{
@@ -22,10 +24,15 @@ leipnik(lmu = "logit", llambda = "loge", imu = NULL, ilambda = NULL)
\eqn{\lambda}{lambda}.
}
+ \item{emu, elambda}{
+ List. Extra argument for each of the links.
+ See \code{earg} in \code{\link{Links}} for general information.
+
+ }
}
\details{
The (transformed) Leipnik distribution has density function
- \deqn{f(y;\mu,\lambda) = \frac{ \{ y(1-y) \}^{-\frac12}}{
+ \deqn{f(y;\mu,\lambda) = \frac{ \{ y(1-y) \}^{-\frac12}}{
\mbox{Beta}( \frac{\lambda+1}{2}, \frac12 )}
\left[ 1 + \frac{(y-\mu)^2 }{y(1-y)}
\right]^{ -\frac{\lambda}{2}}}{%
@@ -89,8 +96,8 @@ leipnik(lmu = "logit", llambda = "loge", imu = NULL, ilambda = NULL)
\examples{
y = rnorm(n=2000, mean=0.5, sd=0.1) # Not good data
fit = vglm(y ~ 1, leipnik(ilambda=1), tr=TRUE, checkwz=FALSE)
-fit = vglm(y ~ 1, leipnik(ilambda=1), tr=TRUE, cri="c", checkwz=FALSE)
-
+fit = vglm(y ~ 1, leipnik(ilambda=1,llam=logoff, elam=list(offset=1)),
+ trace=TRUE, cri="coef")
fitted(fit)[1:5]
mean(y)
summary(fit)
@@ -103,3 +110,4 @@ sum(weights(fit, type="w")) # sum of the working weights
\keyword{models}
\keyword{regression}
+%fit = vglm(y ~ 1, leipnik(ilambda=1), tr=TRUE, cri="c", checkwz=FALSE)
diff --git a/man/levy.Rd b/man/levy.Rd
index f617813..d4821b3 100644
--- a/man/levy.Rd
+++ b/man/levy.Rd
@@ -7,7 +7,8 @@ Estimates the two parameters of the Levy distribution
by maximum likelihood estimation.
}
\usage{
-levy(delta = NULL, link.gamma = "loge", idelta = NULL, igamma = NULL)
+levy(delta = NULL, link.gamma = "loge", earg=list(),
+ idelta = NULL, igamma = NULL)
}
%- maybe also 'usage' for other objects documented here.
\arguments{
@@ -21,6 +22,11 @@ levy(delta = NULL, link.gamma = "loge", idelta = NULL, igamma = NULL)
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{idelta}{
Initial value for the \eqn{\delta}{delta} parameter
(if it is to be estimated).
diff --git a/man/lgammaff.Rd b/man/lgammaff.Rd
index 1a07fbc..581bec3 100644
--- a/man/lgammaff.Rd
+++ b/man/lgammaff.Rd
@@ -9,8 +9,9 @@
}
\usage{
-lgammaff(link = "loge", init.k = NULL)
+lgammaff(link = "loge", earg=list(), init.k = NULL)
lgamma3ff(llocation="identity", lscale="loge", lshape="loge",
+ elocation=list(), escale=list(), eshape=list(),
ilocation=NULL, iscale=NULL, ishape=1, zero=NULL)
}
%- maybe also 'usage' for other objects documented here.
@@ -33,6 +34,11 @@ lgamma3ff(llocation="identity", lscale="loge", lshape="loge",
See \code{\link{Links}} for more choices.
}
+ \item{earg, elocation, escale, eshape}{
+ List. Extra argument for each of the links.
+ See \code{earg} in \code{\link{Links}} for general information.
+
+ }
\item{init.k, ishape}{
Initial value for \eqn{k}.
If given, it must be positive.
diff --git a/man/lino.Rd b/man/lino.Rd
index 7f3d106..3f81458 100644
--- a/man/lino.Rd
+++ b/man/lino.Rd
@@ -9,6 +9,7 @@
}
\usage{
lino(lshape1="loge", lshape2="loge", llambda="loge",
+ eshape1=list(), eshape2=list(), elambda=list(),
ishape1=NULL, ishape2=NULL, ilambda=1, zero=NULL)
}
%- maybe also 'usage' for other objects documented here.
@@ -25,6 +26,11 @@ lino(lshape1="loge", lshape2="loge", llambda="loge",
See \code{\link{Links}} for more choices.
}
+ \item{eshape1, eshape2, elambda}{
+ List. Extra argument for each of the links.
+ See \code{earg} in \code{\link{Links}} for general information.
+
+ }
\item{ishape1, ishape2, ilambda}{
Initial values for the parameters. A \code{NULL} value means
one is computed internally. The argument \code{ilambda} must
@@ -112,11 +118,9 @@ Coef(fit)
fitted(fit)[1:4]
summary(fit)
-
# Nonstandard beta distribution
y = rlino(n=1000, shape1=2, shape2=3, lambda=exp(1))
-fit = vglm(y ~ 1, lino(lshape1=identity, lshape2=identity, ilambda=10),
- trace=TRUE, crit="c")
+fit = vglm(y ~ 1, lino(lshape1=identity, lshape2=identity, ilambda=10))
coef(fit, mat=TRUE)
}
\keyword{models}
diff --git a/man/lms.bcg.Rd b/man/lms.bcg.Rd
index d9ffac2..a21178c 100644
--- a/man/lms.bcg.Rd
+++ b/man/lms.bcg.Rd
@@ -8,7 +8,8 @@
}
\usage{
lms.bcg(percentiles = c(25, 50, 75), zero = NULL,
- link.sigma = "loge", link.mu="identity",
+ link.mu="identity", link.sigma = "loge",
+ emu=list(), esigma=list(),
dfmu.init=4, dfsigma.init=2,
init.lambda = 1, init.sigma = NULL)
}
@@ -29,13 +30,6 @@ lms.bcg(percentiles = c(25, 50, 75), zero = NULL,
functions of the covariates.
}
- \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{link.mu}{
Parameter link function applied to the second linear/additive predictor.
@@ -45,6 +39,18 @@ lms.bcg(percentiles = c(25, 50, 75), zero = NULL,
% (it is something similar to the running median).
}
+ \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{emu, esigma}{
+ List. Extra argument for each of the links.
+ See \code{earg} in \code{\link{Links}} for general information.
+
+ }
\item{dfmu.init}{
Degrees of freedom for the cubic smoothing spline fit applied to
get an initial estimate of mu.
@@ -158,7 +164,7 @@ plotvgam(fit, se=TRUE) # Plot mu function (only)
# Here, we prematurely stop iterations because it fails near the solution
fit = vgam(BMI ~ s(age, df=c(4,2)), maxit=4,
fam=lms.bcg(zero=1, init.lam=3), data=bminz, tr=TRUE)
-
+summary(fit)
predict(fit)[1:3,]
fitted(fit)[1:3,]
bminz[1:3,]
diff --git a/man/lms.bcn.Rd b/man/lms.bcn.Rd
index 77565ca..f51e175 100644
--- a/man/lms.bcn.Rd
+++ b/man/lms.bcn.Rd
@@ -8,7 +8,8 @@
}
\usage{
lms.bcn(percentiles = c(25, 50, 75), zero = NULL,
- link.sigma = "loge", link.mu="identity",
+ link.mu="identity", link.sigma = "loge",
+ emu=list(), esigma=list(),
dfmu.init=4, dfsigma.init=2,
init.lambda = 1, init.sigma = NULL)
}
@@ -29,13 +30,6 @@ lms.bcn(percentiles = c(25, 50, 75), zero = NULL,
functions of the covariates.
}
- \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{link.mu}{
Parameter link function applied to the second linear/additive predictor.
See \code{\link{Links}} for more choices.
@@ -45,6 +39,18 @@ lms.bcn(percentiles = c(25, 50, 75), zero = NULL,
% (it is something similar to the running median).
}
+ \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{emu, esigma}{
+ List. Extra argument for each of the links.
+ See \code{earg} in \code{\link{Links}} for general information.
+
+ }
\item{dfmu.init}{
Degrees of freedom for the cubic smoothing spline fit applied to
get an initial estimate of mu.
diff --git a/man/lms.yjn.Rd b/man/lms.yjn.Rd
index 7f9f4f0..305e457 100644
--- a/man/lms.yjn.Rd
+++ b/man/lms.yjn.Rd
@@ -9,6 +9,7 @@
\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,
@@ -43,6 +44,11 @@ lms.yjn(percentiles = c(25, 50, 75), zero = NULL,
% It is the natural log by default because sigma is positive.
}
+ \item{elambda, esigma}{
+ List. Extra argument for each of the links.
+ See \code{earg} in \code{\link{Links}} for general information.
+
+ }
\item{dfmu.init}{
Degrees of freedom for the cubic smoothing spline fit applied to
get an initial estimate of mu.
diff --git a/man/logff.Rd b/man/logff.Rd
index 9b28202..a0e3fe1 100644
--- a/man/logff.Rd
+++ b/man/logff.Rd
@@ -6,7 +6,7 @@
Estimating the parameter of the logarithmic distribution.
}
\usage{
-logff(link = "logit", init.c = NULL)
+logff(link = "logit", earg=list(), init.c = NULL)
}
%- maybe also 'usage' for other objects documented here.
\arguments{
@@ -16,6 +16,11 @@ logff(link = "logit", init.c = NULL)
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{init.c}{
Optional initial value for the \eqn{c} parameter.
If given, it often pays to start with a larger value, e.g., 0.95.
diff --git a/man/logistic.Rd b/man/logistic.Rd
index 55a9851..68e9806 100644
--- a/man/logistic.Rd
+++ b/man/logistic.Rd
@@ -10,8 +10,10 @@
}
\usage{
-logistic1(llocation="identity", scale.arg=1, method.init=1)
+logistic1(llocation="identity", elocation=list(),
+ scale.arg=1, method.init=1)
logistic2(llocation="identity", lscale="loge",
+ elocation=list(), escale=list(),
ilocation=NULL, iscale=NULL, method.init=1, zero=NULL)
}
%- maybe also 'usage' for other objects documented here.
@@ -21,6 +23,11 @@ logistic2(llocation="identity", lscale="loge",
See \code{\link{Links}} for more choices.
}
+ \item{elocation, escale}{
+ List. Extra argument for each of the links.
+ See \code{earg} in \code{\link{Links}} for general information.
+
+ }
\item{scale.arg}{
Known positive scale parameter (called \eqn{s} below).
diff --git a/man/loglinb2.Rd b/man/loglinb2.Rd
index 9590718..f301684 100644
--- a/man/loglinb2.Rd
+++ b/man/loglinb2.Rd
@@ -26,7 +26,11 @@ loglinb2(exchangeable = FALSE, zero = NULL)
The normalizing parameter \eqn{u_0}{u0} can be expressed as a function
of the other parameters, viz.,
\deqn{u_0 = -\log[1 + \exp(u_1) + \exp(u_2) + \exp(u_1 + u_2 + u_{12})].}{%
- u0 = -log[1 + exp(u1) + exp(u2) + exp(u1 + u2 + u12)].}
+ u0 = -log[1 + exp(u1) + exp(u2) + exp(u1 + u2 + u12)].}
+ The linear/additive predictors are
+ \eqn{(\eta_1,\eta_2,\eta_3)^T = (u_1,u_2,u_{12})^T}{(eta1,eta2,eta3) =
+ (u1,u2,u12)}.
+
}
\value{
An object of class \code{"vglmff"} (see \code{\link{vglmff-class}}).
@@ -61,6 +65,8 @@ contains further information and examples.
The response must be a two-column matrix of ones and zeros only.
This is more restrictive than \code{\link{binom2.or}}, which can handle
more types of input formats.
+ Note that each of the 4 combinations of the multivariate response
+ need to appear in the data set.
}
diff --git a/man/loglinb3.Rd b/man/loglinb3.Rd
index 7c44ece..cddd40f 100644
--- a/man/loglinb3.Rd
+++ b/man/loglinb3.Rd
@@ -18,17 +18,22 @@ loglinb3(exchangeable = FALSE, zero = NULL)
}
\details{
The model is \eqn{P(Y_1=y_1,Y_2=y_2,Y_3=y_3) =}{P(Y1=y1,Y2=y2,Y3=y3) =}
- \deqn{\exp(u_0+u_1 y_1+u_2 y_2+u_3 y_3+u_{12} y_1 y_2+u_{12} y_1 y_2+
- u_{13} y_1 y_3+u_{23} y_2 y_3)}{%
- exp(u0 + u1*y1 + u2*y2 + u3*y3 + u12*y1*y2 + u13*y1*y3+ u23*y2*y3)}
+ \deqn{\exp(u_0+u_1 y_1+u_2 y_2+u_3 y_3+u_{12} y_1 y_2+
+ u_{13} y_1 y_3+u_{23} y_2 y_3)}{%
+ exp(u0 + u1*y1 + u2*y2 + u3*y3 + u12*y1*y2 + u13*y1*y3+ u23*y2*y3)}
where \eqn{y_1}{y1}, \eqn{y_2}{y2} and \eqn{y_3}{y3} are 0 or 1,
and the parameters are \eqn{u_1}{u1}, \eqn{u_2}{u2}, \eqn{u_3}{u3},
\eqn{u_{12}}{u12}, \eqn{u_{13}}{u13}, \eqn{u_{23}}{u23}. The
normalizing parameter \eqn{u_0}{u0} can be expressed as a function of
the other parameters. Note that a third-order association parameter,
- \eqn{u_{123}}{u123} for the produce \eqn{y_1 y_2 y_3}{y1*y2*y3},
+ \eqn{u_{123}}{u123} for the product \eqn{y_1 y_2 y_3}{y1*y2*y3},
is assumed to be zero for this family function.
+ The linear/additive predictors are
+ \eqn{(\eta_1,\eta_2,\ldots,\eta_6)^T =
+ (u_1,u_2,u_3,u_{12},u_{13},u_{23})^T}{(eta1,eta2,...,eta6) =
+ (u1,u2,u3,u12,u13,u23)}.
+
}
\value{
diff --git a/man/lognormal.Rd b/man/lognormal.Rd
index 9a3fb84..93510c2 100644
--- a/man/lognormal.Rd
+++ b/man/lognormal.Rd
@@ -9,19 +9,26 @@
}
\usage{
-lognormal(lmeanlog = "identity", lsdlog = "loge", zero = NULL)
+lognormal(lmeanlog = "identity", lsdlog = "loge",
+ emeanlog=list(), esdlog=list(), zero = NULL)
lognormal3(lmeanlog = "identity", lsdlog = "loge",
+ emeanlog=list(), esdlog=list(),
powers.try = (-3):3, delta = NULL, zero = NULL)
}
%- maybe also 'usage' for other objects documented here.
\arguments{
- \item{lmeanlog, lsdlog}{
+ \item{lmeanlog, lsdlog}{
Parameter link functions applied to the mean and (positive)
\eqn{\sigma}{sigma} (standard deviation) parameter.
Both of these are on the log scale.
See \code{\link{Links}} for more choices.
}
+ \item{emeanlog, esdlog}{
+ List. Extra argument for each of the links.
+ See \code{earg} in \code{\link{Links}} for general information.
+
+ }
\item{zero}{
An integer-valued vector specifying which
linear/additive predictors are modelled as intercepts only.
@@ -109,9 +116,8 @@ fit = vglm(y ~ x, lognormal(zero=1), trace=TRUE, crit="c")
coef(fit, mat=TRUE)
Coef(fit)
-n = 1000
lambda = 4
-y = lambda + rlnorm(n, mean=1.5, sd=exp(-0.8))
+y = lambda + rlnorm(n <- 1000, mean=1.5, sd=exp(-0.8))
fit = vglm(y ~ 1, lognormal3, trace=TRUE)
fit = vglm(y ~ 1, lognormal3, trace=TRUE, crit="c")
coef(fit, mat=TRUE)
diff --git a/man/lomax.Rd b/man/lomax.Rd
index fa86229..f39ad74 100644
--- a/man/lomax.Rd
+++ b/man/lomax.Rd
@@ -8,6 +8,7 @@
}
\usage{
lomax(link.scale = "loge", link.q = "loge",
+ earg.scale=list(), earg.q=list(),
init.scale = NULL, init.q = 1, zero = NULL)
}
%- maybe also 'usage' for other objects documented here.
@@ -18,6 +19,11 @@ lomax(link.scale = "loge", link.q = "loge",
See \code{\link{Links}} for more choices.
}
+ \item{earg.scale, earg.q}{
+ List. Extra argument for each of the links.
+ See \code{earg} in \code{\link{Links}} for general information.
+
+ }
\item{init.scale, init.q}{
Optional initial values for \code{scale} and \code{q}.
diff --git a/man/maxwell.Rd b/man/maxwell.Rd
index 4b883c0..6d2f50c 100644
--- a/man/maxwell.Rd
+++ b/man/maxwell.Rd
@@ -7,7 +7,7 @@
maximum likelihood estimation.
}
\usage{
-maxwell(link = "loge")
+maxwell(link = "loge", earg=list())
}
%- maybe also 'usage' for other objects documented here.
\arguments{
@@ -17,6 +17,11 @@ maxwell(link = "loge")
A log link is the default because the parameter is positive.
}
+ \item{earg}{
+ List. Extra argument for the link.
+ See \code{earg} in \code{\link{Links}} for general information.
+
+ }
}
\details{
The Maxwell distribution, which is used in the area of
diff --git a/man/micmen.Rd b/man/micmen.Rd
index 6ab9f25..7db602a 100644
--- a/man/micmen.Rd
+++ b/man/micmen.Rd
@@ -8,6 +8,7 @@
\usage{
micmen(rpar = 0.001, divisor = 10, init1 = NULL, init2 = NULL,
link1 = "identity", link2 = "identity",
+ earg1=list(), earg2=list(),
dispersion = 0, zero = NULL)
}
%- maybe also 'usage' for other objects documented here.
@@ -34,6 +35,11 @@ micmen(rpar = 0.001, divisor = 10, init1 = NULL, init2 = NULL,
See \code{\link{Links}} for more choices.
}
+ \item{earg1, earg2}{
+ List. Extra argument for each of the links.
+ See \code{earg} in \code{\link{Links}} for general information.
+
+ }
\item{dispersion}{
Numerical. Dispersion parameter.
diff --git a/man/mix2normal1.Rd b/man/mix2normal1.Rd
index 506876b..2134455 100644
--- a/man/mix2normal1.Rd
+++ b/man/mix2normal1.Rd
@@ -9,6 +9,7 @@
}
\usage{
mix2normal1(lphi="logit", lmu="identity", lsd="loge",
+ ephi=list(), emu1=list(), emu2=list(), esd1=list(), esd2=list(),
iphi=0.5, imu1=NULL, imu2=NULL, isd1=NULL, isd2=NULL,
qmu=c(0.2, 0.8), esd=FALSE, zero=1)
}
@@ -30,6 +31,12 @@ mix2normal1(lphi="logit", lmu="identity", lsd="loge",
See \code{\link{Links}} for more choices.
}
+ \item{ephi, emu1, emu2, esd1, esd2}{
+ List. Extra argument for each of the links.
+ See \code{earg} in \code{\link{Links}} for general information.
+ If \code{esd=TRUE} then \code{esd1} is used and not \code{esd2}.
+
+ }
\item{iphi}{
Initial value for \eqn{\phi}{phi}, whose value must lie
between 0 and 1.
@@ -116,6 +123,8 @@ London: Chapman & Hall.
\code{vcov} and \code{summary}) may be quite incorrect, especially when
the arguments \code{weights} is used to input prior weights.
+ This \pkg{VGAM} family function should be used with caution.
+
}
\author{ T. W. Yee }
diff --git a/man/mix2poisson.Rd b/man/mix2poisson.Rd
index 5c74ebf..271d219 100644
--- a/man/mix2poisson.Rd
+++ b/man/mix2poisson.Rd
@@ -9,6 +9,7 @@
}
\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)
}
@@ -25,6 +26,11 @@ mix2poisson(lphi = "logit", llambda = "loge",
See \code{\link{Links}} for more choices.
}
+ \item{ephi, el1, el2}{
+ List. Extra argument for each of the links.
+ See \code{earg} in \code{\link{Links}} for general information.
+
+ }
\item{iphi}{
Initial value for \eqn{\phi}{phi}, whose value must lie
between 0 and 1.
@@ -90,6 +96,8 @@ mix2poisson(lphi = "logit", llambda = "loge",
\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.
+
}
\author{ T. W. Yee }
diff --git a/man/morgenstern.Rd b/man/morgenstern.Rd
new file mode 100644
index 0000000..0d99be4
--- /dev/null
+++ b/man/morgenstern.Rd
@@ -0,0 +1,112 @@
+\name{morgenstern}
+\alias{morgenstern}
+%- Also NEED an '\alias' for EACH other topic documented here.
+\title{ Morgenstern's Bivariate Distribution Family Function }
+\description{
+ Estimate the association parameter of Morgenstern's bivariate
+ distribution using maximum likelihood estimation.
+
+}
+\usage{
+morgenstern(lapar="rhobit", earg=list(), iapar=NULL, tola0=0.01,
+ method.init=1)
+}
+%- maybe also 'usage' for other objects documented here.
+\arguments{
+ \item{lapar}{
+ Link function applied to the association parameter
+ \eqn{\alpha}{alpha}, which lies between \eqn{-1} and \eqn{1}.
+ See \code{\link{Links}} for more choices.
+
+ }
+ \item{earg}{
+ List. Extra argument for the link.
+ See \code{earg} in \code{\link{Links}} for general information.
+
+ }
+ \item{iapar}{
+ 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.
+ Assigning a value will override the argument \code{method.init}.
+
+ }
+ \item{tola0}{
+ Positive numeric.
+ If the estimate of \eqn{\alpha}{alpha} has an absolute
+ value less than this then it is replaced by this value.
+ This is an attempt to fix a numerical problem when the estimate
+ is too close to zero.
+
+ }
+ \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}.
+
+ }
+}
+\details{
+ The cumulative distribution function is
+ \deqn{P(Y_1 \leq y_1, Y_2 \leq y_2) = e^{-y_1-y_2}
+ ( 1 + \alpha [1 - e^{-y_1}] [1 - e^{-y_2}] ) + 1 -
+ e^{-y_1} - e^{-y_2} }{%
+ P(Y1 <= y1, Y2 <= y2) =
+ exp(-y1-y2) * ( 1 + alpha * [1 - exp(-y1)] * [1 - exp(-y2)] ) + 1 -
+ exp(-y1) - exp(-y2) }
+ for \eqn{\alpha}{alpha} between \eqn{-1} and \eqn{1}.
+ The support of the function is for \eqn{y_1>0}{y1>0} and
+ \eqn{y_2>0}{y2>0}.
+ The marginal distributions are an exponential distribution with
+ unit mean.
+ When \eqn{\alpha = 0}{alpha=0} then the random variables are
+ independent, and this causes some problems in the estimation
+ process since the distribution no longer depends on the
+ parameter.
+
+ A variant of Newton-Raphson is used, which only seems to work for an
+ intercept model.
+ It is a very good idea to set \code{trace=TRUE}.
+
+}
+\value{
+ An object of class \code{"vglmff"} (see \code{\link{vglmff-class}}).
+ The object is used by modelling functions such as \code{\link{vglm}}
+ and \code{\link{vgam}}.
+}
+
+\references{
+
+Castillo, E., Hadi, A. S., Balakrishnan, N. Sarabia, J. S. (2005)
+\emph{Extreme Value and Related Models with Applications in Engineering and Science},
+Hoboken, N.J.: Wiley-Interscience.
+
+}
+\author{ T. W. Yee }
+\note{
+ 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.
+
+ This \pkg{VGAM} family function should be used with caution.
+
+}
+
+\seealso{
+ \code{\link{fgm}},
+ \code{\link{gumbelIbiv}}.
+}
+\examples{
+n = 1000
+ymat = cbind(rexp(n), rexp(n))
+\dontrun{plot(ymat)}
+fit = vglm(ymat ~ 1, fam=morgenstern, trace=TRUE)
+fit = vglm(ymat ~ 1, fam=morgenstern, trace=TRUE, crit="coef")
+coef(fit, matrix=TRUE)
+Coef(fit)
+fitted(fit)[1:5,]
+}
+\keyword{models}
+\keyword{regression}
+
diff --git a/man/multinomial.Rd b/man/multinomial.Rd
index fdca22e..0bfaa07 100644
--- a/man/multinomial.Rd
+++ b/man/multinomial.Rd
@@ -122,6 +122,11 @@ contains further information and examples.
walking, etc. For other details about the \code{xij} argument see
\code{\link{vglm.control}} and \code{\link{fill}}.
+ The \code{\link[nnet]{multinom}} function in the \pkg{nnet} package
+ uses the first level of the factor as baseline, whereas the last
+ level of the factor is used here. Consequently the estimated
+ regression coefficients differ.
+
}
% In the future, this family function may be renamed to
diff --git a/man/nakagami.Rd b/man/nakagami.Rd
index 53c342b..101cf03 100644
--- a/man/nakagami.Rd
+++ b/man/nakagami.Rd
@@ -8,7 +8,8 @@
}
\usage{
-nakagami(lshape = "loge", lscale = "loge", ishape = NULL, iscale = 1)
+nakagami(lshape = "loge", lscale = "loge",
+ eshape=list(), escale=list(), ishape = NULL, iscale = 1)
}
%- maybe also 'usage' for other objects documented here.
\arguments{
@@ -19,6 +20,11 @@ nakagami(lshape = "loge", lscale = "loge", ishape = NULL, iscale = 1)
See \code{\link{Links}} for more choices.
}
+ \item{eshape, escale}{
+ List. Extra argument for each of the links.
+ See \code{earg} in \code{\link{Links}} for general information.
+
+ }
\item{ishape, iscale}{
Optional initial values for the shape and scale parameters.
For \code{ishape}, a \code{NULL} value means it is obtained in the
diff --git a/man/nbolf.Rd b/man/nbolf.Rd
index a48c27e..1593799 100644
--- a/man/nbolf.Rd
+++ b/man/nbolf.Rd
@@ -24,6 +24,7 @@ nbolf(theta, earg = stop("'earg' must be given"), inverse = FALSE,
and \code{k}. Here, \code{k} is the \eqn{k} parameter associated
with the negative binomial distribution; see
\code{\link{negbinomial}}.
+ The cutpoints should be non-negative integers.
If \code{nbolf()} is used as the link function in
\code{\link{cumulative}} then one should choose
\code{reverse=TRUE, parallel=TRUE, intercept.apply=TRUE}.
@@ -69,7 +70,7 @@ nbolf(theta, earg = stop("'earg' must be given"), inverse = FALSE,
}
\references{
Yee, T. W. (2006)
- \emph{Link functions for ordinal count data},
+ \emph{Ordinal ordination with normalizing link functions for count data},
(submitted for publication).
}
@@ -100,15 +101,16 @@ nbolf(theta, earg = stop("'earg' must be given"), inverse = FALSE,
\code{\link{negbinomial}},
\code{\link{polf}},
\code{\link{golf}},
+ \code{nbolf2},
\code{\link{cumulative}}.
}
\examples{
-nbolf("prob", short=FALSE)
-nbolf("prob", tag=TRUE)
+earg = list(cutpoint=2, k=1)
+nbolf("p", earg=earg, short=FALSE)
+nbolf("p", earg=earg, tag=TRUE)
p = seq(0.02, 0.98, by=0.01)
-earg = list(cutpoint=2, k=1)
y = nbolf(p, earg=earg)
y. = nbolf(p, earg=earg, deriv=1)
max(abs(nbolf(y, earg=earg, inv=TRUE) - p)) # Should be 0
diff --git a/man/negbinomial.Rd b/man/negbinomial.Rd
index 98a5533..a2493b2 100644
--- a/man/negbinomial.Rd
+++ b/man/negbinomial.Rd
@@ -8,6 +8,7 @@
}
\usage{
negbinomial(lmu = "loge", lk = "loge",
+ emu =list(), ek=list(),
ik = NULL, cutoff = 0.995, Maxiter=5000,
deviance.arg = FALSE, method.init=1, zero = -2)
}
@@ -18,6 +19,11 @@ negbinomial(lmu = "loge", lk = "loge",
See \code{\link{Links}} for more choices.
}
+ \item{emu, ek}{
+ List. Extra argument for each of the links.
+ See \code{earg} in \code{\link{Links}} for general information.
+
+ }
\item{ik}{
Optional initial values for \eqn{k}.
If failure to converge occurs try different values (and/or use
diff --git a/man/normal1.Rd b/man/normal1.Rd
index 964e172..629f475 100644
--- a/man/normal1.Rd
+++ b/man/normal1.Rd
@@ -8,7 +8,8 @@
}
\usage{
-normal1(lmean="identity", lsd="loge", zero=NULL)
+normal1(lmean="identity", lsd="loge",
+ emean=list(), esd=list(), zero=NULL)
}
%- maybe also 'usage' for other objects documented here.
\arguments{
@@ -23,6 +24,11 @@ normal1(lmean="identity", lsd="loge", zero=NULL)
Being a positive quantity, a log link is the default.
}
+ \item{emean, esd}{
+ List. Extra argument for the links.
+ See \code{earg} in \code{\link{Links}} for general information.
+
+ }
\item{zero}{
An integer vector, containing the value 1 or 2. If so, the mean or
standard deviation respectively are modelled as an intercept only.
diff --git a/man/notdocumentedyet.Rd b/man/notdocumentedyet.Rd
index 5d9041e..025b381 100644
--- a/man/notdocumentedyet.Rd
+++ b/man/notdocumentedyet.Rd
@@ -93,8 +93,8 @@
\alias{dimm}
% \alias{dneg.binomial}
\alias{dnorm2}
-% \alias{dotC}
-% \alias{dotFortran}
+\alias{dotC}
+\alias{dotFortran}
% \alias{dpsi.dlambda.yjn}
% \alias{drop1.vgam}
% \alias{drop1.vglm}
@@ -117,7 +117,6 @@
\alias{fitted.values}
\alias{fitted.values.uqo}
\alias{fittedvsmooth.spline}
-\alias{fsqrt}
\alias{gammaff}
% \alias{get.arg}
% \alias{get.rrvglm.se1}
@@ -133,8 +132,8 @@
% \alias{gleg.weight.yjn.12}
% \alias{gleg.weight.yjn.13}
\alias{glm}
-\alias{hyper.secant}
-% \alias{hyper.secant.1}
+% \alias{hypersecant}
+% \alias{hypersecant.1}
% \alias{ima}
% \alias{interleave.VGAM}
\alias{invbinomial}
@@ -163,7 +162,7 @@
\alias{m2adefault}
\alias{m2avglm}
% \alias{matrix.power}
-% \alias{mbesselI0}
+\alias{mbesselI0}
\alias{model.matrix.qrrvglm}
% \alias{mux11}
% \alias{mux111}
@@ -184,6 +183,7 @@
% \alias{negbin.ab}
% \alias{new.assign}
\alias{nlminbcontrol}
+\alias{nbolf2}
\alias{ns}
% \alias{num.deriv.rrr}
\alias{persp}
@@ -196,7 +196,6 @@
\alias{pnorm2}
% \alias{poissonqn}
\alias{poly}
-\alias{powl}
\alias{predict}
\alias{predict.cao}
\alias{predict.glm}
@@ -375,6 +374,8 @@
\alias{vlmsmall-class}
\alias{vsmooth.spline-class}
\alias{vsmooth.spline.fit-class}
+\alias{Coef.cao-class}
+\alias{summary.cao-class}
%
%
%- Also NEED an '\alias' for EACH other topic documented here.
diff --git a/man/ordpoisson.Rd b/man/ordpoisson.Rd
new file mode 100644
index 0000000..f2199cd
--- /dev/null
+++ b/man/ordpoisson.Rd
@@ -0,0 +1,158 @@
+\name{ordpoisson}
+\alias{ordpoisson}
+%- Also NEED an '\alias' for EACH other topic documented here.
+\title{ Ordinal Poisson Family Function }
+\description{
+ Fits a Poisson regression where the response is ordinal
+ (the Poisson counts are grouped between known cutpoints).
+
+}
+\usage{
+ordpoisson(cutpoints, countdata=FALSE, NOS=NULL,
+ Levels=NULL, init.mu=NULL, parallel=FALSE,
+ zero=NULL, link="loge", earg = list())
+}
+%- maybe also 'usage' for other objects documented here.
+\arguments{
+ \item{cutpoints}{
+ Numeric. The cutpoints, \eqn{K_l}.
+ These must be non-negative integers.
+ \code{Inf} values may be included.
+ See below for further details.
+
+ }
+ \item{countdata}{
+ Logical. Is the response (LHS of formula) in count-data format?
+ If not then the response is a matrix or vector with values \code{1},
+ \code{2}, \ldots, \code{L}, say, where \code{L} is the number of
+ levels. Such input can be generated with \code{\link[base]{cut}}
+ with argument \code{labels = FALSE}. If \code{countdata = TRUE} then
+ the response is expected to be in the same format as \code{fit at y}
+ where \code{fit} is a fitted model with \code{ordpoisson} as the
+ \pkg{VGAM} family function. That is, the response is matrix of counts
+ with \code{L} columns (if \code{NOS=1}).
+
+ }
+ \item{NOS}{
+ Integer. The number of species, or more generally, the number of
+ response random variates.
+ This argument must be specified when \code{countdata=TRUE}.
+ Usually \code{NOS=1}.
+
+ }
+ \item{Levels}{
+ Integer vector, recycled to length \code{NOS} if necessary.
+ The number of levels for each response random variate.
+ This argument should agree with \code{cutpoints}.
+ This argument must be specified when \code{countdata=TRUE}.
+
+ }
+ \item{init.mu}{
+ Numeric. Initial values for the means of the Poisson regressions.
+ Recycled to length \code{NOS} if necessary.
+ Use this argument if the default initial values fail (the
+ default is to compute an initial value internally).
+
+ }
+ \item{parallel, zero, link, earg}{
+ See \code{\link{poissonff}}.
+
+ }
+
+}
+\details{
+ This \pkg{VGAM} family function uses maximum likelihood estimation
+ (Fisher scoring)
+ to fit a Poisson regression to each column of a matrix response.
+ The data, however, is ordinal, and is obtained from known integer
+ cutpoints.
+ Here, \eqn{l=1,\ldots,L} where \eqn{L} (\eqn{L \geq 2}{L >= 2})
+ is the number of levels.
+ In more detail, let
+ \eqn{Y^*=l} if \eqn{K_{l-1} < Y \leq K_{l}}{K_{l-1} < Y
+ <= K_{l}} where the \eqn{K_l} are the cutpoints.
+ We have \eqn{K_0=-\infty}{K_0=-Inf} and \eqn{K_L=\infty}{K_L=Inf}.
+ The response for this family function corresponds to \eqn{Y^*} but
+ we are really interested in the Poisson regression of \eqn{Y}.
+
+ If \code{NOS=1} then
+ the argument \code{cutpoints} is a vector \eqn{(K_1,K_2,\ldots,K_L)}
+ where the last value (\code{Inf}) is optional. If \code{NOS>1} then
+ the vector should have \code{NOS-1} \code{Inf} values separating
+ the cutpoints. For example, if there are \code{NOS=3} responses, then
+ something like
+ \code{ordpoisson(cut = c(0, 5, 10, Inf, 20, 30, Inf, 0, 10, 40, Inf))}
+ is valid.
+
+}
+\value{
+ An object of class \code{"vglmff"} (see \code{\link{vglmff-class}}).
+ The object is used by modelling functions such as \code{\link{vglm}}
+ and \code{\link{vgam}}.
+
+}
+\references{
+ Yee, T. W. (2006)
+ \emph{Ordinal ordination with normalizing link functions for count data},
+ (submitted for publication).
+
+}
+\author{ Thomas W. Yee }
+
+\note{
+ Sometimes there are no observations between two cutpoints. If so,
+ the arguments \code{Levels} and \code{NOS} need to be specified too.
+ See below for an example.
+
+}
+\section{Warning }{
+ The input requires care as little to no checking is done.
+ If \code{fit} is the fitted object, have a look at \code{fit at extra} and
+ \code{fit at y} to check.
+
+}
+
+\seealso{
+ \code{\link{poissonff}},
+ \code{\link{polf}}.
+
+}
+\examples{
+# Example 1
+set.seed(123)
+x2 = runif(n <- 1000); x3 = runif(n)
+mymu = exp(3 - 1 * x2 + 2 * x3)
+y1 = rpois(n, lambda=mymu)
+cutpts = c(-Inf, 20, 30, Inf)
+fcutpts = cutpts[is.finite(cutpts)] # finite cutpoints
+ystar = cut(y1, breaks=cutpts, labels=FALSE)
+\dontrun{
+plot(x2, x3, col=ystar, pch=as.character(ystar))
+}
+table(ystar) / sum(table(ystar))
+fit = vglm(ystar ~ x2 + x3, fam = ordpoisson(cutpoi=fcutpts))
+fit at y[1:5,] # This can be input if countdata=TRUE
+fitted(fit)[1:5,]
+predict(fit)[1:5,]
+coef(fit, matrix=TRUE)
+fit at extra
+
+# Example 2: multivariate and there are no obsns between some cutpoints
+cutpts2 = c(-Inf, 0, 9, 10, 20, 70, 200, 201, Inf)
+fcutpts2 = cutpts2[is.finite(cutpts2)] # finite cutpoints
+y2 = rpois(n, lambda=mymu) # Same model as y1
+ystar2 = cut(y2, breaks=cutpts2, labels=FALSE)
+table(ystar2) / sum(table(ystar2))
+fit = vglm(cbind(ystar,ystar2) ~ x2 + x3, fam =
+ ordpoisson(cutpoi=c(fcutpts,Inf,fcutpts2,Inf),
+ Levels=c(length(fcutpts)+1,length(fcutpts2)+1),
+ parallel=TRUE), trace=TRUE)
+coef(fit, matrix=TRUE)
+fit at extra
+constraints(fit)
+summary(fit at y) # Some columns have all zeros
+}
+\keyword{math}
+\keyword{models}
+\keyword{regression}
+
diff --git a/man/paralogistic.Rd b/man/paralogistic.Rd
index 3a11db1..5922aa1 100644
--- a/man/paralogistic.Rd
+++ b/man/paralogistic.Rd
@@ -8,6 +8,7 @@
}
\usage{
paralogistic(link.a = "loge", link.scale = "loge",
+ earg.a=list(), earg.scale=list(),
init.a = 1, init.scale = NULL, zero = NULL)
}
%- maybe also 'usage' for other objects documented here.
@@ -19,6 +20,11 @@ paralogistic(link.a = "loge", link.scale = "loge",
See \code{\link{Links}} for more choices.
}
+ \item{earg.a, earg.scale}{
+ List. Extra argument for each of the links.
+ See \code{earg} in \code{\link{Links}} for general information.
+
+ }
\item{init.a, init.scale}{
Optional initial values for \code{a} and \code{scale}.
diff --git a/man/pareto1.Rd b/man/pareto1.Rd
index cc1a149..38fe355 100644
--- a/man/pareto1.Rd
+++ b/man/pareto1.Rd
@@ -10,8 +10,8 @@
}
\usage{
-pareto1(lshape = "loge", location=NULL)
-tpareto1(lower, upper, lshape = "loge", ishape=NULL)
+pareto1(lshape = "loge", earg=list(), location=NULL)
+tpareto1(lower, upper, lshape = "loge", earg=list(), ishape=NULL)
}
%- maybe also 'usage' for other objects documented here.
\arguments{
@@ -21,6 +21,11 @@ tpareto1(lower, upper, lshape = "loge", ishape=NULL)
A log link is the default because \eqn{k} is positive.
}
+ \item{earg}{
+ List. Extra argument for the link.
+ See \code{earg} in \code{\link{Links}} for general information.
+
+ }
\item{lower, upper}{
Numeric.
Lower and upper limits for the truncated Pareto distribution.
diff --git a/man/paretoIV.Rd b/man/paretoIV.Rd
index 9771259..6c76ef7 100644
--- a/man/paretoIV.Rd
+++ b/man/paretoIV.Rd
@@ -12,10 +12,13 @@
}
\usage{
paretoIV(location=0, lscale="loge", linequality="loge", lshape="loge",
+ escale=list(), einequality=list(), eshape=list(),
iscale=1, iinequality=1, ishape=NULL, method.init=1)
paretoIII(location=0, lscale="loge", linequality="loge",
+ escale=list(), einequality=list(),
iscale=NULL, iinequality=NULL)
paretoII(location=0, lscale="loge", lshape="loge",
+ escale=list(), eshape=list(),
iscale=NULL, ishape=NULL)
}
%- maybe also 'usage' for other objects documented here.
@@ -35,6 +38,11 @@ paretoII(location=0, lscale="loge", lshape="loge",
positive.
}
+ \item{escale, einequality, eshape}{
+ List. Extra argument for each of the links.
+ See \code{earg} in \code{\link{Links}} for general information.
+
+ }
\item{iscale, iinequality, ishape}{
Initial values for the parameters.
A \code{NULL} value means that it is obtained internally.
diff --git a/man/poissonff.Rd b/man/poissonff.Rd
index f2c4231..8783fe2 100644
--- a/man/poissonff.Rd
+++ b/man/poissonff.Rd
@@ -10,13 +10,19 @@
}
\usage{
-poissonff(link = "loge", dispersion = 1,
+poissonff(link = "loge", earg=list(), dispersion = 1,
onedpar = FALSE, parallel = FALSE, zero = NULL)
}
%- maybe also 'usage' for other objects documented here.
\arguments{
\item{link}{
- Link function. See \code{\link{Links}} for more choices.
+ Link function applied to the mean or means.
+ See \code{\link{Links}} for more choices.
+
+ }
+ \item{earg}{
+ Extra argument optionally used by the link function.
+ See \code{\link{Links}} for more information.
}
\item{dispersion}{
@@ -109,6 +115,7 @@ poissonff(link = "loge", dispersion = 1,
\code{\link{Links}},
\code{\link{quasipoissonff}},
\code{\link{zipoisson}},
+ \code{\link{ordpoisson}},
\code{\link{loge}},
\code{\link{polf}},
\code{\link{rrvglm}},
diff --git a/man/polf.Rd b/man/polf.Rd
index 0b0f414..e8d232a 100644
--- a/man/polf.Rd
+++ b/man/polf.Rd
@@ -21,6 +21,7 @@ polf(theta, earg = stop("'earg' must be given"), inverse = FALSE,
\item{earg}{
Extra argument for passing in additional information.
This must be list with component \code{cutpoint}.
+ The cutpoints should be non-negative integers.
If \code{polf()} is used as the link function in
\code{\link{cumulative}} then one should choose
\code{reverse=TRUE, parallel=TRUE, intercept.apply=TRUE}.
@@ -51,6 +52,7 @@ polf(theta, earg = stop("'earg' must be given"), inverse = FALSE,
parameter lying in the unit interval.
Its purpose is to link cumulative probabilities associated with
an ordinal response coming from an underlying Poisson distribution.
+ If the cutpoint is zero then a complementary log-log link is used.
The arguments \code{short} and \code{tag} are used only if
\code{theta} is character.
@@ -65,7 +67,7 @@ polf(theta, earg = stop("'earg' must be given"), inverse = FALSE,
}
\references{
Yee, T. W. (2006)
- \emph{Link functions for ordinal count data},
+ \emph{Ordinal ordination with normalizing link functions for count data},
(submitted for publication).
}
@@ -93,17 +95,18 @@ polf(theta, earg = stop("'earg' must be given"), inverse = FALSE,
\seealso{
\code{\link{Links}},
+ \code{\link{ordpoisson}},
\code{\link{poissonff}},
\code{\link{nbolf}},
\code{\link{golf}},
\code{\link{cumulative}}.
}
\examples{
-polf("prob", short=FALSE)
-polf("prob", tag=TRUE)
+earg = list(cutpoint=2)
+polf("p", earg=earg, short=FALSE)
+polf("p", earg=earg, tag=TRUE)
p = seq(0.01, 0.99, by=0.01)
-earg = list(cutpoint=2)
y = polf(p, earg=earg)
y. = polf(p, earg=earg, deriv=1)
max(abs(polf(y, earg=earg, inv=TRUE) - p)) # Should be 0
diff --git a/man/posbinomUC.Rd b/man/posbinomUC.Rd
index 69217a0..2cb5513 100644
--- a/man/posbinomUC.Rd
+++ b/man/posbinomUC.Rd
@@ -87,7 +87,7 @@ round(dposbinom(1:10, size, prob) * 1000) # Should be similar
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 & shifted slightly)", sep=""),
+ " 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")
}
diff --git a/man/posbinomial.Rd b/man/posbinomial.Rd
index 4456e9b..053b1a2 100644
--- a/man/posbinomial.Rd
+++ b/man/posbinomial.Rd
@@ -6,7 +6,7 @@
Fits a positive binomial distribution.
}
\usage{
-posbinomial(link = "logit")
+posbinomial(link = "logit", earg=list())
}
%- maybe also 'usage' for other objects documented here.
\arguments{
@@ -15,6 +15,11 @@ posbinomial(link = "logit")
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.
+
+ }
}
\details{
The positive binomial distribution is the ordinary binomial distribution
diff --git a/man/posnegbinomial.Rd b/man/posnegbinomial.Rd
index daf5047..c185169 100644
--- a/man/posnegbinomial.Rd
+++ b/man/posnegbinomial.Rd
@@ -8,7 +8,8 @@
}
\usage{
-posnegbinomial(lmunb = "loge", lk = "loge", ik = NULL,
+posnegbinomial(lmunb = "loge", lk = "loge",
+ emunb =list(), ek = list(), ik = NULL,
zero = -2, cutoff = 0.995, method.init=1)
}
%- maybe also 'usage' for other objects documented here.
@@ -25,6 +26,11 @@ posnegbinomial(lmunb = "loge", lk = "loge", ik = NULL,
See \code{\link{Links}} for more choices.
}
+ \item{emunb, ek}{
+ List. Extra argument for the respective links.
+ See \code{earg} in \code{\link{Links}} for general information.
+
+ }
\item{ik}{
Optional initial value for \code{k}, an index parameter.
The value \code{1/k} is known as a dispersion parameter.
diff --git a/man/posnormal1.Rd b/man/posnormal1.Rd
index 4b289d6..0be9946 100644
--- a/man/posnormal1.Rd
+++ b/man/posnormal1.Rd
@@ -7,6 +7,7 @@
}
\usage{
posnormal1(lmean="identity", lsd="loge",
+ emean=list(), esd=list(),
imean=NULL, isd=NULL, zero=NULL)
}
%- maybe also 'usage' for other objects documented here.
@@ -18,6 +19,11 @@ posnormal1(lmean="identity", lsd="loge",
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.
diff --git a/man/pospoisUC.Rd b/man/pospoisUC.Rd
index cba8c51..694c7e7 100644
--- a/man/pospoisUC.Rd
+++ b/man/pospoisUC.Rd
@@ -83,7 +83,7 @@ round(dpospois(1:10, lambda) * 1000) # Should be similar
x = 0:7
plot(x, dpospois(x, lambda), type="h", ylab="Probability",
main=paste("Positive Poisson(", lambda, ") (blue) vs",
- " Poisson(", lambda, ") (red & shifted slightly)", sep=""),
+ " 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")
}
diff --git a/man/pospoisson.Rd b/man/pospoisson.Rd
index 9b06334..74758e3 100644
--- a/man/pospoisson.Rd
+++ b/man/pospoisson.Rd
@@ -6,7 +6,7 @@
Fits a positive Poisson distribution.
}
\usage{
-pospoisson(link = "loge")
+pospoisson(link = "loge", earg=list())
}
%- maybe also 'usage' for other objects documented here.
\arguments{
@@ -16,6 +16,11 @@ pospoisson(link = "loge")
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.
+
+ }
}
\details{
The positive Poisson distribution is the ordinary Poisson
diff --git a/man/powl.Rd b/man/powl.Rd
new file mode 100644
index 0000000..fcb07c0
--- /dev/null
+++ b/man/powl.Rd
@@ -0,0 +1,112 @@
+\name{powl}
+\alias{powl}
+%- Also NEED an '\alias' for EACH other topic documented here.
+\title{ Power Link Function }
+\description{
+ Computes the power transformation, including its inverse and the
+ first two derivatives.
+
+}
+\usage{
+powl(theta, earg = list(power=1), inverse = FALSE, deriv = 0,
+ short = TRUE, tag = FALSE)
+}
+%- maybe also 'usage' for other objects documented here.
+\arguments{
+ \item{theta}{
+ Numeric or character.
+ See below for further details.
+
+ }
+ \item{earg}{
+ List. Extra argument for passing in additional information.
+ Here, the component name \code{power} denotes the power or exponent.
+ This component name should not be abbreviated.
+
+ }
+ \item{inverse}{
+ Logical. If \code{TRUE} the inverse function is computed.
+
+ }
+ \item{deriv}{
+ Order of the derivative. Integer with value 0, 1 or 2.
+
+ }
+ \item{short}{
+ Used for labelling the \code{blurb} slot of a
+ \code{\link{vglmff-class}} object.
+
+ }
+ \item{tag}{
+ Used for labelling the linear/additive predictor in the
+ \code{initialize} slot of a \code{\link{vglmff-class}} object.
+ Contains a little more information if \code{TRUE}.
+
+ }
+}
+\details{
+ The power link function raises a parameter by a certain value of
+ \code{power}.
+ Care is needed because it is very easy to get numerical
+ problems, e.g., if \code{power=0.5} and \code{theta} is
+ negative.
+
+ The arguments \code{short} and \code{tag} are used only if
+ \code{theta} is character.
+
+}
+\value{
+ For \code{powl} with \code{deriv = 0}, then \code{theta} raised
+ to the power of \code{power}.
+ And if \code{inverse = TRUE} then
+ \code{theta} raised to the power of \code{1/power}.
+
+ For \code{deriv = 1}, then the function returns
+ \emph{d} \code{theta} / \emph{d} \code{eta} as a function of \code{theta}
+ if \code{inverse = FALSE},
+ else if \code{inverse = TRUE} then it returns the reciprocal.
+
+}
+%\references{
+% McCullagh, P. and Nelder, J. A. (1989)
+% \emph{Generalized Linear Models}, 2nd ed. London: Chapman & Hall.
+%
+%}
+\author{ Thomas W. Yee }
+
+\note{
+ Numerical problems may occur for certain combinations of
+ \code{theta} and \code{power}.
+ Consequently this link function should be used with caution.
+
+}
+
+\seealso{
+ \code{\link{Links}},
+ \code{\link{loge}}.
+}
+\examples{
+powl("a", earg=list(power=2), short=FALSE, tag=TRUE)
+
+x = 1:5
+powl(x)
+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
+
+# 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)
+Coef(fit) # Useful for intercept-only models
+vcov(fit, untrans=TRUE)
+}
+\keyword{math}
+\keyword{models}
+\keyword{regression}
+
diff --git a/man/prentice74.Rd b/man/prentice74.Rd
index af36476..834552a 100644
--- a/man/prentice74.Rd
+++ b/man/prentice74.Rd
@@ -8,6 +8,7 @@
}
\usage{
prentice74(llocation="identity", lscale="loge", lshape="identity",
+ elocation=list(), escale=list(), eshape=list(),
ilocation=NULL, iscale=NULL, ishape=NULL, zero=NULL)
}
%- maybe also 'usage' for other objects documented here.
@@ -30,6 +31,11 @@ prentice74(llocation="identity", lscale="loge", lshape="identity",
See \code{\link{Links}} for more choices.
}
+ \item{elocation, escale, eshape}{
+ List. Extra argument for each of the links.
+ See \code{earg} in \code{\link{Links}} for general information.
+
+ }
\item{ilocation, iscale}{
Initial value for \eqn{a} and \eqn{b}, respectively.
The defaults mean an initial value is determined internally for each.
diff --git a/man/rayleigh.Rd b/man/rayleigh.Rd
index 2e792d6..0cda1a7 100644
--- a/man/rayleigh.Rd
+++ b/man/rayleigh.Rd
@@ -9,8 +9,8 @@
}
\usage{
-rayleigh(link = "loge")
-crayleigh(link ="loge", expected=FALSE)
+rayleigh(link = "loge", earg=list())
+crayleigh(link ="loge", earg=list(), expected=FALSE)
}
%- maybe also 'usage' for other objects documented here.
\arguments{
@@ -20,6 +20,11 @@ crayleigh(link ="loge", expected=FALSE)
A log link is the default because \eqn{a} is positive.
}
+ \item{earg}{
+ List. Extra argument for the link.
+ See \code{earg} in \code{\link{Links}} for general information.
+
+ }
\item{expected}{
Logical. For censored data only, \code{FALSE}
means the Newton-Raphson algorithm, and \code{TRUE} means Fisher scoring.
diff --git a/man/rcqo.Rd b/man/rcqo.Rd
index dcb944d..a362395 100644
--- a/man/rcqo.Rd
+++ b/man/rcqo.Rd
@@ -187,10 +187,13 @@ rcqo(n, p, S, Rank = 1,
}
\item{seed}{
- Optionally, a single value, interpreted as an integer.
If given, it is passed into \code{\link[base:Random]{set.seed}}.
This argument can be used to obtain reproducible results.
-
+ If set, the value is saved as the \code{"seed"}
+ attribute of the returned value. The default will
+ not change the random generator state, and return
+ \code{\link[base:Random]{.Random.seed}} as \code{"seed"} attribute.
+
}
\item{Crow1positive}{
See \code{\link{qrrvglm.control}} for details.
@@ -288,7 +291,7 @@ rcqo(n, p, S, Rank = 1,
\code{"family"}, \code{"Rank"},
\code{"loabundance"}, \code{"hiabundance"},
\code{"EqualTolerances"}, \code{"EqualMaxima"},
- \code{"seed"}, as inputted.
+ \code{"seed"} as used.
}
\references{
diff --git a/man/reciprocal.Rd b/man/reciprocal.Rd
index 494e7c0..2163829 100644
--- a/man/reciprocal.Rd
+++ b/man/reciprocal.Rd
@@ -85,8 +85,8 @@ close to 0.
\seealso{
\code{\link{identity}},
- \code{powl}.
- }
+ \code{\link{powl}}.
+}
\examples{
reciprocal(1:5)
reciprocal(1:5, inverse=TRUE, deriv=2)
diff --git a/man/rig.Rd b/man/rig.Rd
index 20a632a..2141148 100644
--- a/man/rig.Rd
+++ b/man/rig.Rd
@@ -8,7 +8,8 @@
}
\usage{
-rig(lmu = "identity", llambda = "loge", imu = NULL, ilambda = 1)
+rig(lmu = "identity", llambda = "loge",
+ emu=list(), elambda=list(), imu = NULL, ilambda = 1)
}
%- maybe also 'usage' for other objects documented here.
\arguments{
@@ -22,6 +23,11 @@ rig(lmu = "identity", llambda = "loge", imu = NULL, ilambda = 1)
A \code{NULL} means a value is computed internally.
}
+ \item{emu, elambda}{
+ List. Extra argument for each of the links.
+ See \code{earg} in \code{\link{Links}} for general information.
+
+ }
}
\details{
See Jorgensen (1997) for details.
diff --git a/man/ruge.Rd b/man/ruge.Rd
new file mode 100644
index 0000000..2854a2d
--- /dev/null
+++ b/man/ruge.Rd
@@ -0,0 +1,42 @@
+\name{ruge}
+\alias{ruge}
+\non_function{}
+\title{Rutherford-Geiger polonium data}
+\usage{data(ruge)}
+\description{
+ Decay counts of polonium recorded by Rutherford and Geiger (1910).
+
+}
+\format{
+ This data frame contains the following columns:
+ \describe{
+ \item{counts}{a numeric vector, counts or frequencies}
+ \item{number}{a numeric vector, the number of decays}
+ }
+}
+\details{
+ These are the radioactive decay counts of polonium recorded by
+ Rutherford and Geiger (1910) representing the number of scintillations
+ in 2608 1/8 minute intervals. For example, there were 57 frequencies
+ of zero counts.
+ The counts can be thought of as being approximately Poisson distributed.
+
+}
+\source{
+ Rutherford, E. and Geiger, H. (1910)
+ The Probability Variations in the Distribution of alpha Particles,
+ \emph{Philosophical Magazine},
+ \bold{20}, 698--704.
+
+}
+%\references{
+%}
+\examples{
+data(ruge)
+attach(ruge)
+lambdahat = weighted.mean(number, w=counts)
+(N = sum(counts))
+cbind(number, counts, fitted=round(N * dpois(number, lam=lambdahat)))
+detach(ruge)
+}
+\keyword{datasets}
diff --git a/man/s.Rd b/man/s.Rd
index 4e3fa46..9a02744 100644
--- a/man/s.Rd
+++ b/man/s.Rd
@@ -26,6 +26,8 @@ s(x, df = 4, spar = 0, ...)
numerical vector of length \eqn{r}.
Effective degrees of freedom: must lie between 1 (linear fit)
and \eqn{n} (interpolation).
+ Thus one could say that \code{df-1} is the
+ \emph{nonlinear degrees of freedom} of the smooth.
Recycling of values will be used if \code{df} is not of length \eqn{r}.
}
diff --git a/man/simplex.Rd b/man/simplex.Rd
index 40cd850..e785e28 100644
--- a/man/simplex.Rd
+++ b/man/simplex.Rd
@@ -6,7 +6,9 @@
The two parameters of the univariate simplex distribution are estimated.
}
\usage{
-simplex(lmu = "logit", lsigma = "loge", imu = NULL, isigma = NULL)
+simplex(lmu = "logit", lsigma = "loge",
+ emu=list(), esigma=list(),
+ imu = NULL, isigma = NULL)
}
%- maybe also 'usage' for other objects documented here.
\arguments{
@@ -22,6 +24,11 @@ simplex(lmu = "logit", lsigma = "loge", imu = NULL, isigma = NULL)
The parameter is positive, therefore the log link is the default.
}
+ \item{emu, esigma}{
+ List. Extra argument for each of the links.
+ See \code{earg} in \code{\link{Links}} for general information.
+
+ }
\item{imu, isigma}{
Optional initial values for \code{mu} and \code{sigma}.
A \code{NULL} means a value is obtained internally.
diff --git a/man/sinmad.Rd b/man/sinmad.Rd
index 9d147e5..58a765b 100644
--- a/man/sinmad.Rd
+++ b/man/sinmad.Rd
@@ -8,6 +8,7 @@
}
\usage{
sinmad(link.a = "loge", link.scale = "loge", link.q = "loge",
+ earg.a=list(), earg.scale=list(), earg.q=list(),
init.a = NULL, init.scale = NULL, init.q = 1, zero = NULL)
}
%- maybe also 'usage' for other objects documented here.
@@ -18,6 +19,11 @@ sinmad(link.a = "loge", link.scale = "loge", link.q = "loge",
See \code{\link{Links}} for more choices.
}
+ \item{earg.a, earg.scale, earg.q}{
+ List. Extra argument for each of the links.
+ See \code{earg} in \code{\link{Links}} for general information.
+
+ }
\item{init.a, init.scale, init.q}{
Optional initial values for \code{a}, \code{scale}, and \code{q}.
diff --git a/man/skewnormal1.Rd b/man/skewnormal1.Rd
index e98a103..2f16bae 100644
--- a/man/skewnormal1.Rd
+++ b/man/skewnormal1.Rd
@@ -8,7 +8,7 @@
}
\usage{
-skewnormal1(lshape = "identity", ishape = NULL)
+skewnormal1(lshape = "identity", earg = list(), ishape = NULL)
}
%- maybe also 'usage' for other objects documented here.
\arguments{
@@ -17,6 +17,11 @@ skewnormal1(lshape = "identity", ishape = NULL)
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{ishape}{
Optional inital value for the shape parameter.
The default is to choose one internally.
diff --git a/man/sratio.Rd b/man/sratio.Rd
index 7c9975b..b8ab19b 100644
--- a/man/sratio.Rd
+++ b/man/sratio.Rd
@@ -7,7 +7,8 @@
regression model to an ordered (preferably) factor response.
}
\usage{
-sratio(link = "logit", parallel = FALSE, reverse = FALSE, zero = NULL)
+sratio(link = "logit", earg = list(),
+ parallel = FALSE, reverse = FALSE, zero = NULL)
}
%- maybe also 'usage' for other objects documented here.
\arguments{
@@ -22,6 +23,11 @@ sratio(link = "logit", parallel = FALSE, reverse = FALSE, zero = NULL)
See \code{\link{Links}} for more choices.
}
+ \item{earg}{
+ List. Extra argument for the link function.
+ See \code{earg} in \code{\link{Links}} for general information.
+
+ }
\item{parallel}{
A logical, or formula specifying which terms have
equal/unequal coefficients.
diff --git a/man/studentt.Rd b/man/studentt.Rd
index 8874460..f6e94e0 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")
+studentt(link.df = "loglog", earg=list())
}
%- maybe also 'usage' for other objects documented here.
\arguments{
@@ -16,6 +16,11 @@ studentt(link.df = "loglog")
The default ensures the parameter is greater than unity.
}
+ \item{earg}{
+ List. Extra argument for the link.
+ See \code{earg} in \code{\link{Links}} for general information.
+
+ }
}
\details{
The density function is
@@ -65,8 +70,8 @@ The probable error of a mean.
}
\examples{
-n = 200
-y = rt(n, df=exp(2))
+n = 500
+y = rt(n, df=exp(exp(1)))
fit = vglm(y ~ 1, studentt)
coef(fit, matrix=TRUE)
Coef(fit)
diff --git a/man/tikuv.Rd b/man/tikuv.Rd
index b882cd9..937371e 100644
--- a/man/tikuv.Rd
+++ b/man/tikuv.Rd
@@ -7,7 +7,9 @@
}
\usage{
-tikuv(d, lmean="identity", lsigma="loge", isigma=NULL, zero=2)
+tikuv(d, lmean="identity", lsigma="loge",
+ emean=list(), esigma=list(),
+ isigma=NULL, zero=2)
}
%- maybe also 'usage' for other objects documented here.
\arguments{
@@ -24,6 +26,11 @@ tikuv(d, lmean="identity", lsigma="loge", isigma=NULL, zero=2)
See \code{\link{Links}} for more choices.
}
+ \item{emean, esigma}{
+ List. Extra argument for each of the links.
+ See \code{earg} in \code{\link{Links}} for general information.
+
+ }
\item{isigma}{
Optional initial value for \eqn{\sigma}{sigma}.
A \code{NULL} means a value is computed internally.
diff --git a/man/tobit.Rd b/man/tobit.Rd
index d08890b..6314aed 100644
--- a/man/tobit.Rd
+++ b/man/tobit.Rd
@@ -7,7 +7,7 @@
}
\usage{
tobit(Lower = 0, Upper = Inf, lmu="identity", lsd="loge",
- imethod=1, zero=2)
+ emu=list(), esd=list(), imethod=1, zero=2)
}
%- maybe also 'usage' for other objects documented here.
\arguments{
@@ -35,6 +35,11 @@ tobit(Lower = 0, Upper = Inf, lmu="identity", lsd="loge",
is its default.
}
+ \item{emu, esd}{
+ List. Extra argument for each of the links.
+ See \code{earg} in \code{\link{Links}} for general information.
+
+ }
\item{imethod}{
Initialization method. Either 1 or 2, this specifies
two methods for obtaining initial values for the parameters.
@@ -102,7 +107,7 @@ Estimation of relationships for limited dependent variables.
\code{\link{cnormal1}}.
\code{\link{dcnormal1}}.
}
-\examples{\dontrun{
+\examples{
n = 1000
x = seq(-1, 1, len=n)
f = function(x) 1 + 4*x
@@ -111,16 +116,17 @@ Lower = 1
Upper = 4
y = pmax(ystar, Lower)
y = pmin(y, Upper)
-plot(x, y, main="Tobit model", las=1)
-legend(-0.9, 3, c("Truth", "Estimate"), col=c("Blue", "Red"), lwd=2)
table(y==Lower | y==Upper) # How many censored values?
fit = vglm(y ~ x, tobit(Lower=Lower, Upper=Upper), trace=TRUE)
table(fit at extra$censoredL)
table(fit at extra$censoredU)
coef(fit, matrix=TRUE)
+summary(fit)
+\dontrun{
+plot(x, y, main="Tobit model", las=1)
+legend(-0.9, 3, c("Truth", "Estimate"), col=c("Blue", "Red"), lwd=2)
lines(x, f(x), col="blue", lwd=2) # The truth
lines(x, fitted(fit), col="red", lwd=2, lty="dashed") # The estimate
-summary(fit)
}
}
\keyword{models}
diff --git a/man/uqo.Rd b/man/uqo.Rd
index 77d4fa7..f624b1c 100644
--- a/man/uqo.Rd
+++ b/man/uqo.Rd
@@ -251,7 +251,7 @@ plot(lv(p1), lv(up1), xlim=c(-3,4), ylim=c(-3,4), las=1)
abline(a=0, b=-1, lty=2, col="blue", xpd=FALSE)
cor(lv(p1, ITol=TRUE), lv(up1))
-# Another comparison between the constrained & unconstrained models
+# Another comparison between the constrained and unconstrained models
# The signs are not right so they are similar when reflected about 0
par(mfrow=c(2,1))
persp(up1, main="Red/Blue are the constrained/unconstrained models",
diff --git a/man/venice.Rd b/man/venice.Rd
index 2e11efb..f1bbcb6 100644
--- a/man/venice.Rd
+++ b/man/venice.Rd
@@ -12,15 +12,8 @@
\describe{
\item{year}{a numeric vector. }
\item{r1}{a numeric vector; the highest recorded value. }
- \item{r2}{a numeric vector; the second highest recorded value. }
- \item{r3}{a numeric vector; the third highest recorded value. }
- \item{r4}{a numeric vector; the fourth highest recorded value. }
- \item{r5}{a numeric vector; the fifth highest recorded value. }
- \item{r6}{a numeric vector; the sixth highest recorded value. }
- \item{r7}{a numeric vector; the seventh highest recorded value. }
- \item{r8}{a numeric vector; the eighth highest recorded value. }
- \item{r9}{a numeric vector; the ninth highest recorded value. }
- \item{r10}{a numeric vector; the tenth highest recorded value. }
+ \item{r2,r3,r4,r5,r6,r7,r8,r9,r10}{numeric vectors; the second highest recorded value
+ down to the tenth highest recorded value. }
}
}
\details{
diff --git a/man/vonmises.Rd b/man/vonmises.Rd
index 5cfce4a..f1bdacf 100644
--- a/man/vonmises.Rd
+++ b/man/vonmises.Rd
@@ -7,15 +7,24 @@
von Mises distribution by maximum likelihood estimation.
}
\usage{
-vonmises(lscale="loge", ilocation=NULL,
- iscale=NULL, method.init=1, zero=NULL)
+vonmises(llocation="elogit", lscale="loge",
+ elocation=if(llocation=="elogit") list(min=0, max=2*pi) else list(),
+ escale=list(),
+ ilocation=NULL, iscale=NULL,
+ method.init=1, zero=NULL)
}
%- maybe also 'usage' for other objects documented here.
\arguments{
- \item{lscale}{
- Parameter link function applied to the scale parameter \eqn{k}.
+ \item{llocation, lscale}{
+ Parameter link functions applied to the location \eqn{a} parameter
+ and scale parameter \eqn{k}, respectively.
See \code{\link{Links}} for more choices.
- A log link is the default because the parameter is positive.
+ For \eqn{k}, a log link is the default because the parameter is positive.
+
+ }
+ \item{elocation, escale}{
+ List. Extra argument for each of the link functions.
+ See \code{earg} in \code{\link{Links}} for general information.
}
\item{ilocation}{
@@ -70,16 +79,18 @@ vonmises(lscale="loge", ilocation=NULL,
\eqn{1 - I_1(k) / I_0(k)}{1 - I1(k) / I0(k)}
where \eqn{I_1(k)}{I1(k)} is the modified Bessel
function of order 1.
- By default, \eqn{\eta_1=a}{eta1=a} and
- \eqn{\eta_2=\log(k)}{eta2=log(k)} for this family function, but
- later an extended logit link \eqn{\eta_1=\log(a/(2\pi-a))}{eta1=log(a/(2*pi-a))}
- might be provided for \eqn{\eta_1}{eta1}.
+ By default,
+ \eqn{\eta_1=\log(a/(2\pi-a))}{eta1=log(a/(2*pi-a))}
+ and
+ \eqn{\eta_2=\log(k)}{eta2=log(k)} for this family function.
+
}
\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)
@@ -92,12 +103,14 @@ New York: Wiley-Interscience, Third edition.
\eqn{0\leq y< 2\pi}{0<=y<2*pi}.
The linear/additive predictors are left alone.
Fisher scoring is used.
+
}
\section{Warning }{
Numerically, the von~Mises 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{ilocation} and \code{iscale}.
+
}
\seealso{
@@ -105,6 +118,7 @@ New York: Wiley-Interscience, Third edition.
\pkg{CircStats} and \pkg{circular} currently have a lot more
R functions for circular data than the \pkg{VGAM} package.
+
}
\examples{
x = runif(n <- 1000)
@@ -118,3 +132,7 @@ range(fit at y) # processed data is in [0,2*pi)
\keyword{models}
\keyword{regression}
+%later an extended logit link \eqn{\eta_1=\log(a/(2\pi-a))}{eta1=log(a/(2*pi-a))}
+%might be provided for \eqn{\eta_1}{eta1}.
+%\eqn{\eta_1=a}{eta1=a} and
+
diff --git a/man/wald.Rd b/man/wald.Rd
index 8a857d6..2a25e07 100644
--- a/man/wald.Rd
+++ b/man/wald.Rd
@@ -7,7 +7,7 @@ Estimates the parameter of the standard Wald distribution
by maximum likelihood estimation.
}
\usage{
-wald(link.lambda="loge", init.lambda=NULL)
+wald(link.lambda="loge", earg=list(), init.lambda=NULL)
}
%- maybe also 'usage' for other objects documented here.
\arguments{
@@ -16,6 +16,11 @@ wald(link.lambda="loge", init.lambda=NULL)
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{init.lambda}{
Initial value for the \eqn{\lambda}{lambda} parameter.
The default means an initial value is chosen internally.
diff --git a/man/zanegbinomial.Rd b/man/zanegbinomial.Rd
index fba2b95..4298ae7 100644
--- a/man/zanegbinomial.Rd
+++ b/man/zanegbinomial.Rd
@@ -10,6 +10,7 @@
}
\usage{
zanegbinomial(lp0="logit", lmunb = "loge", lk = "loge",
+ ep0=list(), emunb =list(), ek = list(),
ik = 1, zero = -3, cutoff = 0.995, method.init=3)
}
%- maybe also 'usage' for other objects documented here.
@@ -32,6 +33,11 @@ zanegbinomial(lp0="logit", lmunb = "loge", lk = "loge",
See \code{\link{Links}} for more choices.
}
+ \item{ep0, emunb, ek}{
+ List. Extra argument for the respective links.
+ See \code{earg} in \code{\link{Links}} for general information.
+
+ }
\item{ik}{
Initial values for \code{k}. They must be positive, and one value
for each response/species.
diff --git a/man/zapoisson.Rd b/man/zapoisson.Rd
index 1f19e6e..23010b5 100644
--- a/man/zapoisson.Rd
+++ b/man/zapoisson.Rd
@@ -8,7 +8,8 @@
and a positive-Poisson distribution.
}
\usage{
-zapoisson(lp0 = "logit", llambda = "loge")
+zapoisson(lp0 = "logit", llambda = "loge",
+ ep0=list(), elambda=list())
}
%- maybe also 'usage' for other objects documented here.
\arguments{
@@ -22,6 +23,11 @@ zapoisson(lp0 = "logit", llambda = "loge")
See \code{\link{Links}} for more choices.
}
+ \item{ep0, elambda}{
+ Extra argument for the respective links.
+ See \code{earg} in \code{\link{Links}} for general information.
+
+ }
}
\details{
The response \eqn{Y} is zero with probability \eqn{p_0}{p0}, or \eqn{Y}
diff --git a/man/zetaff.Rd b/man/zetaff.Rd
index 9789188..29d242c 100644
--- a/man/zetaff.Rd
+++ b/man/zetaff.Rd
@@ -6,7 +6,7 @@
Estimates the parameter of the zeta distribution.
}
\usage{
-zetaff(link = "loge", init.p = NULL)
+zetaff(link = "loge", earg=list(), init.p = NULL)
}
%- maybe also 'usage' for other objects documented here.
\arguments{
@@ -17,6 +17,11 @@ zetaff(link = "loge", init.p = NULL)
may fail if the maximum likelihood estimate is less than one.
}
+ \item{earg}{
+ List. Extra argument for the link.
+ See \code{earg} in \code{\link{Links}} for general information.
+
+ }
\item{init.p}{
Optional initial value for the parameter \eqn{p}.
The default is to choose an initial value internally.
diff --git a/man/zibinomUC.Rd b/man/zibinomUC.Rd
index 80affc2..da81e42 100644
--- a/man/zibinomUC.Rd
+++ b/man/zibinomUC.Rd
@@ -75,7 +75,7 @@ round(dzibinom(0:10, size, prob, phi=phi) * 100) # Should be similar
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 & shifted slightly)", sep=""),
+ " 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")
}
diff --git a/man/zibinomial.Rd b/man/zibinomial.Rd
index 3b503f1..f69ac4b 100644
--- a/man/zibinomial.Rd
+++ b/man/zibinomial.Rd
@@ -8,7 +8,9 @@
}
\usage{
-zibinomial(lphi="logit", link.mu="logit", iphi=NULL, zero=1, mv=FALSE)
+zibinomial(lphi="logit", link.mu="logit",
+ ephi=list(), emu=list(),
+ iphi=NULL, zero=1, mv=FALSE)
}
%- maybe also 'usage' for other objects documented here.
\arguments{
@@ -16,31 +18,37 @@ zibinomial(lphi="logit", link.mu="logit", iphi=NULL, zero=1, mv=FALSE)
Link function for the parameter \eqn{\phi}{phi}.
See \code{\link{Links}} for more choices.
-}
+ }
\item{link.mu}{
Link function for the usual binomial probability \eqn{\mu}{mu} parameter.
See \code{\link{Links}} for more choices.
-}
-\item{iphi}{
+ }
+ \item{ephi, emu}{
+ List. Extra argument for the respective links.
+ See \code{earg} in \code{\link{Links}} for general information.
+
+ }
+
+ \item{iphi}{
Optional initial value for \eqn{\phi}{phi}, whose value must lie
between 0 and 1. The default is to compute an initial value internally.
-}
-\item{zero}{
+ }
+ \item{zero}{
An integer specifying which linear/additive predictor is modelled
as intercepts only. If given, the value must be either 1 or 2,
and the default is the first. Setting \code{zero=NULL} enables both
\eqn{\phi}{phi} and \eqn{\mu}{mu} to be modelled as a function of
the explanatory variables.
-}
-\item{mv}{
+ }
+ \item{mv}{
Logical. Currently it must be \code{FALSE} to mean the function does
not handle multivariate responses. This is to remain compatible with
the same argument in \code{\link{binomialff}}.
-}
+ }
}
\details{
This function uses Fisher scoring and is based on
diff --git a/man/zipf.Rd b/man/zipf.Rd
index b2db490..bea1196 100644
--- a/man/zipf.Rd
+++ b/man/zipf.Rd
@@ -7,7 +7,7 @@
}
\usage{
-zipf(N=NULL, link="loge", init.s=NULL)
+zipf(N=NULL, link="loge", earg=list(), init.s=NULL)
}
%- maybe also 'usage' for other objects documented here.
\arguments{
@@ -24,6 +24,11 @@ zipf(N=NULL, link="loge", init.s=NULL)
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{init.s}{
Optional initial value for the parameter \eqn{s}.
The default is to choose an initial value internally.
diff --git a/man/zipoisUC.Rd b/man/zipoisUC.Rd
index 3836fe3..ab53d38 100644
--- a/man/zipoisUC.Rd
+++ b/man/zipoisUC.Rd
@@ -70,7 +70,7 @@ round(dzipois(0:10, lambda, phi) * 100) # Should be similar
x = 0:10
plot(x, dzipois(x, lambda, phi), type="h", ylab="Probability",
main=paste("ZIP(", lambda, ", phi=", phi, ") (blue) vs",
- " Poisson(", lambda, ") (red & shifted slightly)", sep=""),
+ " 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")
}
diff --git a/man/zipoisson.Rd b/man/zipoisson.Rd
index 1103bf4..d99894d 100644
--- a/man/zipoisson.Rd
+++ b/man/zipoisson.Rd
@@ -6,7 +6,9 @@
Fits a zero-inflated Poisson distribution.
}
\usage{
-zipoisson(lphi="logit", llambda = "loge", iphi = NULL, zero = NULL)
+zipoisson(lphi="logit", llambda = "loge",
+ ephi=list(), elambda =list(),
+ iphi = NULL, zero = NULL)
}
%- maybe also 'usage' for other objects documented here.
\arguments{
@@ -14,24 +16,30 @@ zipoisson(lphi="logit", llambda = "loge", iphi = NULL, zero = NULL)
Link function for the parameter \eqn{\phi}{phi}.
See \code{\link{Links}} for more choices.
-}
+ }
\item{llambda}{
Link function for the usual \eqn{\lambda}{lambda} parameter.
See \code{\link{Links}} for more choices.
-}
-\item{iphi}{
+ }
+ \item{ephi, elambda}{
+ List. Extra argument for the respective links.
+ See \code{earg} in \code{\link{Links}} for general information.
+
+ }
+
+ \item{iphi}{
Optional initial value for \eqn{\phi}{phi}, whose value must lie
between 0 and 1. The default is to compute an initial value internally.
-}
-\item{zero}{
+ }
+ \item{zero}{
An integer specifying which linear/additive predictor is modelled as
intercepts only. If given, the value must be either 1 or 2, and the
default is none of them. Setting \code{zero=1} makes \eqn{\phi}{phi}
a single parameter.
-}
+ }
}
\details{
This function uses Fisher scoring and is based on
--
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