[r-cran-vgam] 07/63: Import Upstream version 0.7-4
Andreas Tille
tille at debian.org
Tue Jan 24 13:54:21 UTC 2017
This is an automated email from the git hooks/post-receive script.
tille pushed a commit to branch master
in repository r-cran-vgam.
commit ed25459dded1d54f73f5214b48f3e6c26fe8b67e
Author: Andreas Tille <tille at debian.org>
Date: Tue Jan 24 14:16:45 2017 +0100
Import Upstream version 0.7-4
---
DESCRIPTION | 6 +-
NAMESPACE | 14 +-
NEWS | 38 ++-
R/cao.fit.q | 6 +-
R/cqo.fit.q | 3 -
R/family.basics.q | 5 +-
R/family.binomial.q | 208 +++++++++++---
R/family.bivariate.q | 2 +-
R/family.censored.q | 384 ++++++++++++++++++-------
R/family.extremes.q | 187 ++++++++++---
R/family.functions.q | 2 +-
R/family.glmgam.q | 223 ++++++++++++++-
R/family.mixture.q | 175 +++++++++++-
R/family.normal.q | 7 +-
R/family.positive.q | 8 +-
R/family.qreg.q | 209 ++++++++++++++
R/family.rrr.q | 10 +-
R/family.survival.q | 121 +++-----
R/family.ts.q | 2 +-
R/family.univariate.q | 711 +++++++++++++++++++++++++++++++++++------------
R/family.zeroinf.q | 48 +++-
R/plot.vglm.q | 24 +-
R/predict.vglm.q | 2 +
R/print.summary.others.q | 5 +-
R/smart.R | 445 -----------------------------
R/summary.vglm.q | 4 +
R/vgam.R | 5 +-
R/vsmooth.spline.q | 7 +-
data/aml.R | 10 +
data/toxop.R | 11 +
man/Links.Rd | 3 +-
man/Surv.Rd | 137 +++++++++
man/SurvS4-class.Rd | 50 ++++
man/VGAM-package.Rd | 194 +++++++++++++
man/acat.Rd | 3 +-
man/alsqreg.Rd | 125 +++++++++
man/aml.Rd | 27 ++
man/betabinomial.Rd | 17 +-
man/binomialff.Rd | 2 +
man/bisa.Rd | 65 ++---
man/cao.Rd | 6 +-
man/cexpon.Rd | 88 ------
man/cratio.Rd | 3 +-
man/cumulative.Rd | 9 +-
man/dexpbinomial.Rd | 187 +++++++++++++
man/enzyme.Rd | 2 +-
man/expexp1.Rd | 1 -
man/exponential.Rd | 2 +-
man/fitted.vlm.Rd | 8 +-
man/gev.Rd | 23 +-
man/gpd.Rd | 4 +
man/grc.Rd | 4 +-
man/gumbel.Rd | 4 +
man/hspider.Rd | 15 +
man/hunua.Rd | 6 +-
man/laplace.Rd | 115 ++++++++
man/laplaceUC.Rd | 36 +--
man/lms.bcg.Rd | 3 +-
man/lms.bcn.Rd | 3 +-
man/lms.yjn.Rd | 7 +-
man/logit.Rd | 1 +
man/loglinb2.Rd | 2 +-
man/loglinb3.Rd | 2 +-
man/maxwell.Rd | 6 +-
man/nakagami.Rd | 2 +-
man/negbinomial.Rd | 18 +-
man/ordpoisson.Rd | 3 +-
man/pareto1.Rd | 14 +-
man/poissonff.Rd | 3 +-
man/poissonp.Rd | 109 ++++++++
man/quasibinomialff.Rd | 6 +-
man/rayleigh.Rd | 23 +-
man/ruge.Rd | 2 +-
man/s.Rd | 2 +-
man/seq2binomial.Rd | 112 ++++++++
man/simplex.Rd | 3 +-
man/skewnormal1.Rd | 4 +-
man/sratio.Rd | 3 +-
man/tobit.Rd | 2 +-
man/toxop.Rd | 50 ++++
man/tparetoUC.Rd | 2 +-
man/triangle.Rd | 83 ++++++
man/triangleUC.Rd | 71 +++++
man/vgam-class.Rd | 2 +-
man/vgam.Rd | 5 +-
man/waitakere.Rd | 4 +-
man/weibull.Rd | 74 ++---
man/zetaff.Rd | 2 +-
man/zipf.Rd | 2 +-
man/zipoisson.Rd | 31 ++-
src/muxr.c | 7 +
src/vcall2.f | 13 +
src/vmux.f | 2 +-
93 files changed, 3482 insertions(+), 1214 deletions(-)
diff --git a/DESCRIPTION b/DESCRIPTION
index bd5db7d..0f83deb 100755
--- a/DESCRIPTION
+++ b/DESCRIPTION
@@ -1,6 +1,6 @@
Package: VGAM
-Version: 0.7-3
-Date: 2007-04-30
+Version: 0.7-4
+Date: 2007-10-1
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: Mon Apr 30 09:53:17 2007; yee
+Packaged: Mon Oct 1 16:58:20 2007; yee
diff --git a/NAMESPACE b/NAMESPACE
index 7d0cb1a..af292b9 100644
--- a/NAMESPACE
+++ b/NAMESPACE
@@ -27,7 +27,6 @@ dimm)
-export(lm, glm, predict.lm, predict.mlm, predict.glm)
export(is.smart, smart.mode.is, wrapup.smart, setup.smart, my1, my2)
export(
@@ -69,6 +68,7 @@ anova.vglm,
beta4,
bisa, dbisa, pbisa, qbisa, rbisa,
betabin.ab, betabinomial,
+dexpbinomial,
dbetabin, pbetabin, rbetabin, dbetabin.ab, pbetabin.ab, rbetabin.ab,
biplot.qrrvglm,
borel.tanner,
@@ -89,7 +89,7 @@ dtheta.deta)
export(cloglog,cauchit,elogit,fisherz,logc,loge,logit,logoff,nreciprocal,
probit,reciprocal,rhobit,
golf,polf,nbolf,nbolf2,Cut)
-export(ordpoisson)
+export(ordpoisson, poissonp)
export(m2adefault,
@@ -139,13 +139,15 @@ rlplot, rlplot.vglm, rrar.control,
rrvglm.control.Gaussian)
export(
-cexpon,
-simple.exponential, simple.poisson, size.binomial,
+Surv, is.SurvS4,
+simple.exponential, simple.poisson,
+seq2binomial, size.binomial,
stdze1, stdze2,
summary.cao, summary.grc, summary.lms, summary.qrrvglm,
summary.rc.exponential, summary.rrvglm, summary.uqo, summaryvgam,
summaryvglm, summaryvlm, s.vam, terms.vlm,
theta2eta, Tol.Coef.qrrvglm, Tol.Coef.uqo, Tol.qrrvglm, Tol.uqo,
+triangle, dtriangle, ptriangle, qtriangle, rtriangle,
vglm.garma.control, vglm.multinomial.control,
vglm.multinomial.deviance.control, vglm.vcategorical.control,
vlm, vlm.control,
@@ -182,7 +184,7 @@ export(lognormal)
export(dpolono, rpolono)
export(dgpd, pgpd, qgpd, rgpd, gpd)
export(dgev, pgev, qgev, rgev, gev, egev)
-export(dlaplace, plaplace, qlaplace, rlaplace)
+export(dlaplace, plaplace, qlaplace, rlaplace, laplace)
export(fff, fff.control,
mbesselI0,
vonmises)
@@ -219,6 +221,7 @@ nidentity, identity,
prentice74,
lms.bcg, lms.bcn,
lms.yjn,
+alsqreg,
logff, dlog, plog, rlog,
loglinb2, loglinb3,
loglog, lognormal3, lvplot.qrrvglm,
@@ -272,6 +275,7 @@ exportClasses("vglmff", "vlm", "vglm", "vgam",
"vcov.qrrvglm",
"vsmooth.spline.fit", "vsmooth.spline")
+exportClasses("SurvS4")
exportMethods(
diff --git a/NEWS b/NEWS
index bb1b7a6..104f09a 100755
--- a/NEWS
+++ b/NEWS
@@ -5,6 +5,42 @@
**************************************************
+ CHANGES IN VGAM VERSION 0.7-4
+
+NEW FEATURES
+
+ o weibull() does not handle any censored observations at all.
+ The function cenweibull(), which will handle censored
+ observations, is currently being written and will use Surv()
+ as input; it should be distributed with version 0.7-5 of VGAM.
+ o bisa() now implements full Fisher scoring. No numerical
+ integration is needed.
+ o Certain functions from the smartpred package are no longer
+ distributed with the VGAM package. These are
+ lm, glm, predict.lm, predict.mlm, predict.glm.
+ This is done because many users have found they interfere with
+ the VGAM package in unpredictable ways.
+ o The following VGAM family functions have improved initial values:
+ betabinomial(), cauchy1(), mccullagh89(), negbinomial(),
+ tpareto1(), zipoisson().
+ o New family functions: alsqreg(), dexpbinomial(), laplace(),
+ poissonp(), seq2binomial(), triangle(dpqr).
+ o VGAM family functions currently withdrawn:
+ cexpon().
+ o A new class called "SurvS4" has been prepared. It will be used
+ later to handle VGAM family functions beginning with "cen" that
+ use Surv() as input.
+ o log1p() used whenever possible.
+
+
+BUG FIXES
+
+ o bisa() did not make use of ishape.
+ o cao(..., family=gaussianff) failed. It now works, although the
+ dispersion parameter is computed using a slightly different
+ formula.
+
+
CHANGES IN VGAM VERSION 0.7-3
@@ -296,7 +332,7 @@ NEW FEATURES
o New functions: guplot(), meplot(), ggamma(dpqr), fff(),
vonmises(), lgamma3ff, lgamma(dpqr), prentice74, tobit,
- zipoisson(dpqr), [dpqr]pospois(), laplace(dpqr) but there is
+ zipoisson(dpqr), [dpqr]pospois(), [dpqr]laplace but there is
no laplace().
o cqo() has been largely rewritten. It now sports a new algorithm
for ITolerances=TRUE. It can handle large data sets (e.g., 1000
diff --git a/R/cao.fit.q b/R/cao.fit.q
index eebe7a7..8f249ca 100644
--- a/R/cao.fit.q
+++ b/R/cao.fit.q
@@ -28,6 +28,8 @@ cao.fit <- function(x, y, w=rep(1, length(x[, 1])),
copyxbig <- FALSE # May be overwritten in @initialize
+ xbig.save <- NULL
+
intercept.only <- ncol(x) == 1 && dimnames(x)[[2]] == "(Intercept)"
y.names <- predictors.names <- NULL # May be overwritten in @initialize
@@ -1006,7 +1008,8 @@ Coef.cao = function(object,
thisSpecies = whichSpecies[sppno]
indexSpecies = if(is.character(whichSpecies))
- match(whichSpecies[sppno], sppnames) else whichSpecies[sppno]
+ match(whichSpecies[sppno], ynames) else whichSpecies[sppno]
+
if(is.na(indexSpecies))
stop("mismatch found in \"whichSpecies\"")
@@ -1579,7 +1582,6 @@ plot.cao = function(x,
}
if(residuals.arg) {
stop("can't handle residuals=TRUE yet")
- points(x at x, yymat[,i], col=pcol[i], pch=pch[i], cex=pcex[i])
}
counter = counter + 1
lines(xvals, yvals,
diff --git a/R/cqo.fit.q b/R/cqo.fit.q
index a6ee10b..1026700 100644
--- a/R/cqo.fit.q
+++ b/R/cqo.fit.q
@@ -803,9 +803,6 @@ printqrrvglm <- function(x, ...)
}
if(FALSE) {
- Rank <- x at Rank
- if(!length(Rank))
- Rank <- sum(!nas)
}
if(FALSE) {
diff --git a/R/family.basics.q b/R/family.basics.q
index 6d2a699..2f07d59 100644
--- a/R/family.basics.q
+++ b/R/family.basics.q
@@ -495,6 +495,7 @@ wweights = function(object, matrix.arg=TRUE, deriv.arg=FALSE,
return(wz)
}
+ M <- object at misc$M # Done below
n <- object at misc$n # Done below
if(any(slotNames(object)=="extra")) {
@@ -790,9 +791,7 @@ assign2VGAMenv = function(varnames, mylist, prefix="") {
assign(evarnames[i], mylist[[(varnames[i])]], envir = VGAMenv)
}
} else {
- warning("not sure about the assign function---esp. re. frame 0")
- for(i in 1:length(varnames))
- assign(evarnames[i], mylist[[(varnames[i])]], frame=0)
+ stop("uncomment the lines below")
}
}
diff --git a/R/family.binomial.q b/R/family.binomial.q
index 33c5e5f..48123a8 100644
--- a/R/family.binomial.q
+++ b/R/family.binomial.q
@@ -59,16 +59,16 @@ process.binomial2.data.vgam <- expression({
betabinomial <- function(lmu="logit", lrho="logit",
emu=list(), erho=list(),
- irho=0.5, zero=2)
+ irho=NULL, method.init=1, zero=2)
{
if(mode(lmu) != "character" && mode(lmu) != "name")
lmu = as.character(substitute(lmu))
if(mode(lrho) != "character" && mode(lrho) != "name")
lrho = as.character(substitute(lrho))
- if(length(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()
+ if(!is.Numeric(method.init, allow=1, integ=TRUE, posit=TRUE) ||
+ method.init > 2) stop("argument \"method.init\" must be 1 or 2")
new("vglmff",
blurb=c("Beta-binomial model\n",
@@ -84,34 +84,45 @@ betabinomial <- function(lmu="logit", lrho="logit",
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, earg= .emu, 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)
} else {
- init.rho = rep(0, length=n)
- Loglikfun = function(ycounts, nvec, shape1, shape2)
- if(is.R()) sum(lbeta(shape1+ycounts, shape2+nvec-ycounts) -
- lbeta(shape1, shape2)) else
- sum(lgamma(shape1+ycounts) + lgamma(shape2+nvec-ycounts) -
- lgamma(shape1+shape2+nvec) -
- (lgamma(shape1) + lgamma(shape2) - lgamma(shape1+shape2)))
- rho.grid = rvar = seq(0.05, 0.95, len=11) #
- for(ii in 1:length(rho.grid))
- rvar[ii] = Loglikfun(ycounts=y*w,
- shape1=mustart*(1-rho.grid[ii])/rho.grid[ii],
- shape2=(1-mustart)*(1-rho.grid[ii])/rho.grid[ii],
- nvec=w)
- try.this = rho.grid[rvar == max(rvar)]
+ betabinomial.Loglikfun = function(rhoval, y, x, w, extraargs) {
+ shape1 = extraargs$mustart*(1-rhoval)/rhoval
+ shape2 = (1-extraargs$mustart)*(1-rhoval)/rhoval
+ ycounts = extraargs$ycounts
+ nvec = extraargs$nvec
+ if(is.R()) sum(lbeta(shape1+ycounts, shape2+nvec-ycounts) -
+ lbeta(shape1, shape2)) else
+ sum(lgamma(shape1+ycounts) + lgamma(shape2+nvec-ycounts) -
+ lgamma(shape1+shape2+nvec) -
+ (lgamma(shape1) + lgamma(shape2) -
+ lgamma(shape1+shape2)))
+ }
+ rho.grid = rvar = seq(0.05, 0.95, len=21) #
+ mustart.use = if( .method.init == 2) {
+ mustart
+ } else {
+ y.matrix = cbind(y)
+ mat.temp = matrix(apply(y.matrix, 2, mean), nrow(y.matrix),
+ ncol(y.matrix), byrow=TRUE)
+ 0.5 * mustart + 0.5 * mat.temp
+ }
+ try.this = getMaxMin(rho.grid, objfun=betabinomial.Loglikfun,
+ y=y, x=x, w=w, extraargs=list(
+ ycounts=ycounts, nvec=w,
+ mustart=mustart.use))
init.rho = rep(try.this, len=n)
}
-
- etastart = cbind(theta2eta(mustart, .lmu, earg= .emu),
- theta2eta(init.rho, .lrho, earg= .erho))
+ etastart = cbind(theta2eta(mustart.use, .lmu, earg= .emu),
+ theta2eta(init.rho, .lrho, earg= .erho))
}
}), list( .lmu=lmu, .lrho=lrho,
.emu=emu, .erho=erho,
+ .method.init=method.init,
.irho=irho ))),
inverse=eval(substitute(function(eta, extra=NULL)
eta2theta(eta[,1], .lmu, earg= .emu),
@@ -129,6 +140,9 @@ betabinomial <- function(lmu="logit", lrho="logit",
ycounts = y * w # Convert proportions to counts
mymu = eta2theta(eta[,1], .lmu, earg= .emu)
rho = eta2theta(eta[,2], .lrho, earg= .erho)
+ smallno = 100 * .Machine$double.eps
+ rho = pmax(rho, smallno)
+ rho = pmin(rho, 1-smallno)
shape1 = mymu * (1 - rho) / rho
shape2 = (1-mymu) * (1 - rho) / rho
nvec = w
@@ -148,6 +162,9 @@ betabinomial <- function(lmu="logit", lrho="logit",
ycounts = y * w # Convert proportions to counts
mymu = eta2theta(eta[,1], .lmu, earg= .emu)
rho = eta2theta(eta[,2], .lrho, earg= .erho)
+ smallno = 100 * .Machine$double.eps
+ rho = pmax(rho, smallno)
+ rho = pmin(rho, 1-smallno)
shape1 = mymu * (1 - rho) / rho
shape2 = (1-mymu) * (1 - rho) / rho
dshape1.dmu = (1 - rho) / rho
@@ -283,18 +300,18 @@ binom2.or <- function(lmu="logit", lmu1=lmu, lmu2=lmu, lor="loge",
b <- -4 * or * (or-1) * pm[,1] * pm[,2]
temp <- sqrt(a^2+b)
- coeff <- -0.5 + (2*or*pm[,2]-a)/(2*temp)
- d1 <- coeff*(y[,1]/mu[,1]-y[,3]/mu[,3])-
- (1+coeff)*(y[,2]/mu[,2]-y[,4]/mu[,4])
+ coeff1 <- -0.5 + (2*or*pm[,2]-a)/(2*temp)
+ d1 <- coeff1*(y[,1]/mu[,1]-y[,3]/mu[,3])-
+ (1+coeff1)*(y[,2]/mu[,2]-y[,4]/mu[,4])
- coeff <- -0.5 + (2*or*pm[,1]-a)/(2*temp)
- d2 <- coeff*(y[,1]/mu[,1]-y[,2]/mu[,2])-
- (1+coeff)*(y[,3]/mu[,3]-y[,4]/mu[,4])
+ coeff2 <- -0.5 + (2*or*pm[,1]-a)/(2*temp)
+ d2 <- coeff2*(y[,1]/mu[,1]-y[,2]/mu[,2])-
+ (1+coeff2)*(y[,3]/mu[,3]-y[,4]/mu[,4])
- coeff <- (y[,1]/mu[,1]-y[,2]/mu[,2]-y[,3]/mu[,3]+y[,4]/mu[,4])
+ coeff3 <- (y[,1]/mu[,1]-y[,2]/mu[,2]-y[,3]/mu[,3]+y[,4]/mu[,4])
d3 <- ifelse(abs(or-1) < .tol,
- coeff * pm[,1] * (1-pm[,1]) * pm[,2] * (1-pm[,2]),
- (1/(or-1)) * coeff * ( (pm[,1]+pm[,2])*(1-a/temp)/2 +
+ coeff3 * pm[,1] * (1-pm[,1]) * pm[,2] * (1-pm[,2]),
+ (1/(or-1)) * coeff3 * ( (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], .lmu1, earg= .emu1),
d2 * dtheta.deta(pm[,2], .lmu2, earg= .emu2),
@@ -446,7 +463,7 @@ my.dbinom <- function(x,
{
exp( lgamma(size+1) - lgamma(size-x+1) - lgamma(x+1) +
- x * log(prob/(1-prob)) + size * log(1-prob) )
+ x * log(prob/(1-prob)) + size * log1p(-prob) )
}
@@ -489,12 +506,12 @@ size.binomial <- function(prob=0.5, link="loge", earg=list())
function(mu, y, w, res=FALSE,eta, extra=NULL) {
nvec <- mu/extra$temp2
sum(w * (lgamma(nvec+1) - lgamma(y+1) - lgamma(nvec-y+1) +
- y * log(.prob / (1- .prob)) + nvec * log(1- .prob)))
+ y * log(.prob / (1- .prob)) + nvec * log1p(- .prob)))
}, list( .prob=prob ))),
vfamily=c("size.binomial"),
deriv=eval(substitute(expression({
nvec <- mu/extra$temp2
- dldnvec = digamma(nvec+1) - digamma(nvec-y+1) + log(1-extra$temp2)
+ dldnvec = digamma(nvec+1) - digamma(nvec-y+1) + log1p(-extra$temp2)
dnvecdeta <- dtheta.deta(nvec, .link)
w * cbind(dldnvec * dnvecdeta)
}), list( .link=link ))),
@@ -524,8 +541,8 @@ dbetabin.ab = function(x, size, shape1, shape2, log = FALSE) {
lbeta(shape1[ok]+x[ok], shape2[ok]+size[ok]-x[ok]) -
lbeta(shape1[ok], shape2[ok]) else
choose(size[ok], x[ok]) *
- beta(shape1[ok]+x[ok], shape2[ok]+size[ok]-x[ok]) /
- beta(shape1[ok], shape2[ok])
+ beta(shape1[ok]+x[ok],
+ shape2[ok]+size[ok]-x[ok]) / beta(shape1[ok], shape2[ok])
answer
}
@@ -573,7 +590,7 @@ rbetabin.ab = function(n, size, shape1, shape2) {
dbetabin = function(x, size, prob, rho, log = FALSE) {
- rbetabin.ab(x=x, size=size, shape1=prob*(1-rho)/rho,
+ dbetabin.ab(x=x, size=size, shape1=prob*(1-rho)/rho,
shape2=(1-prob)*(1-rho)/rho, log=log)
}
@@ -785,10 +802,10 @@ betageometric = function(lprob="logit", lshape="loge",
if(residuals) stop("loglikelihood residuals not implemented yet") else {
for(ii in 1:maxy) {
index = ii <= y
- ans[index]=ans[index] + log(1-prob[index]+(ii-1)*shape[index])-
- log(1+(ii-1)*shape[index])
+ ans[index]=ans[index] + log1p(-prob[index]+(ii-1)*shape[index])-
+ log1p((ii-1)*shape[index])
}
- ans = ans - log(1+(y+1-1)*shape)
+ ans = ans - log1p((y+1-1)*shape)
sum(w * ans)
}
}, list( .lprob=lprob, .lshape=lshape,
@@ -848,6 +865,119 @@ betageometric = function(lprob="logit", lshape="loge",
+seq2binomial = function(lprob1="logit", lprob2="logit",
+ eprob1=list(), eprob2=list(),
+ iprob1 = NULL, iprob2 = NULL,
+ zero=NULL)
+{
+ if(mode(lprob1) != "character" && mode(lprob1) != "name")
+ lprob1 = as.character(substitute(lprob1))
+ if(mode(lprob2) != "character" && mode(lprob2) != "name")
+ lprob2 = as.character(substitute(lprob2))
+ if(length(iprob1) &&
+ (!is.Numeric(iprob1, positive=TRUE) || max(iprob1) >= 1))
+ stop("bad input for argument \"iprob1\"")
+ if(length(iprob2) &&
+ (!is.Numeric(iprob2, positive=TRUE) || max(iprob2) >= 1))
+ stop("bad input for argument \"iprob2\"")
+ if(!is.list(eprob1)) eprob1 = list()
+ if(!is.list(eprob2)) eprob2 = list()
+
+ new("vglmff",
+ blurb=c("Sequential binomial distribution (Crowder and Sweeting, 1989)\n",
+ "Links: ", namesof("prob1", lprob1, earg= eprob1), ", ",
+ namesof("prob2", lprob2, earg= eprob2)),
+ constraints=eval(substitute(expression({
+ constraints <- cm.zero.vgam(constraints, x, .zero, M)
+ }), list( .zero=zero ))),
+ initialize=eval(substitute(expression({
+ if(!is.vector(w))
+ stop("the 'weights' argument must be a vector")
+ if(any(w != round(w)))
+ warning("the 'weights' argument should be integer-valued")
+ if(ncol(y <- cbind(y)) != 2)
+ stop("the response must be a 2-column matrix")
+ if(any(y < 0 | y > 1))
+ stop("the response must have values between 0 and 1")
+ rvector = w * y[,1]
+ if(any(abs(rvector - round(rvector)) > 1.0e-8))
+ warning("number of successes in column one should be integer-valued")
+ svector = rvector * y[,2]
+ if(any(abs(svector - round(svector)) > 1.0e-8))
+ warning("number of successes in column two should be integer-valued")
+ predictors.names = c(namesof("prob1", .lprob1,earg= .eprob1, tag=FALSE),
+ namesof("prob2", .lprob2,earg= .eprob2, tag=FALSE))
+ prob1.init = if(is.Numeric( .iprob1)) rep( .iprob1, len=n) else
+ rep(weighted.mean(y[,1], w=w), len=n)
+ prob2.init = if(is.Numeric( .iprob2)) rep( .iprob2, len=n) else
+ rep(weighted.mean(y[,2], w=w*y[,1]), len=n)
+ if(!length(etastart)) {
+ etastart = cbind(theta2eta(prob1.init, .lprob1, earg= .eprob1),
+ theta2eta(prob2.init, .lprob2, earg= .eprob2))
+ }
+ }), list( .iprob1=iprob1, .iprob2=iprob2, .lprob1=lprob1,
+ .eprob1=eprob1, .eprob2=eprob2,
+ .lprob2=lprob2 ))),
+ inverse=eval(substitute(function(eta, extra=NULL) {
+ prob1 = eta2theta(eta[,1], .lprob1, earg= .eprob1)
+ prob2 = eta2theta(eta[,2], .lprob2, earg= .eprob2)
+ cbind(prob1, prob2)
+ }, list( .lprob1=lprob1, .lprob2=lprob2,
+ .eprob1=eprob1, .eprob2=eprob2 ))),
+ last=eval(substitute(expression({
+ misc$link = c("prob1" = .lprob1, "prob2" = .lprob2)
+ misc$earg <- list(prob1 = .eprob1, prob2 = .eprob2)
+ misc$expected = TRUE
+ misc$zero = .zero
+ }), list( .lprob1=lprob1, .lprob2=lprob2,
+ .eprob1=eprob1, .eprob2=eprob2,
+ .zero=zero ))),
+ loglikelihood=eval(substitute(
+ function(mu,y,w,residuals=FALSE,eta, extra=NULL) {
+ prob1 = eta2theta(eta[,1], .lprob1, earg= .eprob1)
+ prob2 = eta2theta(eta[,2], .lprob2, earg= .eprob2)
+ smallno = 100 * .Machine$double.eps
+ prob1 = pmax(prob1, smallno)
+ prob1 = pmin(prob1, 1-smallno)
+ prob2 = pmax(prob2, smallno)
+ prob2 = pmin(prob2, 1-smallno)
+ rvector = w * y[,1]
+ svector = rvector * y[,2]
+ if(residuals) stop("loglikelihood residuals not implemented yet") else {
+ sum(rvector * log(prob1) + (mvector-rvector)*log1p(-prob1) +
+ svector * log(prob2) + (rvector-svector)*log1p(-prob2))
+ }
+ }, list( .lprob1=lprob1, .lprob2=lprob2,
+ .eprob1=eprob1, .eprob2=eprob2 ))),
+ vfamily=c("seq2binomial"),
+ deriv=eval(substitute(expression({
+ prob1 = eta2theta(eta[,1], .lprob1, earg= .eprob1)
+ prob2 = eta2theta(eta[,2], .lprob2, earg= .eprob2)
+ smallno = 100 * .Machine$double.eps
+ prob1 = pmax(prob1, smallno)
+ prob1 = pmin(prob1, 1-smallno)
+ prob2 = pmax(prob2, smallno)
+ prob2 = pmin(prob2, 1-smallno)
+ dprob1.deta = dtheta.deta(prob1, .lprob1, earg= .eprob1)
+ dprob2.deta = dtheta.deta(prob2, .lprob2, earg= .eprob2)
+ rvector = w * y[,1]
+ svector = rvector * y[,2]
+ dl.dprob1 = rvector / prob1 - (mvector-rvector) / (1-prob1)
+ dl.dprob2 = svector / prob2 - (rvector-svector) / (1-prob2)
+ cbind(dl.dprob1 * dprob1.deta, dl.dprob2 * dprob2.deta)
+ }), list( .lprob1=lprob1, .lprob2=lprob2,
+ .eprob1=eprob1, .eprob2=eprob2 ))),
+ weight=eval(substitute(expression({
+ wz = matrix(0, n, M)
+ wz[,iam(1,1,M)] = (dprob1.deta^2) / (prob1 * (1-prob1))
+ wz[,iam(2,2,M)] = (dprob2.deta^2) * prob1 / (prob2 * (1-prob2))
+ w * wz
+ }), list( .lprob1=lprob1, .lprob2=lprob2,
+ .eprob1=eprob1, .eprob2=eprob2 ))))
+}
+
+
+
diff --git a/R/family.bivariate.q b/R/family.bivariate.q
index 96eee65..059d3e4 100644
--- a/R/family.bivariate.q
+++ b/R/family.bivariate.q
@@ -91,7 +91,7 @@ bilogistic4 = function(llocation="identity",
zedd1 = (y[,1]-loc1) / Scale1
zedd2 = (y[,2]-loc2) / Scale2
if(residuals) stop("loglikelihood residuals not implemented yet") else
- sum(w * (-zedd1 - zedd2 - 3 * log(1+exp(-zedd1)+exp(-zedd2)) -
+ sum(w * (-zedd1 - zedd2 - 3 * log1p(exp(-zedd1)+exp(-zedd2)) -
log(Scale1) - log(Scale2)))
}, list(.lscale=lscale, .llocation=llocation))),
vfamily=c("bilogistic4"),
diff --git a/R/family.censored.q b/R/family.censored.q
index d04cba8..9b4d2a9 100644
--- a/R/family.censored.q
+++ b/R/family.censored.q
@@ -6,7 +6,13 @@
-cexpon = function(link="loge", location=0)
+
+
+
+
+if(FALSE)
+cexpon =
+ecexpon = function(link="loge", location=0)
{
if(!is.Numeric(location, allow=1))
stop("bad input for \"location\"")
@@ -16,23 +22,62 @@ cexpon = function(link="loge", location=0)
new("vglmff",
blurb=c("Censored exponential distribution\n\n",
"Link: ", namesof("rate", link, tag= TRUE), "\n",
- "Mean: ", "mu =", location, "+ 1 / ",
- namesof("rate", link, tag= TRUE), "\n",
+ "Mean: ", "mu = ", location, " + 1 / ",
+ namesof("rate", link, tag= FALSE), "\n",
"Variance: ",
if(location==0) "Exponential: mu^2" else
paste("(mu-", location, ")^2", sep="")),
initialize=eval(substitute(expression({
extra$location = .location # This is passed into, e.g., link, deriv etc.
- if(any(y <= extra$location))
+ if(any(y[,1] <= extra$location))
stop(paste("all responses must be greater than", extra$location))
predictors.names = namesof("rate", .link, tag= FALSE)
- mu = y + (abs(y - extra$location) < 0.001) / 8
+ type <- attr(y, "type")
+ if (type=="right" || type=="left"){
+ mu = y[,1] + (abs(y[,1] - extra$location) < 0.001) / 8
+ }else
+ if (type=="interval"){
+ temp <- y[,3]
+ mu = ifelse(temp == 3, y[,2] + (abs(y[,2] - extra$location) < 0.001)
+ / 8,y[,1] + (abs(y[,1] - extra$location) < 0.001) / 8)
+ }
if(!length(etastart))
etastart = theta2eta(1/(mu-extra$location), .link)
- if(!length(extra$leftcensored)) extra$leftcensored = rep(FALSE, len=n)
- if(!length(extra$rightcensored)) extra$rightcensored = rep(FALSE, len=n)
- if(any(extra$rightcensored & extra$leftcensored))
- stop("some observations are both right and left censored!")
+
+ if (type=="right") {
+ temp <- y[, 2]
+ extra$uncensored = ifelse(temp == 1, TRUE, FALSE)
+ extra$rightcensored = ifelse(temp == 0, TRUE, FALSE)
+ extra$leftcensored = rep(FALSE, len=n)
+ extra$interval = rep(FALSE, len=n)
+ } else
+ if (type=="left") {
+ temp <- y[, 2]
+ extra$uncensored = ifelse(temp == 1, TRUE, FALSE)
+ extra$rightcensored = rep(FALSE, len=n)
+ extra$leftcensored = ifelse(temp == 0, TRUE, FALSE)
+ extra$interval = rep(FALSE, len=n)
+ } else
+ if (type=="counting") {
+ stop("type=='counting' not recognized")
+ extra$uncensored = rep(temp == 1, TRUE, FALSE)
+ extra$interval = rep(FALSE, len=n)
+ extra$leftcensored = rep(FALSE, len=n)
+ extra$rightcensored = rep(FALSE, len=n)
+ extra$counting = ifelse(temp == 0, TRUE, FALSE)
+ } else
+ if (type=="interval") {
+ temp <- y[, 3]
+ extra$uncensored = ifelse(temp == 1, TRUE, FALSE)
+ extra$rightcensored = ifelse(temp == 0, TRUE, FALSE)
+ extra$leftcensored = ifelse(temp == 2, TRUE, FALSE)
+ extra$interval = ifelse(temp == 3, TRUE, FALSE)
+ } else
+ stop("'type' not recognized")
+ #if(!length(extra$leftcensored)) extra$leftcensored = rep(FALSE, len=n)
+ #if(!length(extra$rightcensored)) extra$rightcensored = rep(FALSE, len=n)
+ #if(any(extra$rightcensored & extra$leftcensored))
+ # stop("some observations are both right and left censored!")
}), list( .location=location, .link=link ))),
inverse=eval(substitute(function(eta, extra=NULL)
extra$location + 1 / eta2theta(eta, .link),
@@ -41,45 +86,56 @@ cexpon = function(link="loge", location=0)
misc$location = extra$location
misc$link = c("rate" = .link)
}), list( .link=link ))),
- link=eval(substitute(function(mu, extra=NULL)
+ link=eval(substitute(function(mu, extra=NULL)
theta2eta(1/(mu-extra$location), .link),
list( .link=link ) )),
loglikelihood=eval(substitute(
function(mu,y,w,residuals= FALSE,eta, extra=NULL) {
rate = 1 / (mu - extra$location)
- cen0 = !extra$leftcensored & !extra$rightcensored # uncensored obsns
+ cen0 = extra$uncensored
cenL = extra$leftcensored
cenU = extra$rightcensored
+ cenI = extra$interval
if(residuals) stop("loglikelihood residuals not implemented yet") else
- sum(w[cenL] * log(1 - exp(-rate[cenL]*(y[cenL]-extra$location)))) +
- sum(w[cenU] * (-rate[cenU]*(y[cenU]-extra$location))) +
- sum(w[cen0] * (log(rate[cen0]) - rate[cen0]*(y[cen0]-extra$location)))
+ sum(w[cenL] * log1p(-exp(-rate[cenL]*(y[cenL,1]-extra$location)))) +
+ sum(w[cenU] * (-rate[cenU]*(y[cenU,1]-extra$location))) +
+ sum(w[cen0] * (log(rate[cen0]) - rate[cen0]*(y[cen0,1]-extra$location)))+
+ sum(w[cenI] * log(-exp(-rate[cenI]*(y[cenI,2]-extra$location))+
+ exp(-rate[cenI]*(y[cenI,1]-extra$location))))
}, list( .link=link ))),
- vfamily=c("cexpon"),
+ vfamily=c("ecexpon"),
deriv=eval(substitute(expression({
rate = 1 / (mu - extra$location)
- cen0 = !extra$leftcensored & !extra$rightcensored # uncensored obsns
+ cen0 = extra$uncensored
cenL = extra$leftcensored
cenU = extra$rightcensored
- dl.drate = 1/rate - (y-extra$location) # uncensored
- tmp200 = exp(-rate*(y-extra$location))
+ cenI = extra$interval
+ dl.drate = 1/rate - (y[,1]-extra$location) # uncensored
+ tmp200 = exp(-rate*(y[,1]-extra$location))
+ tmp200b = exp(-rate*(y[,2]-extra$location)) # for interval censored
if(any(cenL))
- dl.drate[cenL] = (y[cenL]-extra$location) * tmp200[cenL] /
- (1 - tmp200[cenL])
+ dl.drate[cenL] = (y[cenL,1]-extra$location) *
+ tmp200[cenL] / (1 - tmp200[cenL])
if(any(cenU))
- dl.drate[cenU] = -(y[cenU]-extra$location)
+ dl.drate[cenU] = -(y[cenU,1]-extra$location)
+ if(any(cenI))
+ dl.drate[cenI] = ((y[cenI,2]-extra$location)*tmp200b[cenI]-
+ (y[cenI,1]-extra$location)*tmp200[cenI])/
+ (-tmp200b[cenI]+tmp200[cenI])
drate.deta = dtheta.deta(rate, .link)
w * dl.drate * drate.deta
}), list( .link=link ) )),
weight=eval(substitute(expression({
- A123 = ((mu-extra$location)^2) # uncensored d2l.drate2
- Lowpt = ifelse(cenL, y, extra$location)
- Upppt = ifelse(cenU, y, Inf)
+ A123 = ((mu-extra$location)^2) # uncensored d2l.drate2
+ Lowpt = ifelse(cenL, y[,1], extra$location)
+ Lowpt = ifelse(cenI, y[,1], Lowpt) #interval censored
+ Upppt = ifelse(cenU, y[,1], Inf)
+ Upppt = ifelse(cenI, y[,2], Upppt) #interval censored
tmp300 = exp(-rate*(Lowpt - extra$location))
- d2l.drate2 = 0 * y
+ d2l.drate2 = 0 * y[,1]
ind50 = Lowpt > extra$location
- d2l.drate2[ind50] = (Lowpt[ind50]-extra$location)^2 * tmp300[ind50] /
- (1-tmp300[ind50])
+ d2l.drate2[ind50] = (Lowpt[ind50]-extra$location)^2 *
+ tmp300[ind50] / (1-tmp300[ind50])
d2l.drate2 = d2l.drate2 + (exp(-rate*(Lowpt-extra$location)) -
exp(-rate*(Upppt-extra$location))) * A123
wz = w * (drate.deta^2) * d2l.drate2
@@ -145,8 +201,8 @@ cnormal1 = function(lmu="identity", lsd="loge", imethod=1, zero=2)
Lower = ifelse(cenL, y, -Inf)
Upper = ifelse(cenU, y, Inf)
ell1 = -log(sd[cen0]) - 0.5 * ((y[cen0] - mum[cen0])/sd[cen0])^2
- ell2 = log(1 - pnorm((mum[cenL] - Lower[cenL])/sd[cenL]))
- ell3 = log(1 - pnorm(( Upper[cenU] - mum[cenU])/sd[cenU]))
+ ell2 = log1p(-pnorm((mum[cenL] - Lower[cenL])/sd[cenL]))
+ ell3 = log1p(-pnorm(( Upper[cenU] - mum[cenU])/sd[cenU]))
if(residuals) stop("loglikelihood residuals not implemented yet") else
sum(w[cen0] * ell1) + sum(w[cenL] * ell2) + sum(w[cenU] * ell3)
}, list( .lmu=lmu, .lsd=lsd ))),
@@ -300,11 +356,12 @@ crayleigh = function(link="loge", earg = list(), expected=FALSE) {
}
-weibull = function(lshape="logoff", lscale="loge",
- eshape=if(lshape == "logoff") list(offset=-2) else list(),
- escale=list(),
- ishape=NULL, iscale=NULL,
- imethod=1, zero=2)
+weibull =
+weibull.sev = function(lshape="loge", lscale="loge",
+ eshape=list(), escale=list(),
+ ishape=NULL, iscale=NULL,
+ nrfs = 1,
+ imethod=1, zero=2)
{
if(mode(lshape) != "character" && mode(lshape) != "name")
@@ -317,9 +374,11 @@ weibull = function(lshape="logoff", lscale="loge",
stop("argument \"imethod\" must be 1 or 2")
if(!is.list(eshape)) eshape = list()
if(!is.list(escale)) escale = list()
+ if(!is.Numeric(nrfs, allow=1) || nrfs<0 || nrfs > 1)
+ stop("bad input for 'nrfs'")
new("vglmff",
- blurb=c("Censored Weibull distribution\n\n",
+ blurb=c("Weibull distribution\n\n",
"Links: ",
namesof("shape", lshape, earg= eshape), ", ",
namesof("scale", lscale, earg= escale), "\n",
@@ -332,21 +391,18 @@ weibull = function(lshape="logoff", lscale="loge",
y = cbind(y)
if(ncol(y)>1) stop("the response must be a vector or a 1-column matrix")
- if(length(extra$leftcensored)) stop("left-censoring not allowed") else
- extra$leftcensored = rep(FALSE, len=n)
- if(!length(extra$rightcensored)) extra$rightcensored = rep(FALSE, len=n)
- if(any(extra$rightcensored & extra$leftcensored))
- stop("some observations are both right and left censored!")
+ if(is.SurvS4(y))
+ stop("only uncensored observations are allowed; don't use Surv()")
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
+ anyc = FALSE # extra$leftcensored | extra$rightcensored
i11 = if( .imethod == 1) anyc else FALSE # can be all data
qvec = c(.25, .5, .75) # Arbitrary; could be made an argument
init.shape = if(length( .ishape)) .ishape else 1
- xvec = log(-log(1-qvec))
+ xvec = log(-log1p(-qvec))
fit0 = lsfit(x=xvec, y=log(quantile(y[!i11], qvec)))
}
@@ -368,86 +424,224 @@ weibull = function(lshape="logoff", lscale="loge",
}, list( .lscale=lscale, .lshape=lshape,
.escale=escale, .eshape=eshape ) )),
last=eval(substitute(expression({
+ if(regnotok <- any(shape <= 2))
+ warning(paste("MLE regularity conditions are violated",
+ "(shape <= 2) at the final iteration"))
misc$link = c(shape= .lshape, scale= .lscale)
misc$earg= list(shape= .eshape, scale= .escale)
- misc$expected = TRUE # all(cen0)
+ misc$nrfs = .nrfs
+ misc$RegCondOK = !regnotok # Save this for later
}), list( .lscale=lscale, .lshape=lshape,
- .escale=escale, .eshape=eshape ) )),
+ .escale=escale, .eshape=eshape, .nrfs=nrfs ) )),
loglikelihood=eval(substitute(
function(mu, y, w, residuals= FALSE,eta, extra=NULL) {
- cenL = extra$leftcensored
- cenU = extra$rightcensored
- cen0 = !cenL & !cenU # uncensored obsns
shape = eta2theta(eta[,1], .lshape, earg= .eshape )
scale = eta2theta(eta[,2], .lscale, earg= .escale )
- ell1 = (log(shape[cen0]) - log(scale[cen0]) + (shape[cen0]-1) *
- log(y[cen0]/scale[cen0]) - (y[cen0] / scale[cen0])^shape[cen0])
- ell3 = -((y[cenU] / scale[cenU])^shape[cenU])
+ ell1 = (log(shape) - log(scale) + (shape-1) *
+ log(y/scale) - (y / scale)^shape)
if(residuals) stop("loglikelihood residuals not implemented yet") else
- sum(w[cen0] * ell1) + sum(w[cenU] * ell3)
+ sum(w * ell1)
}, list( .lscale=lscale, .lshape=lshape,
.escale=escale, .eshape=eshape ) )),
- vfamily=c("cweibull"),
+ vfamily=c("weibull.sev"),
deriv=eval(substitute(expression({
- cenL = extra$leftcensored
- cenU = extra$rightcensored
- cen0 = !cenL & !cenU # uncensored obsns
shape = eta2theta(eta[,1], .lshape, earg= .eshape )
scale = eta2theta(eta[,2], .lscale, earg= .escale )
- dl.dshape = 1/shape + log(y/scale) - (y/scale)^shape * log(y/scale)
+ dl.dshape = 1/shape + log(y/scale) - log(y/scale) * (y/scale)^shape
dl.dscale = (shape/scale) * (-1 + (y/scale)^shape)
dshape.deta = dtheta.deta(shape, .lshape, earg= .eshape )
dscale.deta = dtheta.deta(scale, .lscale, earg= .escale )
- if(any(cenU)) {
- fred21 = (y[cenU] / scale[cenU])
- temp21 = fred21^shape[cenU]
- dl.dshape[cenU] = -temp21 * log(fred21)
- dl.dscale[cenU] = temp21 * shape[cenU] / scale[cenU]
- }
w * cbind( dl.dshape * dshape.deta, dl.dscale * dscale.deta )
}), list( .lscale=lscale, .lshape=lshape,
.escale=escale, .eshape=eshape ) )),
weight=eval(substitute(expression({
- Euler = 0.57721566490153286
- if(any(cen0)) {
- if(any(shape[cen0] <= 2))
- cat("warning: Fisher info matrices invalid\n")
- }
+ EulerM = -digamma(1.0)
wz = matrix(as.numeric(NA), n, dimm(M)) #3=dimm(M)
- ed2l.dshape = (6*(Euler-1)^2 + pi^2) / (6*shape^2)
+ ed2l.dshape = (6*(EulerM-1)^2 +pi^2)/(6*shape^2) # Kleiber & Kotz (2003)
ed2l.dscale = (shape/scale)^2
- ed2l.dshapescale = (Euler-1)/scale
+ ed2l.dshapescale = (EulerM-1)/scale
wz[,iam(1,1,M)] = ed2l.dshape * dshape.deta^2
wz[,iam(2,2,M)] = ed2l.dscale * dscale.deta^2
wz[,iam(1,2,M)] = ed2l.dshapescale * dscale.deta * dshape.deta
- if(any(cenU)) {
- Integrand11 = function(x) exp(-x) * (1 + log(x))^2
- Integrand12 = function(x) exp(-x) * (1 + log(x))
- ptilde = 1 - exp(-(y/scale)^shape)
- index2 = (1:n)[cenU]
- ed2l.dshape2 = ed2l.dscale2 = ed2l.dshapescale =
- rep(as.numeric(NA), len=sum(cenU))
- icount = 1
- for(iii in index2) {
- integral11 = integrate(Integrand11, low=0, upp=-log(1-ptilde[iii]))
- if(integral11$message != "OK")
- warning("problem numerically integrating elt (1,1)")
- integral12 = integrate(Integrand12, low=0, upp=-log(1-ptilde[iii]))
- if(integral12$message != "OK")
- warning("problem numerically integrating elt (1,2)")
- ed2l.dshape2[icount] = integral11$value / shape[iii]^2
- ed2l.dshapescale[icount] = integral12$value * scale[iii]
- icount = icount + 1
- }
- ed2l.dscale2 = (shape[cenU]/scale[cenU])^2 * ptilde[cenU]
- wz[cenU,iam(1,1,M)] = ed2l.dshape2 * dshape.deta[cenU]^2
- wz[cenU,iam(2,2,M)] = ed2l.dscale2 * dscale.deta[cenU]^2
- wz[cenU,iam(1,2,M)] = ed2l.dshapescale *
- dshape.deta[cenU] * dscale.deta[cenU]
- }
wz = w * wz
wz
- }), list( .eshape=eshape ))))
+ }), list( .eshape=eshape, .nrfs=nrfs ))))
+}
+
+
+
+
+
+
+setOldClass(c("SurvS4","Surv"))
+
+
+Surv <-
+function (time, time2, event, type = c("right", "left", "interval",
+ "counting", "interval2"), origin = 0)
+{
+ nn <- length(time)
+ ng <- nargs()
+ if (missing(type)) {
+ if (ng == 1 || ng == 2)
+ type <- "right" else if (ng == 3)
+ type <- "counting" else stop("Invalid number of arguments")
+ } else {
+ type <- match.arg(type)
+ ng <- ng - 1
+ if (ng != 3 && (type == "interval" || type == "counting"))
+ stop("Wrong number of args for this type of survival data")
+ if (ng != 2 && (type == "right" || type == "left" ||
+ type == "interval2"))
+ stop("Wrong number of args for this type of survival data")
+ }
+ who <- !is.na(time)
+ if (ng == 1) {
+ if (!is.numeric(time))
+ stop("Time variable is not numeric")
+ ss <- cbind(time, 1)
+ dimnames(ss) <- list(NULL, c("time", "status"))
+ } else if (type == "right" || type == "left") {
+ if (!is.numeric(time))
+ stop("Time variable is not numeric")
+ if (length(time2) != nn)
+ stop("Time and status are different lengths")
+ if (is.logical(time2))
+ status <- 1 * time2 else if (is.numeric(time2)) {
+ who2 <- !is.na(time2)
+ if (max(time2[who2]) == 2)
+ status <- time2 - 1 else status <- time2
+ if (any(status[who2] != 0 & status[who2] != 1))
+ stop("Invalid status value")
+ } else stop("Invalid status value")
+ ss <- cbind(time, status)
+ dimnames(ss) <- list(NULL, c("time", "status"))
+ } else if (type == "counting") {
+ if (length(time2) != nn)
+ stop("Start and stop are different lengths")
+ if (length(event) != nn)
+ stop("Start and event are different lengths")
+ if (!is.numeric(time))
+ stop("Start time is not numeric")
+ if (!is.numeric(time2))
+ stop("Stop time is not numeric")
+ who3 <- who & !is.na(time2)
+ if (any(time[who3] >= time2[who3]))
+ stop("Stop time must be > start time")
+ if (is.logical(event))
+ status <- 1 * event else if (is.numeric(event)) {
+ who2 <- !is.na(event)
+ if (max(event[who2]) == 2)
+ status <- event - 1 else status <- event
+ if (any(status[who2] != 0 & status[who2] != 1))
+ stop("Invalid status value")
+ } else stop("Invalid status value")
+ ss <- cbind(time - origin, time2 - origin, status)
+ } else {
+ if (type == "interval2") {
+ event <- ifelse(is.na(time), 2, ifelse(is.na(time2),
+ 0, ifelse(time == time2, 1, 3)))
+ if (any(time[event == 3] > time2[event == 3]))
+ stop("Invalid interval: start > stop")
+ time <- ifelse(event != 2, time, time2)
+ type <- "interval"
+ } else {
+ temp <- event[!is.na(event)]
+ if (!is.numeric(temp))
+ stop("Status indicator must be numeric")
+ if (length(temp) > 0 && any(temp != floor(temp) |
+ temp < 0 | temp > 3))
+ stop("Status indicator must be 0, 1, 2 or 3")
+ }
+ status <- event
+ ss <- cbind(time, ifelse(!is.na(event) & event == 3,
+ time2, 1), status)
+ }
+ attr(ss, "type") <- type
+ class(ss) <- "SurvS4"
+ ss
+}
+
+
+
+is.SurvS4 <- function(x) inherits(x, "SurvS4")
+
+
+
+
+as.character.SurvS4 <-
+function (x, ...)
+{
+ class(x) <- NULL
+ type <- attr(x, "type")
+
+ if (type == "right") {
+ temp <- x[, 2]
+ temp <- ifelse(is.na(temp), "?", ifelse(temp == 0, "+", " "))
+ paste(format(x[, 1]), temp, sep = "")
+ } else if (type == "counting") {
+ temp <- x[, 3]
+ temp <- ifelse(is.na(temp), "?", ifelse(temp == 0, "+", " "))
+ paste("(", format(x[, 1]), ",", format(x[, 2]), temp, "]", sep = "")
+ } else if (type == "left") {
+ temp <- x[, 2]
+ temp <- ifelse(is.na(temp), "?", ifelse(temp == 0, "<", " "))
+ paste(temp, format(x[, 1]), sep = "")
+ } else {
+ stat <- x[, 3]
+ temp <- c("+", "", "-", "]")[stat + 1]
+ temp2 <- ifelse(stat == 3, paste("[", format(x[, 1]),
+ ", ", format(x[, 2]), sep = ""), format(x[, 1]))
+ ifelse(is.na(stat), as.character(NA), paste(temp2, temp, sep = ""))
+ }
+}
+
+
+
+"[.SurvS4" <- function(x, i,j, drop=FALSE) {
+ if (missing(j)) {
+ temp <- class(x)
+ type <- attr(x, "type")
+ class(x) <- NULL
+ x <- x[i, , drop=FALSE]
+ class(x) <- temp
+ attr(x, "type") <- type
+ x
+ } else {
+
+ class(x) <- NULL
+ NextMethod("[")
+ }
+}
+
+is.na.SurvS4 <- function(x) {
+ as.vector( (1* is.na(unclass(x)))%*% rep(1, ncol(x)) >0)
}
+
+
+
+print.SurvS4 <-
+function (x, quote = FALSE, ...)
+invisible(print(as.character.SurvS4(x), quote = quote, ...))
+
+
+setMethod("print", "SurvS4",
+ function(x, ...)
+ invisible(print.SurvS4(x, ...)))
+
+setMethod("show", "SurvS4",
+ function(object)
+ invisible(print.SurvS4(object)))
+
+
+
+
+
+
+
+
+
+
+
diff --git a/R/family.extremes.q b/R/family.extremes.q
index 2082fbf..4456330 100644
--- a/R/family.extremes.q
+++ b/R/family.extremes.q
@@ -118,8 +118,8 @@ gev <- function(llocation="identity",
xiinit = rep(0.05, len=nrow(y))
if(!length(siginit))
siginit = rep(sqrt(6 * var(y[,1]))/pi, len=nrow(y))
- Euler = 0.57721566490153286
- muinit = rep(median(y[,1]) - Euler*siginit, len=nrow(y))
+ EulerM = -digamma(1)
+ muinit = rep(median(y[,1]) - EulerM*siginit, len=nrow(y))
}
bad = ((1 + xiinit*(y-muinit)/siginit) <= 0)
@@ -157,8 +157,8 @@ gev <- function(llocation="identity",
dimnames(fv) = list(dimnames(eta)[[1]],
paste(as.character(cent), "%", sep=""))
} else {
- Euler = 0.57721566490153286
- fv = loc + sigma * Euler # When xi=0, is Gumbel
+ EulerM = -digamma(1)
+ fv = loc + sigma * EulerM # When xi=0, is Gumbel
fv[!iszero] = loc[!iszero] + sigma[!iszero] *
(gamma(1-xi[!iszero])-1) / xi[!iszero]
fv[xi >= 1] = NA # Mean exists only if xi < 1.
@@ -284,10 +284,10 @@ gev <- function(llocation="identity",
if(ncol(y) > 1)
stop("cannot handle xi==0 with a multivariate response")
- Euler = 0.57721566490153286
- wz[iszero,iam(2,2,M)] = (pi^2/6 + (1-Euler)^2) / sigma^2
+ EulerM = -digamma(1)
+ wz[iszero,iam(2,2,M)] = (pi^2/6 + (1-EulerM)^2) / sigma^2
wz[iszero,iam(3,3,M)] = 2.4236 # Solved numerically zz
- wz[iszero,iam(1,2,M)] = (digamma(2) + 2*(Euler-1)) / sigma^2
+ wz[iszero,iam(1,2,M)] = (digamma(2) + 2*(EulerM-1)) / sigma^2
wz[iszero,iam(1,3,M)]= -(trigamma(1)/2 + digamma(1)*
(digamma(1)/2+1))/sigma
wz[iszero,iam(2,3,M)] = (-dgammadx(2,3)/6 + dgammadx(1,1) +
@@ -416,9 +416,9 @@ egev <- function(llocation="identity",
muTry = rep(fit0$coef["Intercept"], len=length(y))
llTry = egev()@loglikelihood(mu=NULL,y=y,w=w,
residuals=FALSE, extra=list(giveWarning=FALSE),
- eta=cbind(theta2eta(muTry, .llocation, earg= .elocation),
- theta2eta(sigmaTry, .lscale, earg= .escale),
- theta2eta(xi.try, .lshape, earg= .eshape)))
+ eta=cbind(theta2eta(muTry, .llocation,earg= .elocation),
+ theta2eta(sigmaTry, .lscale, earg= .escale),
+ theta2eta(xi.try, .lshape, earg= .eshape)))
if(llTry >= objecFunction) {
if(est.sigma)
siginit = sigmaTry
@@ -434,8 +434,8 @@ egev <- function(llocation="identity",
xiinit = rep(if(length(xiinit)) xiinit else 0.05, len=length(y))
if(!length(siginit))
siginit = rep(sqrt(6*var(y))/pi, len=length(y))
- Euler = 0.57721566490153286
- muinit <- rep(median(y) - Euler * siginit, len=length(y))
+ EulerM = -digamma(1)
+ muinit = rep(median(y) - EulerM * siginit, len=length(y))
}
bad <- (1 + xiinit*(y-muinit)/siginit <= 0)
if(fred <- sum(bad, na.rm=TRUE)) {
@@ -473,8 +473,8 @@ egev <- function(llocation="identity",
dimnames(fv) = list(dimnames(eta)[[1]],
paste(as.character(cent), "%", sep=""))
} else {
- Euler = 0.57721566490153286
- fv = loc + sigma * Euler # When xi=0, is Gumbel
+ EulerM = -digamma(1)
+ fv = loc + sigma * EulerM # When xi=0, is Gumbel
fv[!iszero] = loc[!iszero] + sigma[!iszero] *
(gamma(1-xi[!iszero])-1) / xi[!iszero]
fv[xi >= 1] = NA # Mean exists only if xi < 1.
@@ -559,24 +559,24 @@ egev <- function(llocation="identity",
if(any(bad, na.rm = TRUE)) stop(paste(sum(bad, na.rm = TRUE),
"observations violating boundary constraints in @weight"))
kay = -xi # for the formulae
+ kay[abs(kay-0.5) < .tshape0] = 0.501
temp100 = gamma(2-kay)
- pp = (1-kay)^2 * gamma(1-2*kay)
+ pp = (1-kay)^2 * gamma(1-2*kay) # gamma(0) is undefined so kay != 0.5
qq = temp100 * (digamma(1-kay) - (1-kay)/kay)
wz = matrix(as.numeric(NA), n, 6)
wz[,iam(1,1,M)] = pp / sigma^2
wz[,iam(2,2,M)] = (1-2*temp100 + pp) / (sigma * kay)^2
- Euler = 0.57721566490153286
- wz[,iam(3,3,M)] = (pi^2 / 6 + (1-Euler-1/kay)^2 +
+ EulerM = -digamma(1)
+ wz[,iam(3,3,M)] = (pi^2 / 6 + (1-EulerM-1/kay)^2 +
(2*qq + pp/kay)/kay) / kay^2
wz[,iam(1,2,M)] = (pp - temp100) / (sigma^2 * kay)
wz[,iam(1,3,M)] = -(qq + pp/kay) / (sigma * kay)
- wz[,iam(2,3,M)] = (1-Euler - (1-temp100)/kay - qq -
+ wz[,iam(2,3,M)] = (1-EulerM - (1-temp100)/kay - qq -
pp/kay) / (sigma * kay^2)
-
if(any(iszero)) {
- wz[iszero,iam(2,2,M)] = (pi^2/6 + (1-Euler)^2) / sigma^2
+ wz[iszero,iam(2,2,M)] = (pi^2/6 + (1-EulerM)^2) / sigma^2
wz[iszero,iam(3,3,M)] = 2.4236 # Solved numerically zz
- wz[iszero,iam(1,2,M)] = (digamma(2) + 2*(Euler-1)) / sigma^2
+ wz[iszero,iam(1,2,M)] = (digamma(2) + 2*(EulerM-1)) / sigma^2
wz[iszero,iam(1,3,M)]= -(trigamma(1)/2 + digamma(1)*
(digamma(1)/2+1))/sigma
wz[iszero,iam(2,3,M)] = (-dgammadx(2,3)/6 + dgammadx(1,1) +
@@ -680,8 +680,8 @@ gumbel <- function(llocation="identity",
sc.init = if(is.Numeric( .iscale, posit=TRUE))
.iscale else 1.1 * (0.01+sqrt(var(y)*6)) / pi
sc.init = rep(sc.init, len=n)
- Euler = 0.57721566490153286
- loc.init = (y - sc.init * Euler)
+ EulerM = -digamma(1)
+ loc.init = (y - sc.init * EulerM)
loc.init[loc.init <= 0] = min(y)
}
@@ -717,8 +717,8 @@ gumbel <- function(llocation="identity",
dmn2 = c(dmn2, "MPV")
dimnames(mu) = list(dimnames(eta)[[1]], dmn2)
} else {
- Euler = 0.57721566490153286
- mu = loc + sigma * Euler
+ EulerM = -digamma(1)
+ mu = loc + sigma * EulerM
}
mu
}, list( .llocation=llocation, .lscale=lscale,
@@ -877,7 +877,7 @@ qgpd = function(p, location=0, scale=1, shape=0) {
((1-p[!scase])^(-shape[!scase]) - 1) / shape[!scase]
}
if(nscase) {
- ans[scase] = location[scase] - scale[scase] * log(1-p[scase])
+ ans[scase] = location[scase] - scale[scase] * log1p(-p[scase])
}
ans
}
@@ -940,11 +940,11 @@ gpd = function(threshold=0,
if(!length(etastart)) {
meany = mean(ystar)
vary = var(ystar)
- xiinit = if(length(.ishape)) .ishape else {
+ xiinit = if(length( .ishape)) .ishape else {
if( .method.init == 1) -0.5*(meany^2/vary - 1) else
0.5 * (1 - median(ystar)^2 / vary)
}
- siginit = if(length(.iscale)) .iscale else {
+ siginit = if(length( .iscale)) .iscale else {
if(.method.init==1) 0.5*meany*(meany^2/vary + 1) else
abs(1-xiinit) * median(ystar)
}
@@ -1376,8 +1376,8 @@ egumbel = function(llocation="identity",
sc.init = if(is.Numeric( .iscale, posit=TRUE))
.iscale else 1.5 * (0.01+sqrt(var(y)*6)) / pi
sc.init = rep(sc.init, len=n)
- Euler = 0.57721566490153286
- loc.init = (y - sc.init * Euler)
+ EulerM = -digamma(1)
+ loc.init = (y - sc.init * EulerM)
etastart = cbind(theta2eta(loc.init, .llocation, earg= .elocation),
theta2eta(sc.init, .lscale, earg= .escale ))
}
@@ -1387,11 +1387,11 @@ egumbel = function(llocation="identity",
inverse=eval(substitute( function(eta, extra=NULL) {
loc = eta2theta(eta[,1], .llocation, earg= .elocation)
sigma = eta2theta(eta[,2], .lscale, earg= .escale )
- Euler = 0.57721566490153286
+ EulerM = -digamma(1)
Percentiles = extra$percentiles
mpv = extra$mpv
lp = length(Percentiles) # may be 0
- if(!lp) return(loc + sigma * Euler)
+ if(!lp) return(loc + sigma * EulerM)
mu = matrix(as.numeric(NA), nrow(eta), lp + mpv)
Rvec = extra$R
if(1 <= lp)
@@ -1507,8 +1507,8 @@ cgumbel = function(llocation="identity",
sc.init = if(is.Numeric( .iscale, posit=TRUE))
.iscale else 1.1 * sqrt(var(y) * 6 ) / pi
sc.init = rep(sc.init, len=n)
- Euler = 0.57721566490153286
- loc.init = (y - sc.init * Euler)
+ EulerM = -digamma(1)
+ loc.init = (y - sc.init * EulerM)
loc.init[loc.init <= 0] = min(y)
etastart = cbind(theta2eta(loc.init, .llocation, earg= .elocation ),
theta2eta(sc.init, .lscale, earg= .escale ))
@@ -1519,8 +1519,8 @@ cgumbel = function(llocation="identity",
inverse=eval(substitute( function(eta, extra=NULL) {
loc = eta2theta(eta[,1], .llocation)
sc = eta2theta(eta[,2], .lscale)
- Euler = 0.57721566490153286
- if(.mean) loc + sc * Euler else {
+ EulerM = -digamma(1)
+ if(.mean) loc + sc * EulerM else {
lp = length(.percentiles) # 0 if NULL
mu = matrix(as.numeric(NA), nrow(eta), lp)
for(i in 1:lp) {
@@ -1556,7 +1556,7 @@ cgumbel = function(llocation="identity",
Fy = exp(-exp(-zedd))
ell1 = -log(sc[cen0]) - zedd[cen0] - exp(-zedd[cen0])
ell2 = log(Fy[cenL])
- ell3 = log(1 - Fy[cenU])
+ ell3 = log1p(-Fy[cenU])
if(residuals) stop("loglikelihood residuals not implemented yet") else
sum(w[cen0] * ell1) + sum(w[cenL] * ell2) + sum(w[cenU] * ell3)
}, list( .lscale=lscale,
@@ -1977,7 +1977,7 @@ recnormal1 = function(lmean="identity", lsd="loge",
zedd = (y - mu) / sd
NN = nrow(eta)
sum(w * (-log(sd) - 0.5 * zedd^2)) -
- sum(w[-NN] * (log(1 - pnorm(zedd[-NN]))))
+ sum(w[-NN] * (log1p(-pnorm(zedd[-NN]))))
}
}, list( .lsd=lsd ))),
vfamily=c("recnormal1"),
@@ -2140,13 +2140,13 @@ exbilogi <- function(zero=c(3,6,7),
stop("the response must be a two-column matrix")
if(!length(etastart)) {
- Euler = 0.57721566490153286
+ EulerM = -digamma(1)
# Initial values for limiting case as xi --> 0, r_i==1
sig1.init = sqrt(6 * var(y[,1]))/pi
- mu1.init = median(y[,1]) - Euler * sig1.init
+ mu1.init = median(y[,1]) - EulerM * sig1.init
xi1.init = if(length(.ishape1)) .ishape1 else 0.1
sig2.init = sqrt(6 * var(y[,2]))/pi
- mu2.init = median(y[,2]) - Euler * sig2.init
+ mu2.init = median(y[,2]) - EulerM * sig2.init
xi2.init = if(length(.ishape2)) .ishape2 else 0.1
alpha.init = if(length(.idependency)) .idependency else 1
etastart = cbind(rep(theta2eta(mu1.init, .llocation), nrow(y)),
@@ -2196,7 +2196,7 @@ exbilogi <- function(zero=c(3,6,7),
zedds = (y - mmus) / sigmas
V = (zedds[,1]^(1/alpha) + zedds[,2]^(1/alpha))^alpha
if(residuals) stop("loglikelihood residuals not implemented yet") else
- sum(w * (log(1-alpha) - log(alpha) -
+ sum(w * (log1p(-alpha) - log(alpha) -
log(sigmas[,1]) - log(sigmas[,2]) +
(xis[,1] + 1/alpha) * log(zedds[,1]) +
(xis[,2] + 1/alpha) * log(zedds[,2]) +
@@ -2271,3 +2271,106 @@ exbilogi <- function(zero=c(3,6,7),
+poissonp = function(ostatistic, dimension=2, link="loge", earg=list(),
+ idensity=NULL, method.init=1) {
+ if(!is.Numeric(ostatistic, posit=TRUE, allow=1, integ=TRUE))
+ stop("argument 'ostatistic' must be a single positive integer")
+ if(!is.Numeric(dimension, posit=TRUE, allow=1, integ=TRUE) ||
+ dimension > 3)
+ stop("argument 'dimension' must be 2 or 3")
+ if(mode(link) != "character" && mode(link) != "name")
+ link = as.character(substitute(link))
+ if(!is.list(earg)) earg = list()
+ if(!is.Numeric(method.init, allow=1, posit=TRUE, integer=TRUE) ||
+ method.init > 2.5)
+ stop("argument \"method.init\" must be 1 or 2")
+ if(length(idensity) && !is.Numeric(idensity, posit=TRUE))
+ stop("bad input for argument \"idensity\"")
+
+ new("vglmff",
+ blurb=c(if(dimension==2)
+ "Poisson-points-on-a-plane distances distribution\n" else
+ "Poisson-points-on-a-volume distances distribution\n",
+ "Link: ",
+ namesof("density", link, earg=earg), "\n\n",
+ if(dimension==2)
+ "Mean: gamma(s+0.5) / (gamma(s) * sqrt(density * pi))" else
+ "Mean: gamma(s+1/3) / (gamma(s) * (4*density*pi/3)^(1/3))"),
+ initialize=eval(substitute(expression({
+ if(ncol(cbind(y)) != 1)
+ stop("response must be a vector or a one-column matrix")
+ if(any(y <= 0))
+ stop("response must contain positive values only")
+ predictors.names = namesof("density", .link, earg=.earg, tag=FALSE)
+ if(!length(etastart)) {
+ use.this = if( .method.init == 1) median(y) + 1/8 else
+ weighted.mean(y,w)
+ if( .dimension == 2) {
+ myratio = exp(lgamma( .ostatistic +0.5) - lgamma( .ostatistic))
+ density.init = if(is.Numeric( .idensity))
+ rep( .idensity, len=n) else
+ rep(myratio^2 / (pi * use.this^2), len=n)
+ etastart = theta2eta(density.init, .link, earg= .earg)
+ } else {
+ myratio = exp(lgamma( .ostatistic +1/3) - lgamma( .ostatistic))
+ density.init = if(is.Numeric( .idensity))
+ rep( .idensity, len=n) else
+ rep(3 * myratio^3 / (4 * pi * use.this^3), len=n)
+ etastart = theta2eta(density.init, .link, earg= .earg)
+ }
+ }
+ }), list( .link=link, .earg=earg, .ostatistic=ostatistic,
+ .dimension=dimension, .method.init=method.init,
+ .idensity=idensity ))),
+ inverse=eval(substitute(function(eta, extra=NULL) {
+ density = eta2theta(eta, .link, earg= .earg)
+ if( .dimension == 2) {
+ myratio = exp(lgamma( .ostatistic +0.5) - lgamma( .ostatistic ))
+ myratio / sqrt(density * pi)
+ } else {
+ myratio = exp(lgamma( .ostatistic +1/3) - lgamma( .ostatistic))
+ myratio / (4*density * pi/3)^(1/3)
+ }
+ }, list( .link=link, .earg=earg, .ostatistic=ostatistic,
+ .dimension=dimension ))),
+ last=eval(substitute(expression({
+ misc$link = c("density"= .link)
+ misc$earg = list("density"= .earg)
+ misc$expected = TRUE
+ misc$ostatistic = .ostatistic
+ misc$dimension = .dimension
+ }), list( .link=link, .earg=earg, .ostatistic=ostatistic,
+ .dimension=dimension ))),
+ loglikelihood=eval(substitute(
+ function(mu,y,w,residuals= FALSE,eta, extra=NULL) {
+ density = eta2theta(eta, .link, earg= .earg)
+ if(residuals) stop("loglikelihood residuals not implemented yet") else
+ if( .dimension == 2)
+ sum(w * (log(2) + .ostatistic * log(pi * density) -
+ lgamma( .ostatistic) + (2* .ostatistic-1) * log(y) -
+ density * pi * y^2)) else
+ sum(w * (log(3) + .ostatistic * log(4*pi * density/3) -
+ lgamma( .ostatistic) + (3* .ostatistic-1) * log(y) -
+ (4/3) * density * pi * y^3))
+ }, list( .link=link, .earg=earg, .ostatistic=ostatistic,
+ .dimension=dimension ))),
+ vfamily=c("poissonp"),
+ deriv=eval(substitute(expression({
+ density = eta2theta(eta, .link, earg= .earg)
+ if( .dimension == 2) {
+ dl.ddensity = .ostatistic / density - pi * y^2
+ } else {
+ dl.ddensity = .ostatistic / density - (4/3) * pi * y^3
+ }
+ ddensity.deta = dtheta.deta(density, .link, earg= .earg)
+ w * dl.ddensity * ddensity.deta
+ }), list( .link=link, .earg=earg, .ostatistic=ostatistic,
+ .dimension=dimension ))),
+ weight=eval(substitute(expression({
+ ed2l.ddensity2 = .ostatistic / density^2
+ wz = ddensity.deta^2 * ed2l.ddensity2
+ w * wz
+ }), list( .link=link, .earg=earg, .ostatistic=ostatistic,
+ .dimension=dimension ))))
+}
+
diff --git a/R/family.functions.q b/R/family.functions.q
index 6a4840c..8861fa4 100644
--- a/R/family.functions.q
+++ b/R/family.functions.q
@@ -85,7 +85,7 @@ eij = function(i, n) {
dneg.binomial <- function(x, k, prob)
{
- care.exp(x * log(1-prob) + k * log(prob) + lgamma(x+k) - lgamma(k) -
+ care.exp(x * log1p(-prob) + k * log(prob) + lgamma(x+k) - lgamma(k) -
lgamma(x+1))
}
diff --git a/R/family.glmgam.q b/R/family.glmgam.q
index 34706ba..87d7d02 100644
--- a/R/family.glmgam.q
+++ b/R/family.glmgam.q
@@ -137,8 +137,8 @@ binomialff <- function(link="logit", earg=list(),
nz <- y != 0
devy[nz] <- y[nz] * log(y[nz])
nz <- (1 - y) != 0
- devy[nz] <- devy[nz] + (1 - y[nz]) * log(1 - y[nz])
- devmu <- y * log(mu) + (1 - y) * log(1 - mu)
+ devy[nz] <- devy[nz] + (1 - y[nz]) * log1p(-y[nz])
+ devmu <- y * log(mu) + (1 - y) * log1p(-mu)
if(any(small <- mu * (1 - mu) < .Machine$double.eps)) {
warning("fitted values close to 0 or 1")
smu <- mu[small]
@@ -255,7 +255,7 @@ binomialff <- function(link="logit", earg=list(),
, list( .link=link, .earg = earg ))),
loglikelihood= function(mu, y, w, residuals = FALSE, eta, extra=NULL) {
if(residuals) w*(y/mu - (1-y)/(1-mu)) else
- sum(w*(y*log(mu) + (1-y)*log(1-mu)))
+ sum(w*(y*log(mu) + (1-y)*log1p(-mu)))
},
vfamily=c("binomialff", "vcategorical"),
deriv=eval(substitute(expression({
@@ -266,7 +266,7 @@ binomialff <- function(link="logit", earg=list(),
smallno = 100 * .Machine$double.eps
mu.use[mu.use < smallno] = smallno
mu.use[mu.use > 1 - smallno] = 1 - smallno
- -w * (y - mu) * log(1 - mu.use) / mu.use
+ -w * (y - mu) * log1p(-mu.use) / mu.use
} else
w * dtheta.deta(mu, link= .link, earg = .earg )* (y/mu - 1)/(1-mu)
}), list( .link=link, .earg = earg ))),
@@ -276,7 +276,7 @@ binomialff <- function(link="logit", earg=list(),
tmp200 = if( .link == "logit") {
cbind(w * tmp100)
} else if( .link == "cloglog") {
- cbind(w * (1-mu.use) * (log(1-mu.use))^2 / mu.use )
+ cbind(w * (1-mu.use) * (log1p(-mu.use))^2 / mu.use )
} else {
cbind(w * dtheta.deta(mu, link= .link, earg = .earg)^2 / tmp100)
}
@@ -661,6 +661,7 @@ poissonff <- function(link="loge", earg=list(),
w * tmp600
} else {
d2l.dlambda2 = 1 / lambda
+ d2lambda.deta2=d2theta.deta2(theta=lambda,link= .link,earg= .earg)
w * dlambda.deta^2 * d2l.dlambda2
}
}), list( .link=link, .earg=earg ))))
@@ -851,3 +852,215 @@ poissonqn <- function(link="loge", earg=list(),
}
+
+
+
+
+dexppoisson <- function(lmean="loge", emean=list(),
+ ldispersion="logit", edispersion=list(),
+ idispersion=0.8,
+ zero=NULL)
+{
+ if(mode(lmean)!= "character" && mode(lmean)!= "name")
+ lmean = as.character(substitute(lmean))
+ if(mode(ldispersion)!= "character" && mode(ldispersion)!= "name")
+ ldispersion = as.character(substitute(ldispersion))
+ if(!is.Numeric(idispersion, posit=TRUE))
+ stop("bad input for 'idispersion'")
+ if(!is.list(emean)) emean = list()
+ if(!is.list(edispersion)) edispersion = list()
+
+ new("vglmff",
+ blurb=c("Double Exponential Poisson distribution\n\n",
+ "Link: ",
+ namesof("mean", lmean, earg= emean), ", ",
+ namesof("dispersion", lmean, earg= edispersion), "\n",
+ "Mean: ", "mean\n",
+ "Variance: mean / dispersion"),
+ 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")
+ M = if(is.matrix(y)) ncol(y) else 1
+ dn2 = if(is.matrix(y)) dimnames(y)[[2]] else NULL
+ dn2 = if(length(dn2)) {
+ paste("E[", dn2, "]", sep="")
+ } else {
+ "mu"
+ }
+ predictors.names =
+ c(namesof(dn2, link= .lmean, earg= .emean, short=TRUE),
+ namesof("dispersion", link= .ldispersion,
+ earg= .edispersion, short=TRUE))
+ init.mu = pmax(y, 1/8)
+ if(!length(etastart))
+ etastart = cbind(theta2eta(init.mu, link= .lmean,earg= .emean),
+ theta2eta(rep( .idispersion, len=n),
+ link= .ldispersion, earg= .edispersion))
+ }), list( .lmean=lmean, .emean=emean,
+ .ldispersion=ldispersion, .edispersion=edispersion,
+ .idispersion=idispersion ))),
+ inverse=eval(substitute(function(eta, extra=NULL) {
+ eta2theta(eta[,1], link= .lmean, earg= .emean)
+ }, list( .lmean=lmean, .emean=emean,
+ .ldispersion=ldispersion, .edispersion=edispersion ))),
+ last=eval(substitute(expression({
+ misc$expected = TRUE
+ misc$link = c("mean"= .lmean, "dispersion"= .ldispersion)
+ misc$earg = list(mean= .emean, dispersion= .edispersion)
+ }), list( .lmean=lmean, .emean=emean,
+ .ldispersion=ldispersion, .edispersion=edispersion ))),
+ loglikelihood=eval(substitute(
+ function(mu, y, w, residuals = FALSE, eta, extra=NULL) {
+ lambda = eta2theta(eta[,1], link= .lmean, earg= .emean)
+ Disper = eta2theta(eta[,2], link= .ldispersion, earg= .edispersion)
+ if(residuals) stop("loglikelihood residuals not implemented yet") else {
+ sum(w*(0.5*log(Disper) + Disper*(y-lambda) + Disper*y*log(lambda)))
+ }
+ }, list( .lmean=lmean, .emean=emean,
+ .ldispersion=ldispersion, .edispersion=edispersion ))),
+ vfamily="dexppoisson",
+ deriv=eval(substitute(expression({
+ lambda = eta2theta(eta[,1], link= .lmean, earg= .emean)
+ Disper = eta2theta(eta[,2], link= .ldispersion, earg= .edispersion)
+ dl.dlambda = Disper * (y / lambda - 1)
+ dl.dDisper = y * log(lambda) + y - lambda + 0.5 / Disper
+ dlambda.deta = dtheta.deta(theta=lambda, link= .lmean, earg= .emean)
+ dDisper.deta = dtheta.deta(theta=Disper, link= .ldispersion,
+ earg= .edispersion)
+ w * cbind(dl.dlambda * dlambda.deta,
+ dl.dDisper * dDisper.deta)
+ }), list( .lmean=lmean, .emean=emean,
+ .ldispersion=ldispersion, .edispersion=edispersion ))),
+ weight=eval(substitute(expression({
+ wz = matrix(as.numeric(NA), nrow=n, ncol=2) # diagonal
+ usethis.lambda = pmax(lambda, .Machine$double.eps / 10000)
+ wz[,iam(1,1,M)] = (Disper / usethis.lambda) * dlambda.deta^2
+ wz[,iam(2,2,M)] = (0.5 / Disper^2) * dDisper.deta^2
+ w * wz
+ }), list( .lmean=lmean, .emean=emean,
+ .ldispersion=ldispersion, .edispersion=edispersion ))))
+}
+
+
+
+dexpbinomial <- function(lmean="logit", ldispersion="logit",
+ emean=list(), edispersion=list(),
+ idispersion=0.25,
+ zero=2)
+{
+ if(mode(lmean)!= "character" && mode(lmean)!= "name")
+ lmean = as.character(substitute(lmean))
+ if(mode(ldispersion)!= "character" && mode(ldispersion)!= "name")
+ ldispersion = as.character(substitute(ldispersion))
+ if(!is.Numeric(idispersion, posit=TRUE))
+ stop("bad input for 'idispersion'")
+ if(!is.list(emean)) emean = list()
+ if(!is.list(edispersion)) edispersion = list()
+
+ new("vglmff",
+ blurb=c("Double Exponential Binomial distribution\n\n",
+ "Link: ",
+ namesof("mean", lmean, earg= emean), ", ",
+ namesof("dispersion", lmean, earg= edispersion), "\n",
+ "Mean: ", "mean\n"),
+ constraints=eval(substitute(expression({
+ constraints = cm.zero.vgam(constraints, x, .zero, M)
+ }), list( .zero=zero ))),
+ initialize=eval(substitute(expression({
+ if(ncol(cbind(w)) != 1)
+ stop("'weights' must be a vector or a one-column matrix")
+
+ NCOL = function (x)
+ if(is.array(x) && length(dim(x)) > 1 ||
+ is.data.frame(x)) ncol(x) else as.integer(1)
+
+ if(NCOL(y) == 1) {
+ if(is.factor(y)) y = y != levels(y)[1]
+ nn = rep(1, n)
+ if(!all(y >= 0 & y <= 1))
+ stop("response values must be in [0, 1]")
+ init.mu = (0.5 + w * y) / (1 + w)
+ no.successes = w * y
+ if(any(abs(no.successes - round(no.successes)) > 0.001))
+ stop("Number of successes must be integer-valued")
+ } else if(NCOL(y) == 2) {
+ if(any(abs(y - round(y)) > 0.001))
+ stop("Count data must be integer-valued")
+ nn = y[,1] + y[,2]
+ y = ifelse(nn > 0, y[,1]/nn, 0)
+ w = w * nn
+ init.mu = (0.5 + nn * y) / (1 + nn)
+ } else
+ stop("Response not of the right form")
+
+
+ dn2 = if(is.matrix(y)) dimnames(y)[[2]] else NULL
+ dn2 = if(length(dn2)) {
+ paste("E[", dn2, "]", sep="")
+ } else {
+ "mu"
+ }
+ predictors.names =
+ c(namesof(dn2, link= .lmean, earg= .emean, short=TRUE),
+ namesof("dispersion", link= .ldispersion,
+ earg= .edispersion, short=TRUE))
+ if(!length(etastart))
+ etastart = cbind(theta2eta(init.mu, link= .lmean,earg= .emean),
+ theta2eta(rep( .idispersion, len=n),
+ link= .ldispersion, earg= .edispersion))
+ }), list( .lmean=lmean, .emean=emean,
+ .ldispersion=ldispersion, .edispersion=edispersion,
+ .idispersion=idispersion ))),
+ inverse=eval(substitute(function(eta, extra=NULL) {
+ eta2theta(eta[,1], link= .lmean, earg= .emean)
+ }, list( .lmean=lmean, .emean=emean,
+ .ldispersion=ldispersion, .edispersion=edispersion ))),
+ last=eval(substitute(expression({
+ misc$expected = TRUE
+ misc$link = c("mean"= .lmean, "dispersion"= .ldispersion)
+ misc$earg = list(mean= .emean, dispersion= .edispersion)
+ }), list( .lmean=lmean, .emean=emean,
+ .ldispersion=ldispersion, .edispersion=edispersion ))),
+ loglikelihood=eval(substitute(
+ function(mu, y, w, residuals = FALSE, eta, extra=NULL) {
+ prob = eta2theta(eta[,1], link= .lmean, earg= .emean)
+ Disper = eta2theta(eta[,2], link= .ldispersion, earg= .edispersion)
+ if(residuals) stop("loglikelihood residuals not implemented yet") else {
+ temp1 = y * log(ifelse(y > 0, y, 1)) # y*log(y)
+ temp2 = (1.0-y) * log1p(ifelse(y < 1, -y, 0)) # (1-y)*log(1-y)
+ sum(0.5*log(Disper) + w*(y*Disper*log(prob) +
+ (1-y)*Disper*log1p(-prob) +
+ temp1*(1-Disper) + temp2*(1-Disper)))
+ }
+ }, list( .lmean=lmean, .emean=emean,
+ .ldispersion=ldispersion, .edispersion=edispersion ))),
+ vfamily="dexpbinomial",
+ deriv=eval(substitute(expression({
+ prob = eta2theta(eta[,1], link= .lmean, earg= .emean)
+ Disper = eta2theta(eta[,2], link= .ldispersion, earg= .edispersion)
+ temp1 = y * log(ifelse(y > 0, y, 1)) # y*log(y)
+ temp2 = (1.0-y) * log1p(ifelse(y < 1, -y, 0)) # (1-y)*log(1-y)
+ temp3 = prob * (1.0-prob)
+ temp3 = pmax(temp3, .Machine$double.eps * 10000)
+ dl.dprob = w * Disper * (y - prob) / temp3
+ dl.dDisper = 0.5 / Disper + w * (y * log(prob) +
+ (1-y)*log1p(-prob) - temp1 - temp2)
+ dprob.deta = dtheta.deta(theta=prob, link= .lmean, earg= .emean)
+ dDisper.deta = dtheta.deta(theta=Disper, link= .ldispersion,
+ earg= .edispersion)
+ cbind(dl.dprob * dprob.deta,
+ dl.dDisper * dDisper.deta)
+ }), list( .lmean=lmean, .emean=emean,
+ .ldispersion=ldispersion, .edispersion=edispersion ))),
+ weight=eval(substitute(expression({
+ wz = matrix(as.numeric(NA), nrow=n, ncol=2) # diagonal
+ wz[,iam(1,1,M)] = w * (Disper / temp3) * dprob.deta^2
+ wz[,iam(2,2,M)] = (0.5 / Disper^2) * dDisper.deta^2
+ wz
+ }), list( .lmean=lmean, .emean=emean,
+ .ldispersion=ldispersion, .edispersion=edispersion ))))
+}
+
diff --git a/R/family.mixture.q b/R/family.mixture.q
index e93e583..9f948d4 100644
--- a/R/family.mixture.q
+++ b/R/family.mixture.q
@@ -213,7 +213,7 @@ mix2poisson = function(lphi="logit", llambda="loge",
new("vglmff",
blurb=c("Mixture of two univariate normals\n\n",
"Links: ",
- namesof("phi",lphi, earg= .ephi), ", ",
+ 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",
@@ -313,3 +313,176 @@ mix2poisson = function(lphi="logit", llambda="loge",
}
+mix2exp = function(lphi="logit", llambda="loge",
+ ephi=list(), el1=list(), el2=list(),
+ iphi=0.5, il1=NULL, il2=NULL,
+ qmu=c(0.2, 0.8), zero=1)
+{
+ if(mode(lphi) != "character" && mode(lphi) != "name")
+ lphi = as.character(substitute(lphi))
+ if(mode(llambda) != "character" && mode(llambda) != "name")
+ llambda = as.character(substitute(llambda))
+ if(!is.Numeric(qmu, allow=2, positive=TRUE) || any(qmu >= 1))
+ stop("bad input for argument \"qmu\"")
+ if(length(iphi) && (!is.Numeric(iphi, allow=1, positive=TRUE) || iphi>= 1))
+ stop("bad input for argument \"iphi\"")
+ if(length(il1) && !is.Numeric(il1))
+ stop("bad input for argument \"il1\"")
+ if(length(il2) && !is.Numeric(il2))
+ stop("bad input for argument \"il2\"")
+ if(!is.list(ephi)) ephi = list()
+ if(!is.list(el1)) el1 = list()
+ if(!is.list(el2)) el2 = list()
+
+ new("vglmff",
+ blurb=c("Mixture of two univariate exponentials\n\n",
+ "Links: ",
+ namesof("phi", lphi, earg= ephi), ", ",
+ namesof("lambda1", llambda, earg= el1, tag=FALSE), ", ",
+ namesof("lambda2", llambda, earg= el2, tag=FALSE), "\n",
+ "Mean: phi/lambda1 + (1-phi)/lambda2\n"),
+ constraints=eval(substitute(expression({
+ constraints = cm.zero.vgam(constraints, x, .zero, M)
+ }), list(.zero=zero ))),
+ initialize=eval(substitute(expression({
+ if(ncol(y <- cbind(y)) != 1)
+ stop("the response must be a vector or one-column matrix")
+ predictors.names = c(namesof("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 {
+ 0.5
+ }
+ init.lambda1 = if(length(.il1)) rep(.il1, length=n) else {
+ rep(qy[1], length=n)
+ }
+ init.lambda2 = if(length(.il2)) rep(.il2, length=n) else {
+ rep(qy[2], length=n)
+ }
+ etastart = cbind(theta2eta(init.phi, .lphi, earg= .ephi),
+ theta2eta(init.lambda1, .llambda, earg= .el1),
+ theta2eta(init.lambda2, .llambda, earg= .el2))
+ print("etastart[1:4,]")
+ print( etastart[1:4,] )
+ }
+ }), list(.lphi=lphi, .llambda=llambda, .iphi=iphi, .il1=il1, .il2=il2,
+ .ephi=ephi, .el1=el1, .el2=el2,
+ .qmu=qmu))),
+ inverse=eval(substitute(function(eta, extra=NULL){
+ phi = eta2theta(eta[,1], link= .lphi, earg= .ephi)
+ lambda1 = eta2theta(eta[,2], link= .llambda, earg= .el1)
+ lambda2 = eta2theta(eta[,3], link= .llambda, earg= .el2)
+ phi/lambda1 + (1-phi)/lambda2
+ }, list(.lphi=lphi, .llambda=llambda,
+ .ephi=ephi, .el1=el1, .el2=el2 ))),
+ last=eval(substitute(expression({
+ misc$link = c("phi"= .lphi, "lambda1"= .llambda, "lambda2"= .llambda)
+ misc$earg = list("phi"= .ephi, "lambda1"= .el1, "lambda2"= .el2)
+ misc$expected = FALSE
+ misc$pooled.weight = pooled.weight
+ }), 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, earg= .ephi)
+ lambda1 = eta2theta(eta[,2], link= .llambda, earg= .el1)
+ lambda2 = eta2theta(eta[,3], link= .llambda, earg= .el2)
+ f1 = dexp(y, rate=lambda1)
+ f2 = dexp(y, rate=lambda2)
+ if(residuals) stop("loglikelihood residuals not implemented yet") else
+ sum(w * log(phi*f1 + (1-phi)*f2))
+ }, list(.lphi=lphi, .llambda=llambda,
+ .ephi=ephi, .el1=el1, .el2=el2 ))),
+ vfamily=c("mix2exp"),
+ deriv=eval(substitute(expression({
+ phi = eta2theta(eta[,1], link= .lphi, earg= .ephi)
+ lambda1 = eta2theta(eta[,2], link= .llambda, earg= .el1)
+ lambda2 = eta2theta(eta[,3], link= .llambda, earg= .el2)
+ pdf1 = dexp(x=y, rate=lambda1) * phi
+ pdf2 = dexp(x=y, rate=lambda2) * (1-phi)
+ delta = pdf1 / (pdf1 + pdf2)
+ expy = phi / lambda1 + (1-phi) / lambda2 # E(Y)
+ expy2 = phi * 2 / lambda1^2 + (1-phi) * 2 / lambda2^2 # E(Y^2)
+ dl.dphi = (delta - phi) / (phi * (1-phi))
+ dl.dlambda1 = -(y - 1/lambda1) * delta
+ dl.dlambda2 = -(y - 1/lambda2) * (1-delta)
+ dphi.deta = dtheta.deta(phi, link= .lphi, earg= .ephi)
+ dlambda1.deta = dtheta.deta(lambda1, link= .llambda, earg= .el1)
+ dlambda2.deta = dtheta.deta(lambda2, link= .llambda, earg= .el2)
+ w * cbind(dl.dphi * dphi.deta,
+ dl.dlambda1 * dlambda1.deta,
+ dl.dlambda2 * dlambda2.deta)
+ }), list(.lphi=lphi, .llambda=llambda,
+ .ephi=ephi, .el1=el1, .el2=el2 ))),
+ weight = eval(substitute(expression({
+ d2phi.deta2 = d2theta.deta2(phi, link= .lphi, earg= .ephi)
+ d2lambda1.deta2 = d2theta.deta2(lambda1, link= .llambda, earg= .el1)
+ d2lambda2.deta2 = d2theta.deta2(lambda2, link= .llambda, earg= .el2)
+ wz = matrix(0, n, dimm(M))
+ d2l.dphi2 = ((delta-phi) / (phi*(1-phi)))^2
+ d2l.dlambda12 = delta / lambda1^2 - delta * (1-delta) *
+ (y - 1 / lambda1)^2
+ d2l.dlambda22 = (1-delta) / lambda2^2 - delta * (1-delta) *
+ (y - 1 / lambda2)^2
+ d2l.dphidlambda1 = delta * (1-delta) *
+ (y - 1 / lambda1) / (phi * (1-phi))
+ d2l.dphidlambda2 = -delta * (1-delta) *
+ (y - 1 / lambda2) / (phi * (1-phi))
+ d2l.dlambda1dlambda2 = delta * (1-delta) *
+ (y - 1 / lambda1) * (y - 1 / lambda2)
+ wz[,iam(1,1,M)] = d2l.dphi2 * dphi.deta^2 - dl.dphi * d2phi.deta2
+ wz[,iam(2,2,M)] = d2l.dlambda12 * dlambda1.deta^2 -
+ dl.dlambda1 * d2lambda1.deta2
+ wz[,iam(3,3,M)] = d2l.dlambda22 * dlambda2.deta^2 -
+ dl.dlambda2 * d2lambda2.deta2
+ wz[,iam(1,2,M)] = d2l.dphidlambda1 * dphi.deta * dlambda1.deta
+ wz[,iam(1,3,M)] = d2l.dphidlambda2 * dphi.deta * dlambda2.deta
+ wz[,iam(2,3,M)] = d2l.dlambda1dlambda2 * dlambda1.deta * dlambda2.deta
+ wz = w * wz
+
+
+
+
+ wz = matrix(0, n, dimm(M))
+ d2l.dphi2 = ((delta-phi) / (phi*(1-phi)))^2
+ d2l.dlambda12 = delta / lambda1^2 - delta * (1-delta) *
+ (expy2 - 2 * expy / lambda1 + 1/lambda1^2)
+ d2l.dlambda22 = (1-delta) / lambda2^2 - delta * (1-delta) *
+ (expy2 - 2 * expy / lambda2 + 1/lambda2^2)
+ d2l.dphidlambda1 = delta * (1-delta) *
+ (expy - 1 / lambda1) / (phi * (1-phi))
+ d2l.dphidlambda2 = -delta * (1-delta) *
+ (expy - 1 / lambda2) / (phi * (1-phi))
+ d2l.dlambda1dlambda2 = delta * (1-delta) *
+ (expy2 - expy / lambda1 - expy / lambda2 +
+ 1 / (lambda1 * lambda2))
+ wz[,iam(1,1,M)] = d2l.dphi2 * dphi.deta^2
+ wz[,iam(2,2,M)] = d2l.dlambda12 * dlambda1.deta^2
+ wz[,iam(3,3,M)] = d2l.dlambda22 * dlambda2.deta^2
+ wz[,iam(1,2,M)] = d2l.dphidlambda1 * dphi.deta * dlambda1.deta
+ wz[,iam(1,3,M)] = d2l.dphidlambda2 * dphi.deta * dlambda2.deta
+ wz[,iam(2,3,M)] = d2l.dlambda1dlambda2 * dlambda1.deta * dlambda2.deta
+ print("wz[1:3,]")
+ print( wz[1:3,] )
+ wz = w * wz
+
+
+
+ if(TRUE && intercept.only) {
+ sumw = sum(w)
+ for(i in 1:ncol(wz))
+ wz[,i] = sum(wz[,i]) / sumw
+ pooled.weight = TRUE
+ wz = w * wz # Put back the weights
+ } else
+ pooled.weight = FALSE
+ print("pooled wz[1:3,]")
+ print( wz[1:3,] )
+
+ wz
+ }), list(.lphi=lphi, .llambda=llambda,
+ .ephi=ephi, .el1=el1, .el2=el2))))
+}
+
diff --git a/R/family.normal.q b/R/family.normal.q
index 819f58b..914ccf0 100644
--- a/R/family.normal.q
+++ b/R/family.normal.q
@@ -78,7 +78,8 @@ gaussianff = function(dispersion=0, parallel=FALSE, zero=NULL)
if(!dpar) {
wz = VGAM.weights.function(w=w, M=M, n=n)
temp = rss.vgam(y-mu, wz=wz, M=M)
- dpar = temp / (length(y) - ncol(xbig.save))
+ dpar = temp / (length(y) -
+ (if(is.numeric(ncol(xbig.save))) ncol(xbig.save) else 0))
}
misc$dispersion = dpar
misc$default.dispersion = 0
@@ -212,7 +213,7 @@ posnormal1 = function(lmean="identity", lsd="loge",
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))))
+ sum(w*(-log(mysd)-0.5*((y-mymu)/mysd)^2 -log1p(-pnorm(-mymu/mysd))))
}
}, list( .lmean=lmean, .lsd=lsd, .emean=emean, .esd=esd ))),
vfamily=c("posnormal1"),
@@ -349,7 +350,7 @@ tikuv = function(d, lmean="identity", lsigma="loge",
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))
+ sum(w * (-log(sigma) + 2 * log1p(0.5*zedd^2 / hh) - 0.5*zedd^2))
}
}, list( .lmean=lmean, .lsigma=lsigma, .d=d,
.emean=emean, .esigma=esigma ))),
diff --git a/R/family.positive.q b/R/family.positive.q
index 972e668..b58b61c 100644
--- a/R/family.positive.q
+++ b/R/family.positive.q
@@ -64,7 +64,7 @@ posnegbinomial = function(lmunb = "loge", lk = "loge",
p0 = (kmat / (kmat + munb))^kmat
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)))) }
+ (if(is.R()) log1p(-p0) else log1p(-p0)))) }
k.grid = rvar = 2^((-3):6)
for(spp. in 1:NOS) {
@@ -117,7 +117,7 @@ posnegbinomial = function(lmunb = "loge", lk = "loge",
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))))
+ (if(is.R()) log1p(-p0) else log1p(-p0))))
}, list( .lmunb=lmunb, .lk=lk,
.emunb=emunb, .ek=ek ))),
vfamily=c("posnegbinomial"),
@@ -257,7 +257,7 @@ pospoisson = function(link="loge", earg=list())
function(mu,y,w,residuals=FALSE, eta,extra=NULL) {
lambda = eta2theta(eta, .link, earg= .earg )
if(residuals) stop("loglikelihood residuals not implemented yet") else
- sum(w * (-log(1-exp(-lambda)) - lambda + y*log(lambda)))
+ sum(w * (-log1p(-exp(-lambda)) - lambda + y*log(lambda)))
}, list( .link=link, .earg= earg ))),
vfamily=c("pospoisson"),
deriv=eval(substitute(expression({
@@ -308,7 +308,7 @@ posbinomial = function(link="logit", earg=list())
yi = round(y*w)
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))
+ sum(yi*log(theta)+(w-yi)*log1p(-theta)-log1p(-(1-theta)^w))
}, list( .link=link, .earg=earg ))),
vfamily=c("posbinomial"),
deriv=eval(substitute(expression({
diff --git a/R/family.qreg.q b/R/family.qreg.q
index cab9485..522374d 100644
--- a/R/family.qreg.q
+++ b/R/family.qreg.q
@@ -948,3 +948,212 @@ lms.yjn1 = function(percentiles=c(25,50,75),
+
+
+
+
+alsqreg <- function(w=1, method.init=1)
+{
+ w.arg = w
+ if(!is.Numeric(w.arg, posit=TRUE, allow=1))
+ stop("'w' must be a single positive number")
+ lmean = "identity"
+ emean = list()
+ if(!is.Numeric(method.init, allow=1, integ=TRUE, posit=TRUE) ||
+ method.init > 3) stop("argument \"method.init\" must be 1, 2 or 3")
+
+ new("vglmff",
+ blurb=c("Asymmetric least squares quantile regression\n\n"),
+ initialize=eval(substitute(expression({
+ predictors.names = c(namesof("w-regression plane",
+ .lmean, earg=.emean, tag=FALSE))
+ extra$w = .w.arg
+ if(ncol(y <- cbind(y)) != 1)
+ stop("response must be a vector or a one-column matrix")
+ if(!length(etastart)) {
+ mean.init = if( .method.init == 1)
+ rep(median(y), length=n) else if( .method.init == 2)
+ rep(weighted.mean(y, w), length=n) else {
+ junk = if(is.R()) lm.wfit(x=x, y=y, w=w) else
+ lm.wfit(x=x, y=y, w=w, method="qr")
+ junk$fitted
+ }
+ etastart = cbind(theta2eta(mean.init, .lmean, earg= .emean))
+ }
+ }), list( .lmean=lmean, .emean=emean, .method.init=method.init,
+ .w.arg=w.arg ))),
+ inverse=eval(substitute(function(eta, extra=NULL) {
+ eta2theta(eta, .lmean, earg= .emean)
+ }, list( .lmean=lmean, .emean=emean,
+ .w.arg=w.arg ))),
+ last=eval(substitute(expression({
+ misc$link = c("mu"= .lmean)
+ misc$earg = list("mu"= .emean)
+ misc$expected = TRUE
+ extra$percentile = 100 * weighted.mean(myresid <= 0, w)
+ }), list( .lmean=lmean, .emean=emean,
+ .w.arg=w.arg ))),
+ loglikelihood=eval(substitute(
+ function(mu,y,w,residuals= FALSE,eta, extra=NULL) {
+ if(residuals) stop("loglikelihood residuals not implemented yet") else {
+ Qw <- function(r, w, deriv.arg=0) {
+ Wr <- function(r, w) ifelse(r <= 0, 1, w)
+ switch(as.character(deriv.arg),
+ "0"= Wr(r, w) * r^2,
+ "1"= 2 * Wr(r, w) * r,
+ stop("'deriv' not matched"))
+ }
+ myresid = y - mu
+ -sum(w * Qw(myresid, .w.arg))
+ }
+ }, list( .lmean=lmean, .emean=emean,
+ .w.arg=w.arg ))),
+ vfamily=c("alsqreg"),
+ deriv=eval(substitute(expression({
+ Wr <- function(r, w) ifelse(r <= 0, 1, w)
+ mymu = eta2theta(eta, .lmean, earg= .emean)
+ myresid = y - mymu
+ temp1 = Wr(myresid, w= .w.arg)
+ w * myresid * temp1
+ }), list( .lmean=lmean, .emean=emean,
+ .w.arg=w.arg ))),
+ weight=eval(substitute(expression({
+ wz = w * temp1
+ wz
+ }), list( .lmean=lmean, .emean=emean,
+ .w.arg=w.arg ))))
+}
+
+
+
+
+
+
+alspoisson <- function(link="loge", earg=list(),
+ w=1, method.init=1)
+{
+ if(mode(link )!= "character" && mode(link )!= "name")
+ link <- as.character(substitute(link))
+ if(!is.list(earg)) earg = list()
+ w.arg = w
+ if(!is.Numeric(w.arg, posit=TRUE, allow=1))
+ stop("'w' must be a single positive number")
+ lmean = "identity"
+ emean = list()
+
+ new("vglmff",
+ blurb=c("Poisson distribution estimated by asymmetric least squares\n\n",
+ "Link: ", namesof("mu", link, earg= earg), "\n",
+ "Variance: mu"),
+ deviance= function(mu, y, w, residuals = FALSE, eta, extra=NULL) {
+ nz <- y > 0
+ devi <- - (y - mu)
+ devi[nz] <- devi[nz] + y[nz] * log(y[nz]/mu[nz])
+ if(residuals) sign(y - mu) * sqrt(2 * abs(devi) * w) else
+ 2 * sum(w * devi)
+ },
+ initialize=eval(substitute(expression({
+ if(ncol(cbind(y)) != 1)
+ stop("response must be a vector or a one-column matrix")
+ M = if(is.matrix(y)) ncol(y) else 1
+ dn2 = if(is.matrix(y)) dimnames(y)[[2]] else NULL
+ dn2 = if(length(dn2)) {
+ paste("E[", dn2, "]", sep="")
+ } else {
+ paste("mu", 1:M, sep="")
+ }
+ predictors.names = namesof(if(M>1) dn2 else "mu", .link,
+ earg= .earg, short=TRUE)
+ mu = pmax(y, 1/8)
+ if(!length(etastart))
+ etastart <- theta2eta(mu, link= .link, earg= .earg)
+ }), list( .link=link,
+ .earg=earg ))),
+ inverse=eval(substitute(function(eta, extra=NULL) {
+ mu = eta2theta(eta, link= .link, earg= .earg)
+ mu
+ }, list( .link=link, .earg=earg ))),
+ last=eval(substitute(expression({
+ misc$expected = TRUE
+ misc$link = rep( .link, length=M)
+ names(misc$link) = if(M>1) dn2 else "mu"
+
+ extra$percentile = 100 * weighted.mean(myresid <= 0, w)
+
+ 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 ))),
+ link=eval(substitute(function(mu, extra=NULL) {
+ theta2eta(mu, link= .link, earg= .earg)
+ }, list( .link=link, .earg=earg ))),
+
+
+ loglikelihood=eval(substitute(
+ function(mu,y,w,residuals= FALSE,eta, extra=NULL) {
+ if(residuals) stop("loglikelihood residuals not implemented yet") else {
+ Qw <- function(r, w, deriv.arg=0) {
+ Wr <- function(r, w) ifelse(r <= 0, 1, w)
+ switch(as.character(deriv.arg),
+ "0"= Wr(r, w) * r^2,
+ "1"= 2 * Wr(r, w) * r,
+ stop("'deriv' not matched"))
+ }
+ myresid = extra$z - mu
+ -sum(w * Qw(myresid, .w.arg))
+ }
+ }, list( .lmean=lmean, .emean=emean,
+ .w.arg=w.arg ))),
+
+ vfamily="alspoisson",
+
+ deriv=eval(substitute(expression({
+
+ if( iter > 1) extra$z = z
+ print("iter")
+ print( iter )
+
+ derivUsual =
+ if( .link == "loge" && (any(mu < .Machine$double.eps))) {
+ w * (y - mu)
+ } else {
+ lambda <- mu
+ dl.dlambda <- (y-lambda) / lambda
+ dlambda.deta <- dtheta.deta(theta=lambda, link= .link, earg= .earg)
+ w * dl.dlambda * dlambda.deta
+ }
+
+ if(iter > 1) {
+ Wr <- function(r, w) ifelse(r <= 0, 1, w)
+ mymu = eta2theta(eta, .lmean, earg= .emean)
+ myresid = z - mymu
+ temp1 = Wr(myresid, w= wzUsual) # zz should the wt be wzUsual??
+ temp1 = Wr(myresid, w= .w.arg) # zz should the wt be wzUsual??
+ }
+
+ if(iter %% 3 == 1) cat("=================\n")
+
+ if(iter %% 3 == 1) derivUsual else w * myresid * temp1
+ }), list( .link=link, .earg=earg, .w.arg=w.arg,
+ .lmean=lmean, .emean=emean ))),
+
+ weight=eval(substitute(expression({
+ wzUsual =
+ if( .link == "loge" && (any(mu < .Machine$double.eps))) {
+ tmp600 = mu
+ tmp600[tmp600 < .Machine$double.eps] = .Machine$double.eps
+ w * tmp600
+ } else {
+ d2l.dlambda2 = 1 / lambda
+ w * dlambda.deta^2 * d2l.dlambda2
+ }
+ if(iter %% 3 == 1) wzUsual else w * temp1
+ }), list( .link=link, .earg=earg,
+ .lmean=lmean, .emean=emean,
+ .w.arg=w.arg ))))
+
+}
+
+
+
+
diff --git a/R/family.rrr.q b/R/family.rrr.q
index a9c19da..10e3f70 100644
--- a/R/family.rrr.q
+++ b/R/family.rrr.q
@@ -1601,10 +1601,8 @@ get.rrvglm.se1 <- function(fit, omit13= FALSE, kill.all= FALSE,
}
if(!is.R()) {
- assign("zmat", zmat, frame = 1)
- assign("offs", offs, frame = 1)
- assign("wz", wz, frame = 1)
- assign("lv.mat", lv.mat, frame = 1)
+
+ stop("26-9-2007: uncomment out the following lines to run it in Splus")
}
fit1122 <- if(dspec) vlm(bb,
@@ -1950,7 +1948,7 @@ rrr.deriv.gradient.fast <- function(theta, wz, U, z, M, r, xmat,
}
coeffs <- vlm.wfit(xmat, z, Blist, U=U, matrix.out= TRUE,
- xij=xij)$mat.coef
+ xij=NULL)$mat.coef
c3 <- coeffs <- t(coeffs) # transpose to make M x (pp+1)
@@ -2758,7 +2756,7 @@ vcovqrrvglm = function(object,
len=M), ...) {
stop("this function is not yet completed")
- if(mode(MaxScale) != "character" && mode(link) != "name")
+ if(mode(MaxScale) != "character" && mode(MaxScale) != "name")
MaxScale <- as.character(substitute(MaxScale))
MaxScale <- match.arg(MaxScale, c("predictors", "response"))[1]
if(MaxScale != "predictors")
diff --git a/R/family.survival.q b/R/family.survival.q
index c18ab40..d64ca7c 100644
--- a/R/family.survival.q
+++ b/R/family.survival.q
@@ -62,7 +62,7 @@ dcnormal1 = function(r1=0, r2=0, link.sd="loge",
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)})
+ (if(.r2==0) 0 else {z2=max((y-mu)/sd); Fz2=pnorm(z2); .r2*log1p(-Fz2)})
} , list( .link.sd=link.sd, .r1=r1, .r2=r2,
.earg=earg ))),
vfamily=c("dcnormal1"),
@@ -114,7 +114,7 @@ dbisa = function(x, shape, scale=1, log = FALSE) {
if(!is.Numeric(scale, pos=TRUE)) stop("bad input for argument \"scale\"")
xifun = function(x) {temp <- sqrt(x); temp - 1/temp}
ans = if(log)
- dnorm(xifun(x/scale) / shape, log=TRUE) + log(1 + scale/x) - log(2) -
+ dnorm(xifun(x/scale) / shape, log=TRUE) + log1p(scale/x) - log(2) -
0.5 * log(x) - 0.5 * log(scale) - log(shape) else
dnorm(xifun(x/scale) / shape) * (1 + scale/x) / (2 * sqrt(x) *
sqrt(scale) * shape)
@@ -161,16 +161,10 @@ rbisa = function(n, shape, scale=1) {
-bisa.control <- function(save.weight=TRUE, ...)
-{
- list(save.weight=save.weight)
-}
-
-bisa = function(lshape="loge",
- lscale="loge",
+bisa = function(lshape = "loge", lscale = "loge",
eshape = list(), escale = list(),
- ishape=NULL, iscale=1,
- method.init=1, fsmax=9001, zero=NULL)
+ ishape = NULL, iscale=1,
+ method.init=1, zero=NULL)
{
if(mode(lshape) != "character" && mode(lshape) != "name")
lshape = as.character(substitute(lshape))
@@ -181,10 +175,8 @@ bisa = function(lshape="loge",
if(!is.Numeric(iscale, posit=TRUE))
stop("bad input for argument \"iscale\"")
if(!is.Numeric(method.init, allow=1, integ=TRUE, posit=TRUE) ||
- method.init > 2)
- stop("method.init must be 1 or 2")
- if(!is.Numeric(fsmax, allow=1, integ=TRUE))
- stop("bad input for \"fsmax\"")
+ method.init > 3)
+ stop("method.init must be 1 or 2 or 3")
if(!is.list(eshape)) eshape = list()
if(!is.list(escale)) escale = list()
@@ -199,48 +191,53 @@ bisa = function(lshape="loge",
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, earg= .eshape, tag= FALSE),
- namesof("scale", .lscale, tag= FALSE))
+ predictors.names = c(namesof("shape", .lshape,earg= .eshape,tag=FALSE),
+ namesof("scale", .lscale, tag=FALSE))
if(!length(etastart)) {
scale.init = rep( .iscale, len=n)
- shape.init = if( .method.init==2) sqrt(2*( pmax(y, scale.init+0.1) /
- scale.init - 1)) else {
- ybar = rep(weighted.mean(y, w), len=n)
- sqrt(2*( pmax(ybar, scale.init+0.1) / scale.init - 1))
+ shape.init = if(is.Numeric( .ishape)) rep( .ishape, len=n) else {
+ if( .method.init==1) {
+ ybar = rep(weighted.mean(y, w), len=n)
+ ybarr = rep(1 / weighted.mean(1/y, w), len=n) # Reqrs y > 0
+ sqrt(ybar / scale.init + scale.init / ybarr - 2)
+ } else if( .method.init==2) {
+ sqrt(2*( pmax(y, scale.init+0.1) / scale.init - 1))
+ } else {
+ 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, 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 ))),
+ }) , list( .lshape=lshape, .lscale=lscale,
+ .ishape=ishape, .iscale=iscale,
+ .eshape=eshape, .escale=escale,
+ .method.init=method.init ))),
inverse=eval(substitute(function(eta, extra=NULL) {
sh = eta2theta(eta[,1], .lshape, earg= .eshape)
sc = eta2theta(eta[,2], .lscale, earg= .escale)
sc * (1 + sh^2 / 2)
}, list( .lshape=lshape, .lscale=lscale,
- .eshape=eshape, .escale=escale ))),
+ .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
+ misc$expected = TRUE
}) , list( .lshape=lshape, .lscale=lscale,
- .eshape=eshape, .escale=escale ))),
+ .eshape=eshape, .escale=escale ))),
loglikelihood=eval(substitute(
function(mu,y,w,residuals= FALSE,eta, extra=NULL) {
sh = eta2theta(eta[,1], .lshape, earg= .eshape)
sc = eta2theta(eta[,2], .lscale, earg= .escale)
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)))
+ sum(w * (-log(sh) - 0.5 * log(sc) + log1p(sc/y) -
+ 0.5*log(8*pi) - 0.5 * log(y) -
+ (y/sc - 2 + sc/y) / (2*sh^2)))
} , 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, earg= .eshape)
sc = eta2theta(eta[,2], .lscale, earg= .escale)
dl.dsh = ((y/sc - 2 + sc/y) / sh^2 - 1) / sh
@@ -248,56 +245,18 @@ bisa = function(lshape="loge",
(sqrt(y/sc) - sqrt(sc/y)) / (2 * sh^2 * sc^1.5)
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 {
- if(iter == 1) {
- etanew = eta
- } else {
- derivold = derivnew
- etaold = etanew
- etanew = eta
- }
- derivnew = w * cbind(dl.dsh * dsh.deta, dl.dsc * dsc.deta)
- derivnew
- }
+ w * cbind(dl.dsh * dsh.deta, dl.dsc * dsc.deta)
}) , list( .lshape=lshape, .lscale=lscale,
- .eshape=eshape, .escale=escale,
- .fsmax=fsmax ))),
+ .eshape=eshape, .escale=escale ))),
weight=eval(substitute(expression({
- if(useFS) {
- wz = matrix(as.numeric(NA), n, M) # Diagonal!!
- wz[,iam(1,1,M)] = 2 * dsh.deta^2 / sh^2
- invxi = function(y) {
- 1 + 0.5 * y^2 + y * sqrt(4 + y^2) / 2
- }
- myfun = function(x, alpha)
- 2 * (1 / (1 + invxi(alpha*x)) - 0.5)^2 * dnorm(x)
- if(intercept.only) {
- temp9 = integrate(f=myfun, lower=0, upper=Inf, alpha=sh[1])
- if(temp9$message != "OK") stop("integration was unsuccessful")
- wz[,iam(2,2,M)] = dsc.deta^2 * (0.25+ 1/sh^2 +temp9$value)/sc^2
- } else {
- for(iii in 1:n) {
- temp9= integrate(f=myfun, lower=0, upper=Inf, alpha=sh[iii])
- if(temp9$message!="OK") stop("integration was unsuccessful")
- wz[iii,iam(2,2,M)] = dsc.deta[iii]^2 *
- (0.25 + 1 / sh[iii]^2 + temp9$value) / sc[iii]^2
- }
- }
- w * wz
- } else {
- if(iter == 1) {
- wznew = cbind(matrix(w, n, M), matrix(0, n, dimm(M)-M))
- } else {
- wzold = wznew
- wznew = qnupdate(w=w, wzold=wzold, dderiv=(derivold - derivnew),
- deta=etanew-etaold, M=M,
- trace=trace) # weights incorporated in args
- }
- wznew
- }
- }), list( .fsmax=fsmax ))))
+ wz = matrix(as.numeric(NA), n, M) # Diagonal!!
+ wz[,iam(1,1,M)] = 2 * dsh.deta^2 / sh^2
+ hfunction = function(alpha)
+ alpha * sqrt(pi/2) - pi * exp(2/alpha^2) * (1-pnorm(2/alpha))
+ wz[,iam(2,2,M)] = dsc.deta^2 * (sh * hfunction(sh) / sqrt(2*pi) +
+ 1) / (sh*sc)^2
+ w * wz
+ }), list( .zero=zero ))))
}
diff --git a/R/family.ts.q b/R/family.ts.q
index 4a2c0e6..863b72e 100644
--- a/R/family.ts.q
+++ b/R/family.ts.q
@@ -344,7 +344,7 @@ garma <- function(link=c("identity","loge","reciprocal",
identity=sum(w*(y-mu)^2),
loge=sum(w*(-mu + y*log(mu))),
inverse=sum(w*(-mu + y*log(mu))),
- sum(w*(y*log(mu) + (1-y)*log(1-mu))))
+ sum(w*(y*log(mu) + (1-y)*log1p(-mu))))
}, list( .link=link, .earg=earg ))),
middle2=eval(substitute(expression({
realfv <- fv
diff --git a/R/family.univariate.q b/R/family.univariate.q
index b1cd434..20114c0 100644
--- a/R/family.univariate.q
+++ b/R/family.univariate.q
@@ -16,6 +16,25 @@
+getMaxMin = function(vov, objfun, y, x, w, extraargs=NULL, maximize=TRUE,
+ abs.arg=FALSE) {
+ if(!is.vector(vov)) stop("vov must be a vector")
+ objvals = vov
+ for(ii in 1:length(vov))
+ objvals[ii] = objfun(vov[ii], y=y, x=x, w=w, extraargs=extraargs)
+ try.this = if(abs.arg) {
+ if(maximize) vov[abs(objvals) == max(abs(objvals))] else
+ vov[abs(objvals) == min(abs(objvals))]
+ } else {
+ if(maximize) vov[objvals == max(objvals)] else
+ vov[objvals == min(objvals)]
+ }
+ if(!length(try.this)) stop("something has gone wrong!")
+ if(length(try.this) == 1) try.this else sample(try.this, size=1)
+}
+
+
+
mccullagh89 = function(ltheta="rhobit", lnu="logoff",
itheta=NULL, inu=NULL,
etheta=list(),
@@ -53,24 +72,25 @@ mccullagh89 = function(ltheta="rhobit", lnu="logoff",
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)
- for(ii in 1:length(theta.grid))
- rvar[ii] = mean((y-theta.grid[ii])*(theta.grid[ii]^2-1)/
- (1-2*theta.grid[ii]*y+theta.grid[ii]^2))
- try.this = theta.grid[abs(rvar) == min(abs(rvar))]
+ mccullagh89.aux = function(thetaval, y, x, w, extraargs)
+ mean((y-thetaval)*(thetaval^2-1)/(1-2*thetaval*y+thetaval^2))
+ theta.grid = seq(-0.9, 0.9, by=0.05)
+ try.this = getMaxMin(theta.grid, objfun=mccullagh89.aux,
+ y=y, x=x, w=w, maximize=FALSE,
+ abs.arg=TRUE)
try.this = rep(try.this, len=n)
try.this
}
- tmp = y/(theta.init-y)
+ tmp = y / (theta.init-y)
tmp[tmp < -0.4] = -0.4
- tmp[tmp > 10.] = 10.
+ tmp[tmp > 10.0] = 10.0
nu.init = rep(if(length(.inu)) .inu else tmp, length=n)
nu.init[!is.finite(nu.init)] = 0.4
etastart = cbind(theta2eta(theta.init, .ltheta, earg=.etheta ),
theta2eta(nu.init, .lnu, earg= .enu ))
}
- }),list( .ltheta=ltheta, .lnu=lnu, .inu=inu, .itheta=itheta,
- .etheta = etheta, .enu=enu ))),
+ }), list( .ltheta=ltheta, .lnu=lnu, .inu=inu, .itheta=itheta,
+ .etheta = etheta, .enu=enu ))),
inverse=eval(substitute(function(eta, extra=NULL) {
Theta = eta2theta(eta[,1], .ltheta, earg= .etheta )
nu = eta2theta(eta[,2], .lnu, earg= .enu )
@@ -86,7 +106,7 @@ mccullagh89 = function(ltheta="rhobit", lnu="logoff",
Theta = eta2theta(eta[,1], .ltheta, earg= .etheta )
nu = eta2theta(eta[,2], .lnu, earg= .enu )
if(residuals) stop("loglikelihood residuals not implemented yet") else
- sum(w * ((nu-0.5)*log(1-y^2) - nu * log(1 - 2*Theta*y + Theta^2) -
+ sum(w * ((nu-0.5)*log1p(-y^2) - nu * log1p(-2*Theta*y + Theta^2) -
lbeta(nu+0.5,0.5 )))
}, list( .ltheta=ltheta, .lnu=lnu, .etheta = etheta, .enu=enu ))),
vfamily=c("mccullagh89"),
@@ -96,7 +116,7 @@ mccullagh89 = function(ltheta="rhobit", lnu="logoff",
dTheta.deta = dtheta.deta(Theta, .ltheta, earg= .etheta )
dnu.deta = dtheta.deta(nu, .lnu, earg= .enu )
dl.dTheta = 2 * nu * (y-Theta) / (1 -2*Theta*y + Theta^2)
- dl.dnu = log(1-y^2) - log(1 -2*Theta*y + Theta^2) -
+ dl.dnu = log1p(-y^2) - log1p(-2*Theta*y + Theta^2) -
digamma(nu+0.5) + digamma(nu+1)
w * cbind(dl.dTheta * dTheta.deta, dl.dnu * dnu.deta)
}), list( .ltheta=ltheta, .lnu=lnu, .etheta = etheta, .enu=enu ))),
@@ -363,12 +383,12 @@ dirmultinomial = function(lphi="logit", ephi = list(),
if(loopOveri) {
for(iii in 1:n) {
rrr = 1:omega[iii]
- ans[iii]= ans[iii] - sum(log(1-phi[iii] + (rrr-1)*phi[iii]))
+ ans[iii]= ans[iii] - sum(log1p(-phi[iii] + (rrr-1)*phi[iii]))
}
} else {
for(rrr in 1:maxomega) {
ind8 = rrr <= omega
- ans[ind8] = ans[ind8] - log(1-phi[ind8] + (rrr-1)*phi[ind8])
+ ans[ind8] = ans[ind8] - log1p(-phi[ind8] + (rrr-1)*phi[ind8])
}
}
sum(ans)
@@ -828,11 +848,12 @@ zetaff = function(link="loge", earg=list(), init.p=NULL)
predictors.names = namesof("p", .link, earg=.earg, tag=FALSE)
if(!length(etastart)) {
- llfun = function(pp, y, w) {
- sum(w * (-(pp+1) * log(y) - log(zeta(pp+1 ))))
+ zetaff.Loglikfun = function(pp, y, x, w, extraargs) {
+ sum(w * (-(pp+1) * log(y) - log(zeta(pp+1))))
}
+ p.grid = seq(0.1, 3.0, len=19)
pp.init = if(length( .init.p )) .init.p else
- getInitVals(gvals=seq(0.1, 3.0, len=19), llfun=llfun, y=y, w=w)
+ getMaxMin(p.grid, objfun=zetaff.Loglikfun, y=y, x=x, w=w)
pp.init = rep(pp.init, length=length(y))
if( .link == "loglog") pp.init[pp.init <= 1] = 1.2
etastart = theta2eta(pp.init, .link, earg=.earg)
@@ -1020,6 +1041,12 @@ zipf = function(N=NULL, link="loge", earg=list(), init.s=NULL)
}
+
+
+
+
+
+
cauchy1 = function(scale.arg=1, llocation="identity",
elocation=list(),
ilocation=NULL, method.init=1)
@@ -1048,16 +1075,16 @@ cauchy1 = function(scale.arg=1, llocation="identity",
loc.init = if(length(.ilocation)) .ilocation else {
if( .method.init == 2) median(rep(y,w)) else
if( .method.init == 3) y else {
- Loglikfun = function(y, loc, scal, w)
- sum(w * (-log(1+((y-loc)/scal)^2) - log(scal )))
- loc.grid = rvar = quantile(y, probs=seq(0.1,0.9,by=0.1))
- for(ii in 1:length(loc.grid))
- rvar[ii] = Loglikfun(y=y, loc=loc.grid[ii],
- scal= .scale.arg, w=w)
- try.this = loc.grid[rvar == max(rvar)]
+ cauchy1.Loglikfun = function(loc, y, x, w, extraargs) {
+ scal = extraargs
+ sum(w * (-log1p(((y-loc)/scal)^2) - log(scal)))
+ }
+ loc.grid = quantile(y, probs=seq(0.1, 0.9, by=0.05))
+ try.this = getMaxMin(loc.grid, objfun=cauchy1.Loglikfun,
+ y=y, x=x, w=w, extraargs= .scale.arg)
try.this = rep(try.this, len=n)
try.this
- }
+ }
}
loc.init = rep(loc.init, len=n)
if(.llocation == "loge") loc.init = abs(loc.init)+0.01
@@ -1080,7 +1107,7 @@ cauchy1 = function(scale.arg=1, llocation="identity",
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 )))
+ sum(w * (-log1p(temp^2) - log(pi) - log(.scale.arg )))
}, list( .scale.arg=scale.arg, .elocation=elocation,
.llocation=llocation ))),
vfamily=c("cauchy1"),
@@ -1102,6 +1129,8 @@ cauchy1 = function(scale.arg=1, llocation="identity",
+
+
logistic1 = function(llocation="identity",
elocation=list(),
scale.arg=1, method.init=1)
@@ -1147,7 +1176,7 @@ logistic1 = function(llocation="identity",
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 )))
+ sum(w * (-zedd - 2 * log1p(exp(-zedd)) - log(.scale.arg )))
}, list( .llocation=llocation,
.elocation=elocation, .scale.arg=scale.arg ))),
vfamily=c("logistic1"),
@@ -1284,7 +1313,7 @@ borel.tanner = function(shape.arg, link="logit", earg=list())
function(mu,y,w,residuals= FALSE,eta, extra=NULL) {
a = eta2theta(eta, .link, earg=.earg)
if(residuals) stop("loglikelihood residuals not implemented yet") else
- sum(w * ((y-.shape.arg) * log(a) - a * y))
+ sum(w * ((y- .shape.arg) * log(a) - a * y))
}, list( .link=link, .earg=earg, .shape.arg=shape.arg ))),
vfamily=c("borel.tanner"),
deriv=eval(substitute(expression({
@@ -2065,7 +2094,7 @@ geometric =function(link="logit", earg=list(), expected=TRUE)
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 )))
+ sum(w*(y * log1p(-prob) + log(prob )))
}
}, list( .link=link, .earg=earg ))),
vfamily=c("geometric"),
@@ -2210,8 +2239,8 @@ tobit = function(Lower = 0, Upper = Inf, lmu="identity",
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]))
+ ell2 = log1p(-pnorm((mum[cenL] - .Lower)/sd[cenL]))
+ ell3 = log1p(-pnorm(( .Upper - mum[cenU])/sd[cenU]))
if(residuals) stop("loglikelihood residuals not implemented yet") else
sum(w[cen0] * ell1) + sum(w[cenL] * ell2) + sum(w[cenU] * ell3)
}, list( .lmu=lmu, .lsd=lsd,
@@ -2611,7 +2640,7 @@ 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,
+ deviance.arg=FALSE, method.init=1, shrinkage.init=0.95,
zero = -2)
{
@@ -2624,6 +2653,10 @@ negbinomial = function(lmu = "loge", lk = "loge",
stop("range error in the argument \"cutoff\"")
if(!is.Numeric(Maxiter, integ=TRUE, allow=1) || Maxiter < 100)
stop("bad input for argument \"Maxiter\"")
+ if(!is.Numeric(method.init, allow=1, integ=TRUE, posit=TRUE) ||
+ method.init > 2) stop("argument \"method.init\" must be 1 or 2")
+ if(!is.Numeric(shrinkage.init, allow=1) || shrinkage.init < 0 ||
+ shrinkage.init > 1) stop("bad input for argument \"shrinkage.init\"")
if(mode(lmu) != "character" && mode(lmu) != "name")
lmu = as.character(substitute(lmu))
@@ -2664,39 +2697,33 @@ negbinomial = function(lmu = "loge", lk = "loge",
tag=FALSE))
predictors.names = predictors.names[interleave.VGAM(M, M=2)]
if(!length(etastart)) {
- if( .method.init >= 4) {
- mu.init = y
- for(iii in 1:ncol(y)) {
- mu.init[,iii] = if( .method.init == 4)
- weighted.mean(y[,iii], w=w) else
- median(rep(y[,iii], w)) + 1/8
- }
- for(iii in 1:ncol(y)) {
- mu.init[,iii] = pmin(y[,iii] + 1/8, mu.init[,iii])
+ mu.init = y
+ for(iii in 1:ncol(y)) {
+ use.this = if( .method.init == 2) {
+ weighted.mean(y[,iii], w) + 1/16
+ } else {
+ median(y[,iii]) + 1/16
}
- } else if( .method.init == 3) {
- mu.init = y + 1/8
- } else {
- mu.init = y
- for(iii in 1:ncol(y))
- mu.init[,iii] = if( .method.init == 2)
- weighted.mean(y[,iii], w=w) else
- median(rep(y[,iii], w)) + 1/8
+ mu.init[,iii] = (1- .sinit) * (y[,iii]+1/16) + .sinit * use.this
}
+
+
if( is.Numeric( .k.init )) {
kay.init = matrix( .k.init, nr=n, nc=NOS, byrow=TRUE)
} else {
+ negbinomial.Loglikfun = function(kmat, y, x, w, extraargs) {
+ mu = extraargs
+ sum(w * (y * log(mu/(mu+kmat)) +
+ kmat*log(kmat/(mu+kmat)) + lgamma(y+kmat) -
+ lgamma(kmat) - lgamma(y+1)))
+ }
+ k.grid = 2^((-3):6)
kay.init = matrix(0, nr=n, nc=NOS)
- Loglikfun = function(y, mu, kmat, w)
- sum(w * (y * log(mu/(mu+kmat)) + kmat*log(kmat/(mu+kmat)) +
- lgamma(y+kmat) - lgamma(kmat) - lgamma(y+1 )))
- k.grid = rvar = 2^((-3):6)
for(spp. in 1:NOS) {
- for(ii in 1:length(k.grid))
- rvar[ii] = Loglikfun(y=y[,spp.], mu=mu.init[,spp.],
- kmat=k.grid[ii], w=w)
- try.this = k.grid[rvar == max(rvar)]
- kay.init[,spp.] = try.this
+ kay.init[,spp.] = getMaxMin(k.grid,
+ objfun=negbinomial.Loglikfun,
+ y=y[,spp.], x=x, w=w,
+ extraargs= mu.init[,spp.])
}
}
etastart = cbind(theta2eta(mu.init, .lmu, earg= .emu),
@@ -2705,6 +2732,7 @@ negbinomial = function(lmu = "loge", lk = "loge",
}
}), list( .lmu=lmu, .lk=lk, .k.init=ik, .zero=zero,
.emu=emu, .ek=ek,
+ .sinit=shrinkage.init,
.method.init=method.init ))),
inverse=eval(substitute(function(eta, extra=NULL) {
NOS = ncol(eta) / 2
@@ -2881,7 +2909,7 @@ negbin.ab = function(link.alpha ="loge", link.k ="loge",
alpha = eta2theta(eta[,1], .link.alpha, earg= .ealpha)
k = eta2theta(eta[,2], .link.k, earg= .ek)
dl.dalpha = (y/alpha - k)/(1+alpha)
- dl.dk = digamma(y+k) - digamma(k) - log(1+alpha)
+ dl.dk = digamma(y+k) - digamma(k) - log1p(alpha)
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)
@@ -3026,7 +3054,7 @@ neg.binomial = function(link.p="logit", link.k="loge",
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) -
+ sum(w * (y * log1p(-prob) + k * log(prob) + lgamma(y+k) -
lgamma(k) - lgamma(y+1 )))
}, list( .link.p=link.p, .link.k=link.k,
.ep=ep, .ek=ek ))),
@@ -3096,7 +3124,7 @@ neg.binomial.k = function(k, link="logit", earg=list(), expected=TRUE, ...)
devy = .k * log( .k / ( .k + y))
nz = y != 0
devy[nz] = devy[nz] + y[nz] * log(y[nz] / ( .k + y[nz]))
- devmu = y * log(1 - prob) + .k * log(prob)
+ devmu = y * log1p(-prob) + .k * log(prob)
devi = 2 * (devy - devmu)
if(residuals)
sign(y - mu) * sqrt(abs(devi) * w) else
@@ -3123,7 +3151,7 @@ neg.binomial.k = function(k, link="logit", earg=list(), expected=TRUE, ...)
function(mu,y,w,residuals= FALSE,eta, extra=NULL) {
prob = eta2theta(eta, .link, earg= .earg)
if(residuals) stop("loglikelihood residuals not implemented yet") else
- sum(w * (y * log(1-prob) + .k * log(prob) + lgamma(y+ .k) -
+ sum(w * (y * log1p(-prob) + .k * log(prob) + lgamma(y+ .k) -
lgamma( .k ) - lgamma(y+1 )))
}, list( .link=link, .earg=earg, .k=k ))),
vfamily=c("neg.binomial.k"),
@@ -3234,8 +3262,8 @@ studentt = function(link.df="loglog", earg=list())
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 )))
+ sum(w * (-log(pi*df)/2 - (df+1)*log1p(temp1)/2 +
+ lgamma((df+1)/2) - lgamma(df/2)))
}
}, list( .link.df=link.df, .earg=earg ))),
vfamily=c("studentt"),
@@ -3243,7 +3271,7 @@ studentt = function(link.df="loglog", earg=list())
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)) +
+ dl.ddf = 0.5*(-temp -log1p(temp1) +(df+1)*y^2/(df^2 * (1+temp1)) +
digamma((df+1)/2)-digamma(df/2))
ddf.deta = dtheta.deta(theta=df, .link.df, earg= .earg)
w * dl.ddf * ddf.deta
@@ -3638,7 +3666,7 @@ hypersecant.1 = function(link.theta="elogit",
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 )))
+ (-0.5-theta/pi)*log1p(-y )))
}, list( .link.theta=link.theta, .earg=earg ))),
vfamily=c("hypersecant.1"),
deriv=eval(substitute(expression({
@@ -3716,8 +3744,8 @@ leipnik = function(lmu="logit", llambda="loge",
function(mu,y,w,residuals= FALSE,eta, extra=NULL) {
lambda = eta2theta(eta[,2], .llambda, earg= .elambda)
if(residuals) stop("loglikelihood residuals not implemented yet") else
- sum(w * (-0.5*log(y*(1-y)) - 0.5 * lambda * log(1 +
- (y-mu)^2 / (y*(1-y ))) - lgamma((lambda+1)/2) +
+ sum(w * (-0.5*log(y*(1-y)) - 0.5 * lambda *
+ log1p((y-mu)^2 / (y*(1-y ))) - lgamma((lambda+1)/2) +
lgamma(1+ lambda/2 )))
}, list( .llambda=llambda,
.emu=emu, .elambda=elambda ))),
@@ -3726,7 +3754,7 @@ leipnik = function(lmu="logit", llambda="loge",
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 ))) -
+ dl.dlambda=-0.5*log1p((y-mu)^2 / (y*(1-y))) -
0.5*digamma((lambda+1)/2) +
0.5*digamma(1+lambda/2))
} else {
@@ -4465,7 +4493,7 @@ dlog = function(x, prob) {
zero = round(x) != x | x < 1
ans = rep(0.0, len=length(x))
if(any(!zero))
- ans[!zero] = -(prob[!zero]^(x[!zero])) / (x[!zero] * log(1-prob[!zero]))
+ ans[!zero] = -(prob[!zero]^(x[!zero])) / (x[!zero] * log1p(-prob[!zero]))
if(any(ox))
ans[ox] = NA
ans
@@ -4506,7 +4534,7 @@ rlog = function(n, prob, Smallno=1.0e-6) {
ans = rep(0.0, len=n)
ptr1 = 1; ptr2 = 0
- a = -1 / log(1 - prob)
+ a = -1 / log1p(-prob)
mean = a*prob/(1-prob) # E(Y)
sigma = sqrt(a*prob*(1-a*prob)) / (1-prob) # sd(Y)
ymax = dlog(x=1, prob)
@@ -4549,7 +4577,7 @@ logff = function(link="logit", earg=list(), init.c=NULL)
predictors.names = namesof("c", .link, earg=.earg, tag=FALSE)
if(!length(etastart)) {
llfun = function(cc, y, w) {
- a = -1 / log(1-cc)
+ a = -1 / log1p(-cc)
sum(w * (log(a) + y * log(cc) - log(y)))
}
c.init = if(length( .init.c )) .init.c else
@@ -4560,7 +4588,7 @@ logff = function(link="logit", earg=list(), init.c=NULL)
}), list( .link=link, .earg=earg, .init.c=init.c ))),
inverse=eval(substitute(function(eta, extra=NULL) {
cc = eta2theta(eta, .link, earg= .earg)
- a = -1 / log(1-cc)
+ a = -1 / log1p(-cc)
a * cc / (1-cc)
}, list( .link=link, .earg=earg ))),
last=eval(substitute(expression({
@@ -4570,15 +4598,15 @@ logff = function(link="logit", earg=list(), init.c=NULL)
loglikelihood=eval(substitute(
function(mu,y,w,residuals= FALSE,eta, extra=NULL) {
cc = eta2theta(eta, .link, earg= .earg)
- a = -1 / log(1-cc)
+ a = -1 / log1p(-cc)
if(residuals) stop("loglikelihood residuals not implemented yet") else
sum(w * (log(a) + y * log(cc) - log(y )))
}, list( .link=link, .earg=earg ))),
vfamily=c("logff"),
deriv=eval(substitute(expression({
cc = eta2theta(eta, .link, earg= .earg)
- a = -1 / log(1-cc)
- dl.dc = 1 / ((1-cc) * log(1-cc)) + y / cc
+ a = -1 / log1p(-cc)
+ dl.dc = 1 / ((1-cc) * log1p(-cc)) + y / cc
dc.deta = dtheta.deta(cc, .link, earg= .earg)
w * dl.dc * dc.deta
}), list( .link=link, .earg=earg ))),
@@ -4746,7 +4774,7 @@ stoppa = function(y0,
if(!length( .ialpha) || !length( .itheta)) {
qvec = c(.25, .5, .75) # Arbitrary; could be made an argument
init.theta = if(length( .itheta)) .itheta else 1
- xvec = log(1-qvec^(1/ init.theta))
+ xvec = log1p(-qvec^(1/init.theta))
fit0 = lsfit(x=xvec, y=log(quantile(y, qvec))-log(y0), intercept=FALSE)
}
@@ -4774,7 +4802,7 @@ stoppa = function(y0,
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 ))))
+ (theta-1) * log1p(-(y/extra$y0)^(-alpha))))
}, list( .link.theta=link.theta, .link.alpha=link.alpha ))),
vfamily=c("stoppa"),
deriv=eval(substitute(expression({
@@ -4782,7 +4810,7 @@ stoppa = function(y0,
theta = eta2theta(eta[,2], .link.theta, earg= .etheta)
temp8 = (y / extra$y0)^(-alpha)
temp8a = log(temp8)
- temp8b = log(1-temp8)
+ temp8b = log1p(-temp8)
dl.dalpha = 1/alpha - log(y/extra$y0) + (theta-1) * temp8 *
log(y / extra$y0) / (1-temp8)
dl.dtheta = 1/theta + temp8b
@@ -4934,8 +4962,8 @@ lino = function(lshape1="loge",
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)) )
+ sum(w*(sh1*log(lambda) + (sh1-1)*log(y) + (sh2-1)*log1p(-y) -
+ lbeta(sh1,sh2) -(sh1+sh2)*log1p(-(1-lambda)*y)) )
}, list( .lshape1=lshape1, .lshape2=lshape2, .llambda=llambda,
.eshape1=eshape1, .eshape2=eshape2, .elambda=elambda ))),
vfamily=c("lino"),
@@ -4943,10 +4971,10 @@ lino = function(lshape1="loge",
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)
+ temp1 = log1p(-(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.dsh2 = log1p(-y) - digamma(sh2) + temp2 - temp1
dl.dlambda = sh1/lambda - (sh1+sh2) * y / (1 - (1-lambda) * y)
dsh1.deta = dtheta.deta(sh1, .lshape1, earg= .eshape1)
dsh2.deta = dtheta.deta(sh2, .lshape2, earg= .eshape2)
@@ -5076,7 +5104,7 @@ genbetaII= function(link.a="loge",
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 )))
+ (parg+qq)*log1p((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,
@@ -5093,7 +5121,7 @@ genbetaII= function(link.a="loge",
temp3 = digamma(parg + qq)
temp3a = digamma(parg)
temp3b = digamma(qq)
- temp4 = log(1+temp2)
+ temp4 = log1p(temp2)
dl.da = 1/aa + parg * temp1 - (parg+qq) * temp1 / (1+1/temp2)
dl.dscale = (aa/scale) * (-parg + (parg+qq) / (1+1/temp2))
@@ -5382,7 +5410,7 @@ sinmad = function(link.a="loge",
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 )))
+ (parg+qq)*log1p((y/scale)^aa)))
}, list( .link.a=link.a, .link.scale=link.scale,
.earg.a=earg.a, .earg.scale=earg.scale,
.earg.q=earg.q,
@@ -5401,7 +5429,7 @@ 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)
+ dl.dq = digamma(parg + qq) - temp3b - log1p(temp2)
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)
@@ -5525,7 +5553,7 @@ sinmad = function(link.a="loge",
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 )))
+ (parg+qq)*log1p((y/scale)^aa)))
}, list( .link.a=link.a, .link.scale=link.scale,
.earg.a=earg.a, .earg.scale=earg.scale,
.earg.p=earg.p,
@@ -5544,7 +5572,7 @@ 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)
+ dl.dp = aa * temp1 + digamma(parg + qq) - temp3a - log1p(temp2)
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)
@@ -5669,7 +5697,7 @@ betaII= function(link.scale="loge",
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 )))
+ (parg+qq)*log1p((y/scale)^aa)))
}, list( .link.scale=link.scale,
.earg.scale=earg.scale,
.earg.p=earg.p, .earg.q=earg.q,
@@ -5686,7 +5714,7 @@ betaII= function(link.scale="loge",
temp3 = digamma(parg + qq)
temp3a = digamma(parg)
temp3b = digamma(qq)
- temp4 = log(1+temp2)
+ temp4 = log1p(temp2)
dl.dscale = (aa/scale) * (-parg + (parg+qq) / (1+1/temp2))
dl.dp = aa * temp1 + temp3 - temp3a - temp4
@@ -5803,7 +5831,7 @@ lomax = function(link.scale="loge",
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 )))
+ (parg+qq)*log1p((y/scale)^aa)))
}, list( .link.scale=link.scale,
.earg.scale=earg.scale,
.earg.q=earg.q,
@@ -5817,7 +5845,7 @@ lomax = function(link.scale="loge",
temp2 = (y/scale)^aa
dl.dscale = (aa/scale) * (-parg + (parg+qq) / (1+1/temp2))
- dl.dq = digamma(parg + qq) - digamma(qq) - log(1+temp2)
+ dl.dq = digamma(parg + qq) - digamma(qq) - log1p(temp2)
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,
@@ -5914,7 +5942,7 @@ lomax = function(link.scale="loge",
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 )))
+ (parg+qq)*log1p((y/scale)^aa)))
}, list( .link.a=link.a, .link.scale=link.scale,
.earg.a=earg.a, .earg.scale=earg.scale ))),
vfamily=c("fisk"),
@@ -6028,7 +6056,7 @@ invlomax = function(link.scale="loge",
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 )))
+ (parg+qq)*log1p((y/scale)^aa)))
}, list( .link.scale=link.scale,
.earg.scale=earg.scale,
.earg.p=earg.p,
@@ -6043,7 +6071,7 @@ invlomax = function(link.scale="loge",
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)
+ dl.dp = aa * temp1 + digamma(parg + qq) - digamma(parg) - log1p(temp2)
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,
@@ -6144,7 +6172,7 @@ paralogistic = function(link.a="loge",
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 )))
+ (parg+qq)*log1p((y/scale)^aa)))
}, list( .link.a=link.a, .link.scale=link.scale,
.earg.a=earg.a, .earg.scale=earg.scale
))),
@@ -6260,7 +6288,7 @@ paralogistic = function(link.a="loge",
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 )))
+ (parg+qq)*log1p((y/scale)^aa)))
}, list( .link.a=link.a, .link.scale=link.scale,
.earg.a=earg.a, .earg.scale=earg.scale ))),
vfamily=c("invparalogistic"),
@@ -6460,15 +6488,15 @@ betaprime = function(link="loge", earg=list(), i1=2, i2=NULL, zero=NULL)
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))
+ sum(w *((shapes[,1]-1)*log(y)-(shapes[,2]+shapes[,1])*log1p(y)-temp))
}, list( .link=link, .earg=earg ))),
vfamily="betaprime",
deriv=eval(substitute(expression({
shapes = eta2theta(eta, .link, earg= .earg)
dshapes.deta = dtheta.deta(shapes, .link, earg= .earg)
- dl.dshapes = cbind(log(y) - log(1+y) - digamma(shapes[,1]) +
+ dl.dshapes = cbind(log(y) - log1p(y) - digamma(shapes[,1]) +
digamma(shapes[,1]+shapes[,2]),
- - log(1+y) - digamma(shapes[,2]) +
+ - log1p(y) - digamma(shapes[,2]) +
digamma(shapes[,1]+shapes[,2]))
w * dl.dshapes * dshapes.deta
}), list( .link=link, .earg=earg ))),
@@ -6520,7 +6548,7 @@ maxwell = function(link="loge", earg=list()) {
function(mu,y,w,residuals= FALSE,eta, extra=NULL) {
a = eta2theta(eta, .link, earg= .earg)
if(residuals) stop("loglikelihood residuals not implemented yet") else
- sum(w * (1.5 * log(a) + 2 * log(y) - 0.5 * a * y^2 + 0.5*log(2/pi )))
+ sum(w * (1.5 * log(a) + 2 * log(y) - 0.5 * a * y^2 + 0.5*log(2/pi)))
}, list( .link=link, .earg=earg ))),
vfamily=c("maxwell"),
deriv=eval(substitute(expression({
@@ -6738,10 +6766,12 @@ nakagami = function(lshape="loge", lscale="loge",
-rayleigh = function(link="loge", earg=list()) {
+rayleigh = function(link="loge", earg=list(), nrfs=1/3+0.01) {
if(mode(link) != "character" && mode(link) != "name")
link = as.character(substitute(link))
if(!is.list(earg)) earg = list()
+ if(!is.Numeric(nrfs, allow=1) || nrfs<0 || nrfs > 1)
+ stop("bad input for 'nrfs'")
new("vglmff",
blurb=c("Rayleigh distribution f(y) = y*exp(-0.5*(y/a)^2)/a^2, y>0, a>0\n",
@@ -6764,7 +6794,8 @@ rayleigh = function(link="loge", earg=list()) {
last=eval(substitute(expression({
misc$link = c(a= .link)
misc$earg = list(a = .earg)
- }), list( .link=link, .earg=earg ))),
+ misc$nrfs = .nrfs
+ }), list( .link=link, .earg=earg, .nrfs=nrfs ))),
loglikelihood=eval(substitute(
function(mu,y,w,residuals= FALSE,eta, extra=NULL) {
a = eta2theta(eta, .link, earg= .earg)
@@ -6779,10 +6810,11 @@ rayleigh = function(link="loge", earg=list()) {
w * dl.da * da.deta
}), list( .link=link, .earg=earg ))),
weight=eval(substitute(expression({
+ d2l.da2 = (3 * (y/a)^2 - 2) / a^2
ed2l.da2 = 4 / a^2
- wz = w * da.deta^2 * ed2l.da2
+ wz = w * da.deta^2 * ((1- .nrfs) * d2l.da2 + .nrfs * ed2l.da2)
wz
- }), list( .link=link, .earg=earg ))))
+ }), list( .link=link, .earg=earg, .nrfs=nrfs ))))
}
@@ -6803,7 +6835,7 @@ prayleigh = function(q, a) {
qrayleigh = function(p, a) {
if(any(a <= 0)) stop("argument \"a\" must be positive")
if(any(p <= 0) || any(p >= 1)) stop("argument \"p\" must be between 0 and 1")
- a * sqrt(-2 * log(1-p))
+ a * sqrt(-2 * log1p(-p))
}
rrayleigh = function(n, a) {
@@ -7017,7 +7049,7 @@ paretoIV = function(location=0,
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 ))))
+ log(zedd) - (shape+1) * log1p(zedd^(1/inequality))))
}, list( .lscale=lscale, .linequality=linequality, .lshape=lshape,
.escale=escale, .einequality=einequality, .eshape=eshape ))),
vfamily=c("paretoIV"),
@@ -7136,7 +7168,7 @@ paretoIII = function(location=0,
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 ))))
+ log(zedd) - (1+1) * log1p(zedd^(1/inequality))))
}, list( .lscale=lscale, .linequality=linequality,
.escale=escale, .einequality=einequality ))),
vfamily=c("paretoIII"),
@@ -7210,7 +7242,7 @@ paretoII = function(location=0,
probs = (1:4)/5
scale.init.0 = 1 # zz; have to put some value here...
ytemp = quantile(x=log(y-location+scale.init.0), probs=probs)
- fittemp = lsfit(x=log(1-probs), y=ytemp, int=TRUE)
+ fittemp = lsfit(x=log1p(-probs), y=ytemp, int=TRUE)
if(!length(shape.init))
shape.init = max(-1/fittemp$coef["X"], 0.01)
if(!length(scale.init))
@@ -7243,7 +7275,7 @@ paretoII = function(location=0,
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 )))
+ sum(w * (log(shape) - log(Scale) - (shape+1) * log1p(zedd)))
}, list( .lscale=lscale, .lshape=lshape,
.escale=escale, .eshape=eshape ))),
vfamily=c("paretoII"),
@@ -7373,7 +7405,8 @@ rpareto = function(n, location, shape) {
}
-tpareto1 = function(lower, upper, lshape="loge", earg=list(), ishape=NULL) {
+tpareto1 = function(lower, upper, lshape="loge", earg=list(), ishape=NULL,
+ method.init=1) {
if(mode(lshape) != "character" && mode(lshape) != "name")
lshape = as.character(substitute(lshape))
if(!is.Numeric(lower, posit=TRUE, allow=1))
@@ -7385,6 +7418,9 @@ tpareto1 = function(lower, upper, lshape="loge", earg=list(), ishape=NULL) {
if(length(ishape) && !is.Numeric(ishape, posit=TRUE))
stop("bad input for argument \"ishape\"")
if(!is.list(earg)) earg = list()
+ if(!is.Numeric(method.init, allow=1, integ=TRUE, posit=TRUE) ||
+ method.init > 2)
+ stop("'method.init' must be 1 or 2")
new("vglmff",
blurb=c("Truncated Pareto distribution f(y) = shape * lower^shape /",
@@ -7407,10 +7443,24 @@ tpareto1 = function(lower, upper, lshape="loge", earg=list(), ishape=NULL) {
extra$upper = .upper
if(!length(etastart)) {
shape.init = if(is.Numeric( .ishape)) 0 * y + .ishape else
- (y + 1/8) / (y - .lower + 1/8)
+ if( .method.init == 2) {
+ 0 * y + median(rep((y + 1/8) / (y - .lower + 1/8), times=w))
+ } else {
+ tpareto1.Loglikfun = function(shape, y, x, w, extraargs) {
+ myratio = .lower / .upper
+ sum(w * (log(shape) + shape * log( .lower) -
+ (shape+1) * log(y) - log1p(-myratio^shape)))
+ }
+ shape.grid = 2^((-4):4)
+ try.this = getMaxMin(shape.grid, objfun=tpareto1.Loglikfun,
+ y=y, x=x, w=w)
+ try.this = rep(try.this, len=n)
+ try.this
+ }
etastart = theta2eta(shape.init, .lshape, earg= .earg)
}
}), list( .ishape=ishape, .earg=earg, .lshape=lshape,
+ .method.init=method.init,
.lower=lower, .upper=upper ))),
inverse=eval(substitute(function(eta, extra=NULL) {
shape = eta2theta(eta, .lshape, earg= .earg)
@@ -7431,7 +7481,7 @@ tpareto1 = function(lower, upper, lshape="loge", earg=list(), ishape=NULL) {
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 )))
+ log1p(-myratio^shape)))
}, list( .lshape=lshape, .earg=earg, .lower=lower, .upper=upper ))),
vfamily=c("tpareto1"),
deriv=eval(substitute(expression({
@@ -7624,7 +7674,7 @@ expexp = function(lshape="loge", lscale="loge",
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))
+ (shape-1)*log1p(-exp(-scale*y)) - scale*y))
}, list( .lscale=lscale, .lshape=lshape,
.eshape=eshape, .escale=escale ))),
vfamily=c("expexp"),
@@ -7632,7 +7682,7 @@ expexp = function(lshape="loge", lscale="loge",
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))
+ dl.dshape = 1/shape + log1p(-exp(-scale*y))
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)
@@ -7738,7 +7788,7 @@ expexp1 = function(lscale="loge",
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))
+ (shape-1)*log1p(-exp(-scale*y)) - scale*y))
}, list( .lscale=lscale, .escale=escale ))),
vfamily=c("expexp1"),
deriv=eval(substitute(expression({
@@ -7947,7 +7997,7 @@ logistic2 = function(llocation="identity",
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 )))
+ sum(w * (-zedd - 2 * log1p(exp(-zedd)) - log(Scale )))
}, list( .llocation=llocation, .lscale=lscale,
.elocation=elocation, .escale=escale ))),
vfamily=c("logistic2"),
@@ -7979,29 +8029,156 @@ logistic2 = function(llocation="identity",
-if(FALSE)
-laplace.control <- function(save.weight=TRUE, ...)
-{
- list(save.weight=save.weight)
+
+alaplace = function(llocation="identity", lscale="loge",
+ lkappa="loge",
+ elocation=list(), escale=list(),
+ ekappa=list(),
+ ilocation=NULL, iscale=NULL, ikappa=1.0,
+ method.init=1, zero=NULL) {
+ if(mode(llocation) != "character" && mode(llocation) != "name")
+ llocation = as.character(substitute(llocation))
+ if(mode(lscale) != "character" && mode(lscale) != "name")
+ lscale = as.character(substitute(lscale))
+ if(mode(lkappa) != "character" && mode(lkappa) != "name")
+ lkappa = as.character(substitute(lkappa))
+ if(!is.Numeric(method.init, allow=1, integ=TRUE, posit=TRUE) ||
+ method.init > 2) stop("argument \"method.init\" must be 1 or 2")
+ if(length(zero) && !is.Numeric(zero, integer=TRUE, posit=TRUE))
+ stop("bad input for argument \"zero\"")
+ if(!is.list(elocation)) elocation = list()
+ if(!is.list(escale)) escale = list()
+ if(!is.list(ekappa)) ekappa = list()
+
+ new("vglmff",
+ blurb=c("Three-parameter asymmetric Laplace distribution\n\n",
+ "Links: ",
+ namesof("location", llocation, earg=elocation), ", ",
+ namesof("scale", lscale, earg=escale), ", ",
+ namesof("kappa", lkappa, earg=ekappa),
+ "\n", "\n",
+ "Mean: location + scale * (1/kappa - kappa) / sqrt(2)",
+ "\n",
+ "Variance: mean^2 + scale^2"),
+ constraints=eval(substitute(expression({
+ constraints = cm.zero.vgam(constraints, x, .zero, M)
+ }), list( .zero=zero ))),
+ initialize=eval(substitute(expression({
+ if(ncol(cbind(y)) != 1)
+ stop("response must be a vector or a one-column matrix")
+ predictors.names =
+ c(namesof("location", .llocation, earg=.elocation, tag=FALSE),
+ namesof("scale", .lscale, earg=.escale, tag=FALSE),
+ namesof("kappa", .lkappa, earg=.ekappa, tag=FALSE))
+ if(!length(etastart)) {
+ kappa.init = if(length( .ikappa)) rep( .ikappa, len=n) else
+ rep( 1.0, len=n)
+ if( .method.init == 1) {
+ location.init = median(y)
+ scale.init = sqrt(var(y) / 2)
+ } else {
+ location.init = y
+ scale.init = sqrt(sum(w*abs(y-median(y ))) / (sum(w) *2))
+ }
+ location.init = if(length(.ilocation)) rep(.ilocation, len=n) else
+ rep(location.init, len=n)
+ scale.init = if(length(.iscale)) rep(.iscale, len=n) else
+ rep(scale.init, len=n)
+ etastart =
+ cbind(theta2eta(location.init, .llocation, earg= .elocation),
+ theta2eta(scale.init, .lscale, earg= .escale),
+ theta2eta(kappa.init, .lkappa, earg= .ekappa))
+ }
+ }), list( .method.init=method.init,
+ .elocation=elocation, .escale=escale, .ekappa=ekappa,
+ .llocation=llocation, .lscale=lscale, .lkappa=lkappa,
+ .ilocation=ilocation, .iscale=iscale, .ikappa=ikappa ))),
+ inverse=eval(substitute(function(eta, extra=NULL) {
+ location = eta2theta(eta[,1], .llocation, earg= .elocation)
+ Scale = eta2theta(eta[,2], .lscale, earg= .escale)
+ kappa = eta2theta(eta[,3], .lkappa, earg= .ekappa)
+ location + Scale * (1/kappa - kappa) / sqrt(2)
+ }, list( .elocation=elocation, .llocation=llocation,
+ .escale=ekappa, .lscale=lkappa,
+ .ekappa=ekappa, .lkappa=lkappa ))),
+ last=eval(substitute(expression({
+ misc$link = c(location= .llocation, scale= .lscale, kappa= .lkappa)
+ misc$earg = list(location= .elocation, scale= .escale, kappa= .ekappa)
+ misc$expected = TRUE
+ }), list( .elocation=elocation, .llocation=llocation,
+ .escale=escale, .lscale=lscale,
+ .ekappa=ekappa, .lkappa=lkappa ))),
+ loglikelihood=eval(substitute(
+ function(mu,y,w,residuals= FALSE,eta, extra=NULL) {
+ location = eta2theta(eta[,1], .llocation, earg= .elocation)
+ Scale = eta2theta(eta[,2], .lscale, earg= .escale)
+ kappa = eta2theta(eta[,3], .lkappa, earg= .ekappa)
+ zedd = ifelse(y >= location, kappa, 1/kappa) * sqrt(2) *
+ abs(y-location) / Scale
+ if(residuals) stop("loglikelihood residuals not implemented yet") else
+ sum(w * (-zedd - log(Scale) - log(2)/2 + log(kappa) - log1p(kappa^2)))
+ }, list( .elocation=elocation, .llocation=llocation,
+ .escale=escale, .lscale=lscale,
+ .ekappa=ekappa, .lkappa=lkappa ))),
+ vfamily=c("alaplace"),
+ deriv=eval(substitute(expression({
+ location = eta2theta(eta[,1], .llocation, earg= .elocation)
+ Scale = eta2theta(eta[,2], .lscale, earg= .escale)
+ kappa = eta2theta(eta[,3], .lkappa, earg= .ekappa)
+ zedd = abs(y-location) / Scale
+ dl.dlocation = sqrt(2) * ifelse(y >= location, kappa, 1/kappa) *
+ sign(y-location) / Scale
+ dl.dscale = sqrt(2) * ifelse(y >= location, kappa, 1/kappa) *
+ zedd / Scale - 1 / Scale
+ dl.dkappa = 1 / kappa - 2 * kappa / (1+kappa^2) -
+ (sqrt(2) / Scale) *
+ ifelse(y > location, 1, -1/kappa^2) * abs(y-location)
+ dlocation.deta = dtheta.deta(location, .llocation, earg= .elocation)
+ dscale.deta = dtheta.deta(Scale, .lscale, earg= .escale)
+ dkappa.deta = dtheta.deta(kappa, .lkappa, earg= .ekappa)
+ w * cbind(dl.dlocation * dlocation.deta,
+ dl.dscale * dscale.deta,
+ dl.dkappa * dkappa.deta)
+ }), list( .escale=escale, .lscale=lscale,
+ .elocation=elocation, .llocation=llocation,
+ .ekappa=ekappa, .lkappa=lkappa ))),
+ weight=eval(substitute(expression({
+ d2l.dlocation2 = 2 / Scale^2
+ d2l.dscale2 = 1 / Scale^2
+ d2l.dkappa2 = 1 / kappa^2 + 4 / (1+kappa^2)^2
+ d2l.dkappadloc = -sqrt(8) / ((1+kappa^2) * Scale)
+ d2l.dkappadscale = -(1-kappa^2) / ((1+kappa^2) * kappa * Scale)
+ wz = matrix(0, nrow=n, dimm(M))
+ wz[,iam(1,1,M)] = d2l.dlocation2 * dlocation.deta^2
+ wz[,iam(2,2,M)] = d2l.dscale2 * dscale.deta^2
+ wz[,iam(3,3,M)] = d2l.dkappa2 * dkappa.deta^2
+ wz[,iam(1,3,M)] = d2l.dkappadloc * dkappa.deta * dlocation.deta
+ wz[,iam(2,3,M)] = d2l.dkappadscale * dkappa.deta * dscale.deta
+ w * wz
+ }), list( .escale=escale, .lscale=lscale,
+ .elocation=elocation, .llocation=llocation ))))
}
-if(FALSE)
-laplace = function(lscale="loge", escale=list(),
+laplace = 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")
+ llocation = as.character(substitute(llocation))
if(mode(lscale) != "character" && mode(lscale) != "name")
lscale = as.character(substitute(lscale))
if(!is.Numeric(method.init, allow=1, integ=TRUE, posit=TRUE) ||
method.init > 2) stop("argument \"method.init\" must be 1 or 2")
if(length(zero) && !is.Numeric(zero, integer=TRUE, posit=TRUE))
stop("bad input for argument \"zero\"")
+ if(!is.list(elocation)) elocation = list()
if(!is.list(escale)) escale = list()
new("vglmff",
blurb=c("Two-parameter Laplace distribution\n\n",
"Links: ",
- namesof("location", "identity", earg=list()), ", ",
+ namesof("location", llocation, earg=elocation), ", ",
namesof("scale", lscale, earg=escale),
"\n", "\n",
"Mean: location", "\n",
@@ -8013,8 +8190,8 @@ laplace = function(lscale="loge", escale=list(),
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))
+ c(namesof("location", .llocation, earg=.elocation, tag=FALSE),
+ namesof("scale", .lscale, earg=.escale, tag=FALSE))
if(!length(etastart)) {
if( .method.init == 1) {
location.init = median(y)
@@ -8026,60 +8203,55 @@ laplace = function(lscale="loge", escale=list(),
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", earg= list()),
- theta2eta(scale.init, .lscale, earg= .escale))
- }
- }), list( .method.init=method.init, .ilocation=ilocation,
- .escale=escale, .iscale=iscale, .lscale=lscale ))),
- inverse=function(eta, extra=NULL) {
- eta[,1]
- },
+ rep(scale.init, len=n)
+ etastart =
+ cbind(theta2eta(location.init, .llocation, earg= .elocation),
+ theta2eta(scale.init, .lscale, earg= .escale))
+ }
+ }), list( .method.init=method.init,
+ .elocation=elocation, .escale=escale,
+ .llocation=llocation, .lscale=lscale,
+ .ilocation=ilocation, .iscale=iscale ))),
+ inverse=eval(substitute(function(eta, extra=NULL) {
+ eta2theta(eta[,1], .llocation, earg= .elocation)
+ }, list( .elocation=elocation, .llocation=llocation ))),
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( .escale=escale, .lscale=lscale ))),
+ misc$link = c(location= .llocation, scale= .lscale)
+ misc$earg = list(location= .elocation, scale= .escale)
+ misc$expected = TRUE
+ misc$RegCondOK = FALSE # Save this for later
+ }), list( .escale=escale, .lscale=lscale,
+ .elocation=elocation, .llocation=llocation ))),
loglikelihood=eval(substitute(
function(mu,y,w,residuals= FALSE,eta, extra=NULL) {
- location = eta2theta(eta[,1], "identity", earg= list())
+ location = eta2theta(eta[,1], .llocation, earg= .elocation)
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( .escale=escale, .lscale=lscale ))),
+ sum(w * (-zedd - log(Scale) - log(2)))
+ }, list( .escale=escale, .lscale=lscale,
+ .elocation=elocation, .llocation=llocation ))),
vfamily=c("laplace"),
deriv=eval(substitute(expression({
- location = eta2theta(eta[,1], "identity", earg= list())
+ location = eta2theta(eta[,1], .llocation, earg= .elocation)
Scale = eta2theta(eta[,2], .lscale, earg= .escale)
zedd = abs(y-location) / Scale
dl.dlocation = sign(y-location) / Scale
- dlocation.deta = dtheta.deta(location, "identity", earg= list())
dl.dscale = zedd / Scale - 1/Scale
+ dlocation.deta = dtheta.deta(location, .llocation, earg= .elocation)
dscale.deta = dtheta.deta(Scale, .lscale, earg= .escale)
- if(iter == 1) {
- etanew = eta
- } else {
- derivold = derivnew
- etaold = etanew
- etanew = eta
- }
- derivnew = w * cbind(dl.dlocation * dlocation.deta,
- dl.dscale * dscale.deta)
- derivnew
- }), list( .escale=escale, .lscale=lscale ))),
+ w * cbind(dl.dlocation * dlocation.deta, dl.dscale * dscale.deta)
+ }), list( .escale=escale, .lscale=lscale,
+ .elocation=elocation, .llocation=llocation ))),
weight=eval(substitute(expression({
- if(iter == 1) {
- wznew = cbind(matrix(w, n, M), matrix(0, n, dimm(M)-M))
- } else {
- wzold = wznew
- wznew = qnupdate(w=w, wzold=wzold, dderiv=(derivold - derivnew),
- deta=etanew-etaold, M=M,
- trace=trace) # weights incorporated in args
- }
- wznew
- }), list( .escale=escale, .lscale=lscale ))))
+ d2l.dlocation2 = 1 / Scale^2
+ d2l.dscale2 = 1 / Scale^2
+ wz = matrix(0, nrow=n, ncol=2) # diagonal
+ wz[,iam(1,1,M)] = d2l.dlocation2 * dlocation.deta^2
+ wz[,iam(2,2,M)] = d2l.dscale2 * dscale.deta^2
+ w * wz
+ }), list( .escale=escale, .lscale=lscale,
+ .elocation=elocation, .llocation=llocation ))))
}
dlaplace = function(x, location=0, scale=1) {
@@ -8186,7 +8358,7 @@ fff = function(link="loge", earg=list(),
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 )))
+ 0.5*(df1+df2)*log1p(df1*y/df2)))
}, list( .link=link, .earg=earg ))),
vfamily=c("fff"),
deriv=eval(substitute(expression({
@@ -8195,12 +8367,12 @@ fff = function(link="loge", earg=list(),
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)
+ 0.5*log1p(df1*y/df2)
ddf1.deta = dtheta.deta(df1, .link, earg= .earg)
dl.ddf2 = 0.5*digamma(0.5*(df1+df2)) - 0.5*df1/df2 -
0.5*digamma(0.5*df2) -
0.5*(df1+df2) * (-df1*y/df2^2) / (1 + df1*y/df2) -
- 0.5*log(1 + df1*y/df2)
+ 0.5*log1p(df1*y/df2)
ddf2.deta = dtheta.deta(df2, .link, earg= .earg)
if(iter == 1) {
etanew = eta
@@ -8234,6 +8406,8 @@ vonmises = function(llocation="elogit",
escale=list(),
ilocation=NULL, iscale=NULL,
method.init=1, zero=NULL) {
+ if(mode(llocation) != "character" && mode(llocation) != "name")
+ llocation = as.character(substitute(llocation))
if(mode(lscale) != "character" && mode(lscale) != "name")
lscale = as.character(substitute(lscale))
if(!is.Numeric(method.init, allow=1, integ=TRUE, posit=TRUE) ||
@@ -8476,7 +8650,7 @@ qbenini = function(p, shape, y0) {
stop("bad input for argument \"p\"")
if(!is.Numeric(shape, posit=TRUE)) stop("bad input for argument \"shape\"")
if(!is.Numeric(y0, posit=TRUE)) stop("bad input for argument \"y0\"")
- y0 * exp(sqrt(-log(1-p) / shape))
+ y0 * exp(sqrt(-log1p(-p) / shape))
}
rbenini = function(n, shape, y0) {
@@ -8513,9 +8687,9 @@ benini = function(y0=stop("argument \"y0\" must be specified"),
probs = (1:3) / 4
qofy= quantile(rep(y, times=w), probs=probs) # fails if w != integer
if( .method.init == 1) {
- shape.init = mean(-log(1-probs) / (log(qofy))^2)
+ shape.init = mean(-log1p(-probs) / (log(qofy))^2)
} else {
- shape.init = median(-log(1-probs) / (log(qofy))^2)
+ shape.init = median(-log1p(-probs) / (log(qofy))^2)
}
shape.init = if(length(.ishape)) rep(.ishape, len=n) else
rep(shape.init, len=n)
@@ -8589,7 +8763,7 @@ rpolono = function(n, meanlog=0, sdlog=1) {
if(!is.Numeric(sdlog)) stop("bad input for argument \"sdlog\"")
meanlog = rep(meanlog, len=n); sdlog = rep(sdlog, len=n);
lambda = if(is.R()) rlnorm(n=n, meanlog=meanlog, sdlog=sdlog) else
- rlognormal(n=n, m=meanlog, s=sdlog, lambda=0)
+ stop("suppressing a warning message")
rpois(n=n, lambda=lambda)
}
@@ -8599,3 +8773,194 @@ rpolono = function(n, meanlog=0, sdlog=1) {
+
+
+dtriangle = function(x, theta, lower=0, upper=1) {
+ if(!is.Numeric(x)) stop("bad input for argument \"x\"")
+ if(!is.Numeric(theta)) stop("bad input for argument \"theta\"")
+ if(!is.Numeric(lower)) stop("bad input for argument \"lower\"")
+ if(!is.Numeric(upper)) stop("bad input for argument \"upper\"")
+ if(!all(lower < theta & theta < upper))
+ stop("lower < theta < upper values are required")
+ N = max(length(x), length(theta), length(lower), length(upper))
+ x = rep(x, len=N); lower = rep(lower, len=N); upper = rep(upper, len=N);
+ theta = rep(theta, len=N)
+ ans = x * 0
+ neg = (lower <= x) & (x <= theta)
+ pos = (theta <= x) & (x <= upper)
+ denom1 = ((upper-lower)*(theta-lower))
+ denom2 = ((upper-lower)*(upper-theta))
+ ans[neg] = pmax(2 * (x-lower) / denom1, 0)[neg]
+ ans[pos] = pmax(2 * (upper-x) / denom2, 0)[pos]
+ ans
+}
+
+
+rtriangle = function(n, theta, lower=0, upper=1) {
+ if(!is.Numeric(n, integ=TRUE,allow=1)) stop("bad input for argument \"n\"")
+ if(!is.Numeric(theta)) stop("bad input for argument \"theta\"")
+ if(!is.Numeric(lower)) stop("bad input for argument \"lower\"")
+ if(!is.Numeric(upper)) stop("bad input for argument \"upper\"")
+ if(!all(lower < theta & theta < upper))
+ stop("lower < theta < upper values are required")
+ N = n
+ lower = rep(lower, len=N); upper = rep(upper, len=N);
+ theta = rep(theta, len=N)
+ t1 = sqrt(runif(n))
+ t2 = sqrt(runif(n))
+ ifelse(runif(n) < (theta-lower)/(upper-lower),
+ lower + (theta-lower)*t1,
+ upper - (upper-theta)*t2)
+}
+
+
+qtriangle = function(p, theta, lower=0, upper=1) {
+ if(!is.Numeric(p, posit=TRUE)) stop("bad input for argument \"p\"")
+ if(!is.Numeric(theta)) stop("bad input for argument \"theta\"")
+ if(!is.Numeric(lower)) stop("bad input for argument \"lower\"")
+ if(!is.Numeric(upper)) stop("bad input for argument \"upper\"")
+ if(!all(lower < theta & theta < upper))
+ stop("lower < theta < upper values are required")
+
+ N = max(length(p), length(theta), length(lower), length(upper))
+ p = rep(p, len=N); lower = rep(lower, len=N); upper = rep(upper, len=N);
+ theta = rep(theta, len=N)
+
+ bad = (p < 0) | (p > 1)
+ if(any(bad))
+ stop("bad input for 'p'")
+
+ Neg = (p <= (theta - lower)/(upper - lower))
+ ans = as.numeric(NA) * p
+ temp1 = p * (upper-lower) * (theta-lower)
+ ans[ Neg] = lower[ Neg] + sqrt(temp1[ Neg])
+
+ Pos = (p >= (theta - lower)/(upper - lower))
+ if(any(Pos)) {
+ pstar = (p - (theta-lower)/(upper-lower)) / (1 -
+ (theta-lower)/(upper-lower))
+ qstar = cbind(1 - sqrt(1-pstar), 1 + sqrt(1-pstar))
+ qstar = qstar[Pos,]
+ qstar = ifelse(qstar[,1] >= 0 & qstar[,1] <= 1, qstar[,1], qstar[,2])
+ ans[Pos] = theta[Pos] + qstar * (upper-theta)[Pos]
+ }
+ ans
+}
+
+
+ptriangle = function(q, theta, lower=0, upper=1) {
+ if(!is.Numeric(q)) stop("bad input for argument \"q\"")
+ if(!is.Numeric(theta)) stop("bad input for argument \"theta\"")
+ if(!is.Numeric(lower)) stop("bad input for argument \"lower\"")
+ if(!is.Numeric(upper)) stop("bad input for argument \"upper\"")
+ if(!all(lower < theta & theta < upper))
+ stop("lower < theta < upper values are required")
+
+ N = max(length(q), length(theta), length(lower), length(upper))
+ q = rep(q, len=N); lower = rep(lower, len=N); upper = rep(upper, len=N);
+ theta = rep(theta, len=N)
+ ans = q * 0
+
+ qstar = (q - lower)^2 / ((upper-lower) * (theta-lower))
+ Neg = (lower <= q & q <= theta)
+ ans[Neg] = (qstar)[Neg]
+
+ Pos = (theta <= q & q <= upper)
+ qstar = (q - theta) / (upper-theta)
+ ans[Pos] = ((theta-lower)/(upper-lower))[Pos] +
+ (qstar * (2-qstar) * (upper-theta) / (upper - lower))[Pos]
+ ans[q >= upper] = 1
+ ans
+}
+
+
+
+triangle = function(lower=0, upper=1,
+ link="elogit", earg=if(link=="elogit")
+ list(min = lower, max = upper) else list(), itheta=NULL)
+{
+ if(!is.Numeric(lower)) stop("bad input for argument \"lower\"")
+ if(!is.Numeric(upper)) stop("bad input for argument \"upper\"")
+ if(!all(lower < upper))
+ stop("lower < upper values are required")
+ if(length(itheta) && !is.Numeric(itheta))
+ stop("bad input for 'itheta'")
+
+ if(mode(link) != "character" && mode(link) != "name")
+ link = as.character(substitute(link))
+ if(!is.list(earg)) earg = list()
+
+ new("vglmff",
+ blurb=c(
+ "Triangle distribution\n\n",
+ "Link: ",
+ namesof("theta", link, earg=earg)),
+ initialize=eval(substitute(expression({
+ y = as.numeric(y)
+ if(ncol(cbind(y)) != 1)
+ stop("response must be a vector or a one-column matrix")
+ extra$lower = rep( .lower, len=n)
+ extra$upper = rep( .upper, len=n)
+
+ if(any(y <= extra$lower | y >= extra$upper))
+ stop("some y values in [lower,upper] detected")
+ predictors.names = namesof("theta", .link, earg= .earg, tag=FALSE)
+ if(!length(etastart)) {
+ Theta.init = if(length( .itheta)) .itheta else {
+ weighted.mean(y, w)
+ }
+ Theta.init = rep(Theta.init, length=n)
+ etastart = theta2eta(Theta.init, .link, earg= .earg )
+ }
+ }), list( .link=link, .earg=earg, .itheta=itheta,
+ .upper=upper, .lower=lower ))),
+ inverse=eval(substitute(function(eta, extra=NULL) {
+ Theta = eta2theta(eta, .link, earg= .earg )
+ lower = extra$lower
+ upper = extra$upper
+ mu = ((Theta^3 / 3 - lower * Theta^2 / 2 +
+ lower^3 / 6) / (Theta - lower) +
+ ((Theta^3 / 3 - upper * Theta^2 / 2 +
+ upper^3 / 6) / (upper - Theta))) * 2 / (upper-lower)
+ mu
+ }, list( .link=link, .earg=earg ))),
+ last=eval(substitute(expression({
+ misc$link = c(theta = .link)
+ misc$earg = list(theta = .earg)
+ misc$expected = TRUE
+ }), list( .link=link, .earg=earg ))),
+ loglikelihood=eval(substitute(
+ function(mu,y,w,residuals= FALSE,eta, extra=NULL) {
+ Theta = eta2theta(eta, .link, earg= .earg )
+ lower = extra$lower
+ upper = extra$upper
+ if(residuals) stop("loglikelihood residuals not implemented yet") else {
+ pos = y >= Theta
+ neg = y < Theta
+ sum(w * (log(2) - log(upper-lower))) +
+ sum(w[neg]*(log(y[neg]-lower[neg]) - log(Theta[neg]-lower[neg]))) +
+ sum(w[pos]*(log(upper[pos]-y[pos]) - log(upper[pos]-Theta[pos])))
+ }
+ }, list( .link=link, .earg=earg ))),
+ vfamily=c("triangle"),
+ deriv=eval(substitute(expression({
+ Theta = eta2theta(eta, .link, earg= .earg )
+ dTheta.deta = dtheta.deta(Theta, .link, earg= .earg )
+ pos = y > Theta
+ neg = y < Theta
+ lower = extra$lower
+ upper = extra$upper
+ dl.dTheta = 0 * y
+ dl.dTheta[neg] = -1 / (Theta[neg]-lower[neg])
+ dl.dTheta[pos] = 1 / (upper[pos]-Theta[pos])
+ dl.dTheta * dTheta.deta
+ }), list( .link=link, .earg=earg ))),
+ weight=eval(substitute(expression({
+ d2l.dTheta2 = 1 / ((Theta-lower)*(upper-Theta))
+ wz = dTheta.deta^2 * d2l.dTheta2
+ w * wz
+ }), list( .link=link, .earg=earg ))))
+}
+
+
+
diff --git a/R/family.zeroinf.q b/R/family.zeroinf.q
index c7dbd91..78adea3 100644
--- a/R/family.zeroinf.q
+++ b/R/family.zeroinf.q
@@ -114,7 +114,7 @@ yip88 = function(link.lambda="loge", n.arg=NULL)
loglikelihood=eval(substitute(
function(mu,y,w,residuals=FALSE, eta, extra=NULL) {
lambda = eta2theta(eta, .link.lambda)
- lstar = -lambda + y * log(lambda) - log(1-exp(-lambda))
+ lstar = -lambda + y * log(lambda) - log1p(-exp(-lambda))
sum(w * lstar)
}, list( .link.lambda=link.lambda ))),
vfamily=c("yip88"),
@@ -151,7 +151,7 @@ zapoisson = function(lp0="logit", llambda="loge",
"Zero-altered Poisson (binomial and positive-Poisson conditional model)\n\n",
"Links: ",
namesof("p0", lp0, earg=ep0, tag=FALSE), ", ",
- namesof("lambda", llambda, earg= .elambda, tag=FALSE),
+ namesof("lambda", llambda, earg= elambda, tag=FALSE),
"\n"),
constraints=eval(substitute(expression({
temp752 = .zero
@@ -206,8 +206,8 @@ zapoisson = function(lp0="logit", llambda="loge",
ans = 0
for(spp. in 1:NOS) {
ans = ans + sum(w[skip[,spp.]] * log(p0[skip[,spp.],spp.])) +
- sum(w[!skip[,spp.]] * (log(1-p0[!skip[,spp.],spp.]) -
- log(1-exp(-lambda[!skip[,spp.],spp.])) -
+ sum(w[!skip[,spp.]] * (log1p(-p0[!skip[,spp.],spp.]) -
+ log1p(-exp(-lambda[!skip[,spp.],spp.])) -
lambda[!skip[,spp.],spp.] +
y[!skip[,spp.],spp.]*log(lambda[!skip[,spp.],spp.])))
}
@@ -374,14 +374,14 @@ zanegbinomial = function(lp0="logit", lmunb = "loge", lk = "loge",
for(spp. in 1:NOS) {
i8 = skip[,spp.]
ans = ans + sum(w[i8] * log(p0[i8,spp.])) +
- sum(w[!i8] * (log(1-p0[!i8,spp.]) + y[!i8,spp.] *
+ sum(w[!i8] * (log1p(-p0[!i8,spp.]) + y[!i8,spp.] *
log(munb[!i8,spp.]/(munb[!i8,spp.]+
kmat[!i8,spp.])) + kmat[!i8,spp.]*log(kmat[!i8,spp.] /
(munb[!i8,spp.]+kmat[!i8,spp.])) +
lgamma(y[!i8,spp.]+kmat[!i8,spp.]) -
lgamma(kmat[!i8,spp.]) - lgamma(y[!i8,spp.]+1) -
(if(is.R())
- log1p(-pnb0[!i8,spp.]) else log(1 - pnb0[!i8,spp.]))))
+ log1p(-pnb0[!i8,spp.]) else log1p( - pnb0[!i8,spp.]))))
}
ans
}, list( .lp0=lp0, .lmunb=lmunb, .lk=lk,
@@ -497,7 +497,8 @@ rposnegbin = function(n, munb, k) {
zipoisson = function(lphi="logit", llambda="loge",
ephi=list(), elambda =list(),
- iphi=NULL, zero=NULL)
+ iphi=NULL, method.init=1,
+ shrinkage.init=0.8, zero=NULL)
{
if(mode(lphi) != "character" && mode(lphi) != "name")
lphi = as.character(substitute(lphi))
@@ -508,6 +509,10 @@ zipoisson = function(lphi="logit", llambda="loge",
stop("iphi must be a single number inside the interval (0,1)")
if(!is.list(ephi)) ephi = list()
if(!is.list(elambda)) elambda = list()
+ if(!is.Numeric(method.init, allow=1, integ=TRUE, posit=TRUE) ||
+ method.init > 2) stop("argument \"method.init\" must be 1 or 2")
+ if(!is.Numeric(shrinkage.init, allow=1) || shrinkage.init < 0 ||
+ shrinkage.init > 1) stop("bad input for argument \"shrinkage.init\"")
new("vglmff",
blurb=c("Zero-inflated Poisson\n\n",
@@ -526,14 +531,23 @@ zipoisson = function(lphi="logit", llambda="loge",
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
+ phi.init[phi.init <= 0] = 0.05 # Last resort
+ phi.init[phi.init >= 1] = 0.95 # Last resort
+ if( .method.init == 2) {
+ mymean = weighted.mean(y[y>0], w[y>0]) + 1/16
+ lambda.init = (1- .sinit) * (y+1/8) + .sinit * mymean
+ } else {
+ mymedian = median(y[y>0]) + 1/16
+ lambda.init = (1- .sinit) * (y+1/8) + .sinit * mymedian
+ }
etastart = cbind(theta2eta(rep(phi.init, len=n), .lphi, earg= .ephi ),
theta2eta(lambda.init, .llambda, earg= .ephi ))
}
}), list( .lphi=lphi, .llambda=llambda,
.ephi=ephi, .elambda=elambda,
- .iphi=iphi ))),
+ .method.init=method.init,
+ .iphi=iphi,
+ .sinit=shrinkage.init ))),
inverse=eval(substitute(function(eta, extra=NULL) {
phi = eta2theta(eta[,1], .lphi, earg= .ephi )
lambda = eta2theta(eta[,2], .llambda, earg= .elambda )
@@ -552,18 +566,25 @@ zipoisson = function(lphi="logit", llambda="loge",
.ephi=ephi, .elambda=elambda ))),
loglikelihood=eval(substitute(
function(mu,y,w,residuals=FALSE, eta, extra=NULL) {
+ smallno = 100 * .Machine$double.eps
phi = eta2theta(eta[,1], .lphi, earg= .ephi )
+ phi = pmax(phi, smallno)
+ phi = pmin(phi, 1.0-smallno)
lambda = eta2theta(eta[,2], .llambda, earg= .elambda )
index = (y==0)
- tmp8 = phi + (1-phi)*exp(-lambda)
+ tmp8 = phi + (1.0-phi)*exp(-lambda)
ell0 = log(tmp8[index])
- ell1 = log((1-phi[!index]) * dpois(y[!index], lambda= lambda[!index]))
+ ell1 = log1p(-phi[!index]) +
+ dpois(y[!index], lambda= lambda[!index], log=TRUE)
sum(w[index] * ell0) + sum(w[!index] * ell1)
}, list( .lphi=lphi, .llambda=llambda,
.ephi=ephi, .elambda=elambda ))),
vfamily=c("zipoisson"),
deriv=eval(substitute(expression({
+ smallno = 100 * .Machine$double.eps
phi = eta2theta(eta[,1], .lphi, earg= .ephi )
+ phi = pmax(phi, smallno)
+ phi = pmin(phi, 1.0-smallno)
lambda = eta2theta(eta[,2], .llambda, earg= .elambda )
tmp8 = phi + (1-phi)*exp(-lambda)
index = (y==0)
@@ -600,7 +621,6 @@ zipoisson = function(lphi="logit", llambda="loge",
-
zibinomial = function(lphi="logit", link.mu="logit",
ephi=list(), emu=list(),
iphi=NULL, zero=1, mv=FALSE)
@@ -688,7 +708,7 @@ zibinomial = function(lphi="logit", link.mu="logit",
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]),
+ ell1 = log1p(-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,
diff --git a/R/plot.vglm.q b/R/plot.vglm.q
index 1b66f52..8710a63 100644
--- a/R/plot.vglm.q
+++ b/R/plot.vglm.q
@@ -358,22 +358,8 @@ plotvglm <- function(x, residuals=NULL, smooths= FALSE,
{
stop("this function hasn't been written yet") # zz
- M <- x at misc$M
- true.mu <- object at misc$true.mu
- response <- as.matrix(x at y)
- if(is.null(true.mu))
- true.mu <- T
-
- Residuals <- resid(x, type="deviance")
- if(!is.null(residuals))
- {
- if(length(residuals) == 1 && residuals)
- residuals <- Residuals else
- Residuals <- residuals
- }
- if(ncol(response)==1 && true.mu && !is.null(Residuals))
- invisible(NextMethod("plot")) else
+
invisible(x)
}
@@ -417,12 +403,10 @@ plotpreplotvgam <- function(x, y=NULL, residuals=NULL,
} else {
dummy <- function(residuals=NULL, rugplot= TRUE, se= FALSE, scale=0,
offset.arg=0, deriv.arg=0, overlay= FALSE,
- which.cf=NULL, control=plotvgam.control(...))
+ which.cf=NULL, control=plotvgam.control())
c(list(residuals=residuals, rugplot=rugplot, se=se, scale=scale,
- offset.arg=offset.arg, deriv.arg=deriv.arg,
- overlay=overlay,
- which.cf=which.cf),
- control)
+ offset.arg=offset.arg, deriv.arg=deriv.arg, overlay=overlay,
+ which.cf=which.cf), control)
d <- dummy(residuals=residuals, rugplot=rugplot, se=se, scale=scale,
offset.arg=offset.arg, deriv.arg=deriv.arg,
diff --git a/R/predict.vglm.q b/R/predict.vglm.q
index cef470c..3c8a06a 100644
--- a/R/predict.vglm.q
+++ b/R/predict.vglm.q
@@ -191,6 +191,8 @@ predict.rrvglm = function(object,
dispersion=dispersion, ...))
}
+ na.act = object at na.action
+
if(!length(newdata) && length(na.act)) {
if(se.fit) {
pred$fitted.values = napredict(na.act[[1]], pred$fitted.values)
diff --git a/R/print.summary.others.q b/R/print.summary.others.q
index daca261..01338ab 100644
--- a/R/print.summary.others.q
+++ b/R/print.summary.others.q
@@ -4,16 +4,13 @@
-
+if(FALSE)
printsummary.lms <- function(x, digits = NULL, quote = TRUE, prefix = "")
{
printsummary.vglm(x, digits = NULL, quote = TRUE, prefix = "")
- cat("\nLMS method!!!\n")
- cat("\nfirst 4 rows of $lin are\n")
- print.matrix(x$testing)
invisible(NULL)
}
diff --git a/R/smart.R b/R/smart.R
index aa81523..6992bbf 100644
--- a/R/smart.R
+++ b/R/smart.R
@@ -10,451 +10,6 @@
-lm <-
-function (formula, data, subset, weights, na.action, method = "qr",
- model = TRUE, x = FALSE, y = FALSE, qr = TRUE, singular.ok = TRUE,
- contrasts = NULL, offset, smart=TRUE, ...)
-{
- ret.x <- x
- ret.y <- y
-
- if(smart) setup.smart("write")
-
- cl <- match.call()
- mf <- match.call(expand.dots = FALSE)
- m <- match(c("formula", "data", "subset", "weights", "na.action",
- "offset"), names(mf), 0)
- mf <- mf[c(1, m)]
- mf$drop.unused.levels <- TRUE
- mf$smart <- NULL
- mf[[1]] <- as.name("model.frame")
- mf <- eval(mf, parent.frame())
- if (method == "model.frame")
- return(mf) else if (method != "qr")
- warning(gettextf("method = '%s' is not supported. Using 'qr'",
- method), domain = NA)
- mt <- attr(mf, "terms")
- y <- model.response(mf, "numeric")
- w <- as.vector(model.weights(mf))
- if (!is.null(w) && !is.numeric(w))
- stop("'weights' must be a numeric vector")
- offset <- as.vector(model.offset(mf))
- if (!is.null(offset)) {
- if (length(offset) == 1)
- offset <- rep(offset, NROW(y)) else if (length(offset) != NROW(y))
- stop(gettextf("number of offsets is %d, should equal %d (number of observations)",
- length(offset), NROW(y)), domain = NA)
- }
- if (is.empty.model(mt)) {
- x <- NULL
- z <- list(coefficients = if (is.matrix(y)) matrix(, 0,
- 3) else numeric(0), residuals = y, fitted.values = 0 *
- y, weights = w, rank = 0, df.residual = if (is.matrix(y)) nrow(y) else length(y))
- if (!is.null(offset))
- z$fitted.values <- offset
- } else {
- x <- model.matrix(mt, mf, contrasts)
- z <- if (is.null(w))
- lm.fit(x, y, offset = offset, singular.ok = singular.ok,
- ...) else
- lm.wfit(x, y, w, offset = offset, singular.ok = singular.ok,
- ...)
- }
- class(z) <- c(if (is.matrix(y)) "mlm", "lm")
- z$na.action <- attr(mf, "na.action")
- z$offset <- offset
- z$contrasts <- attr(x, "contrasts")
- z$xlevels <- .getXlevels(mt, mf)
- z$call <- cl
- z$terms <- mt
- if (model)
- z$model <- mf
- if (ret.x)
- z$x <- x
- if (ret.y)
- z$y <- y
- if (!qr)
- z$qr <- NULL
-
- if(smart) {
- z$smart.prediction <- get.smart.prediction()
- wrapup.smart()
- } else
- z$smart.prediction <- list(smart.arg=FALSE)
-
- z
-}
-attr(lm, "smart") <- TRUE
-
-
-predict.lm <-
-function (object, newdata, se.fit = FALSE, scale = NULL, df = Inf,
- interval = c("none", "confidence", "prediction"), level = 0.95,
- type = c("response", "terms"), terms = NULL, na.action = na.pass,
- pred.var = res.var/weights, weights = 1, ...)
-{
- # Smart prediction: handle the prediction flaw
- if(is.smart(object) && length(object$smart.prediction)) {
- setup.smart("read", smart.prediction=object$smart.prediction)
- }
-
- tt <- terms(object)
- if (missing(newdata) || is.null(newdata)) {
- mm <- X <- model.matrix(object)
- mmDone <- TRUE
- offset <- object$offset
- } else {
- Terms <- delete.response(tt)
- m <- model.frame(Terms, newdata, na.action = na.action,
- xlev = object$xlevels)
- if (!is.null(cl <- attr(Terms, "dataClasses")))
- .checkMFClasses(cl, m)
- X <- model.matrix(Terms, m, contrasts = object$contrasts)
- offset <- if (!is.null(off.num <- attr(tt, "offset")))
- eval(attr(tt, "variables")[[off.num + 1]], newdata) else
- if (!is.null(object$offset))
- eval(object$call$offset, newdata)
- mmDone <- FALSE
- }
- n <- length(object$residuals)
- p <- object$rank
- p1 <- seq_len(p)
- piv <- object$qr$pivot[p1]
- if (p < ncol(X) && !(missing(newdata) || is.null(newdata)))
- warning("prediction from a rank-deficient fit may be misleading")
- beta <- object$coefficients
- predictor <- drop(X[, piv, drop = FALSE] %*% beta[piv])
- if (!is.null(offset))
- predictor <- predictor + offset
- interval <- match.arg(interval)
- if (interval == "prediction") {
- if (missing(newdata))
- warning("Predictions on current data refer to _future_ responses\n")
- if (missing(newdata) && missing(weights)) {
- w <- weights.default(object)
- if (!is.null(w)) {
- weights <- w
- warning("Assuming prediction variance inversely proportional to weights used for fitting\n")
- }
- }
- if (!missing(newdata) && missing(weights) && !is.null(object$weights) &&
- missing(pred.var))
- warning("Assuming constant prediction variance even though model fit is weighted\n")
- if (inherits(weights, "formula")) {
- if (length(weights) != 2)
- stop("'weights' as formula should be one-sided")
- d <- if (missing(newdata) || is.null(newdata))
- model.frame(object) else newdata
- weights <- eval(weights[[2]], d, environment(weights))
- }
- }
- type <- match.arg(type)
- if (se.fit || interval != "none") {
- res.var <- if (is.null(scale)) {
- r <- object$residuals
- w <- object$weights
- rss <- sum(if (is.null(w))
- r^2 else r^2 * w)
- df <- n - p
- rss/df
- } else scale^2
- if (type != "terms") {
- if (p > 0) {
- XRinv <- if (missing(newdata) && is.null(w))
- qr.Q(object$qr)[, p1, drop = FALSE] else
- X[, piv] %*% qr.solve(qr.R(object$qr)[p1,
- p1])
- ip <- drop(XRinv^2 %*% rep(res.var, p))
- } else ip <- rep(0, n)
- }
- }
- if (type == "terms") {
- if (!mmDone) {
- mm <- model.matrix(object)
- mmDone <- TRUE
- }
- aa <- attr(mm, "assign")
- ll <- attr(tt, "term.labels")
- hasintercept <- attr(tt, "intercept") > 0
- if (hasintercept)
- ll <- c("(Intercept)", ll)
- aaa <- factor(aa, labels = ll)
- asgn <- split(order(aa), aaa)
- if (hasintercept) {
- asgn$"(Intercept)" <- NULL
- if (!mmDone) {
- mm <- model.matrix(object)
- mmDone <- TRUE
- }
- avx <- colMeans(mm)
- termsconst <- sum(avx[piv] * beta[piv])
- }
- nterms <- length(asgn)
- if (nterms > 0) {
- predictor <- matrix(ncol = nterms, nrow = NROW(X))
- dimnames(predictor) <- list(rownames(X), names(asgn))
- if (se.fit || interval != "none") {
- ip <- matrix(ncol = nterms, nrow = NROW(X))
- dimnames(ip) <- list(rownames(X), names(asgn))
- Rinv <- qr.solve(qr.R(object$qr)[p1, p1])
- }
- if (hasintercept)
- X <- sweep(X, 2, avx)
- unpiv <- rep.int(0, NCOL(X))
- unpiv[piv] <- p1
- for (i in seq(1, nterms, length = nterms)) {
- iipiv <- asgn[[i]]
- ii <- unpiv[iipiv]
- iipiv[ii == 0] <- 0
- predictor[, i] <- if (any(iipiv) > 0)
- X[, iipiv, drop = FALSE] %*% beta[iipiv] else 0
- if (se.fit || interval != "none")
- ip[, i] <- if (any(iipiv) > 0)
- as.matrix(X[, iipiv, drop = FALSE] %*% Rinv[ii,
- , drop = FALSE])^2 %*% rep.int(res.var,
- p) else 0
- }
- if (!is.null(terms)) {
- predictor <- predictor[, terms, drop = FALSE]
- if (se.fit)
- ip <- ip[, terms, drop = FALSE]
- }
- } else {
- predictor <- ip <- matrix(0, n, 0)
- }
- attr(predictor, "constant") <- if (hasintercept)
- termsconst else 0
- }
- if (interval != "none") {
- tfrac <- qt((1 - level)/2, df)
- hwid <- tfrac * switch(interval, confidence = sqrt(ip),
- prediction = sqrt(ip + pred.var))
- if (type != "terms") {
- predictor <- cbind(predictor, predictor + hwid %o%
- c(1, -1))
- colnames(predictor) <- c("fit", "lwr", "upr")
- } else {
- lwr <- predictor + hwid
- upr <- predictor - hwid
- }
- }
- if (se.fit || interval != "none")
- se <- sqrt(ip)
- if (missing(newdata) && !is.null(na.act <- object$na.action)) {
- predictor <- napredict(na.act, predictor)
- if (se.fit)
- se <- napredict(na.act, se)
- }
-
- if(is.smart(object) && length(object$smart.prediction)) {
- wrapup.smart()
- }
-
- if (type == "terms" && interval != "none") {
- if (missing(newdata) && !is.null(na.act)) {
- lwr <- napredict(na.act, lwr)
- upr <- napredict(na.act, upr)
- }
- list(fit = predictor, se.fit = se, lwr = lwr, upr = upr,
- df = df, residual.scale = sqrt(res.var))
- } else if (se.fit)
- list(fit = predictor, se.fit = se, df = df,
- residual.scale = sqrt(res.var)) else predictor
-}
-attr(predict.lm, "smart") <- TRUE
-
-
-predict.glm <-
-function (object, newdata = NULL, type = c("link", "response",
- "terms"), se.fit = FALSE, dispersion = NULL, terms = NULL,
- na.action = na.pass, ...)
-{
- # Smart prediction: handle the prediction flaw
- if(is.smart(object) && length(object$smart.prediction)) {
- setup.smart("read", smart.prediction=object$smart.prediction)
- }
-
- type <- match.arg(type)
- na.act <- object$na.action
- object$na.action <- NULL
- if (!se.fit) {
- if (missing(newdata)) {
- pred <- switch(type, link = object$linear.predictors,
- response = object$fitted, terms = predict.lm(object,
- se.fit = se.fit, scale = 1, type = "terms",
- terms = terms))
- if (!is.null(na.act))
- pred <- napredict(na.act, pred)
- } else {
- pred <- predict.lm(object, newdata, se.fit, scale = 1,
- type = ifelse(type == "link", "response", type),
- terms = terms, na.action = na.action)
- switch(type, response = {
- pred <- family(object)$linkinv(pred)
- }, link = , terms = )
- }
- } else {
- if (inherits(object, "survreg"))
- dispersion <- 1
- if (is.null(dispersion) || dispersion == 0)
- dispersion <- summary(object, dispersion = dispersion)$dispersion
- residual.scale <- as.vector(sqrt(dispersion))
- pred <- predict.lm(object, newdata, se.fit, scale = residual.scale,
- type = ifelse(type == "link", "response", type),
- terms = terms, na.action = na.action)
- fit <- pred$fit
- se.fit <- pred$se.fit
- switch(type, response = {
- se.fit <- se.fit * abs(family(object)$mu.eta(fit))
- fit <- family(object)$linkinv(fit)
- }, link = , terms = )
- if (missing(newdata) && !is.null(na.act)) {
- fit <- napredict(na.act, fit)
- se.fit <- napredict(na.act, se.fit)
- }
- pred <- list(fit = fit, se.fit = se.fit, residual.scale = residual.scale)
- }
- if(is.smart(object) && length(object$smart.prediction)) {
- wrapup.smart()
- }
- pred
-}
-attr(predict.glm, "smart") <- TRUE
-
-
-predict.mlm <-
-function (object, newdata, se.fit = FALSE, na.action = na.pass,
- ...)
-{
- # Smart prediction: handle the prediction flaw
- if(is.smart(object) && length(object$smart.prediction)) {
- setup.smart("read", smart.prediction=object$smart.prediction)
- }
-
- if (missing(newdata))
- return(object$fitted)
- if (se.fit)
- stop("the 'se.fit' argument is not yet implemented for \"mlm\" objects")
- if (missing(newdata)) {
- X <- model.matrix(object)
- offset <- object$offset
- } else {
- tt <- terms(object)
- Terms <- delete.response(tt)
- m <- model.frame(Terms, newdata, na.action = na.action,
- xlev = object$xlevels)
- if (!is.null(cl <- attr(Terms, "dataClasses")))
- .checkMFClasses(cl, m)
- X <- model.matrix(Terms, m, contrasts = object$contrasts)
- offset <- if (!is.null(off.num <- attr(tt, "offset")))
- eval(attr(tt, "variables")[[off.num + 1]], newdata) else
- if (!is.null(object$offset))
- eval(object$call$offset, newdata)
- }
- piv <- object$qr$pivot[seq(object$rank)]
- pred <- X[, piv, drop = FALSE] %*% object$coefficients[piv,
- ]
- if (!is.null(offset))
- pred <- pred + offset
-
- if(is.smart(object) && length(object$smart.prediction)) {
- wrapup.smart()
- }
-
- if (inherits(object, "mlm")) pred else pred[, 1]
-}
-attr(predict.mlm, "smart") <- TRUE
-
-
-
-glm <-
-function (formula, family = gaussian, data, weights, subset,
- na.action, start = NULL, etastart, mustart, offset, control = glm.control(...),
- model = TRUE, method = "glm.fit", x = FALSE, y = TRUE, contrasts = NULL,
- smart = TRUE, ...)
-{
- call <- match.call()
- if (is.character(family))
- family <- get(family, mode = "function", envir = parent.frame())
- if (is.function(family))
- family <- family()
- if (is.null(family$family)) {
- print(family)
- stop("'family' not recognized")
- }
- if (missing(data))
- data <- environment(formula)
-
- if(smart) setup.smart("write")
-
- mf <- match.call(expand.dots = FALSE)
- m <- match(c("formula", "data", "subset", "weights", "na.action",
- "etastart", "mustart", "offset"), names(mf), 0)
- mf <- mf[c(1, m)]
- mf$smart <- NULL
- mf$drop.unused.levels <- TRUE
- mf[[1]] <- as.name("model.frame")
- mf <- eval(mf, parent.frame())
- switch(method, model.frame = return(mf), glm.fit = 1, stop("invalid 'method': ",
- method))
- mt <- attr(mf, "terms")
- Y <- model.response(mf, "any")
- if (length(dim(Y)) == 1) {
- nm <- rownames(Y)
- dim(Y) <- NULL
- if (!is.null(nm))
- names(Y) <- nm
- }
- X <- if (!is.empty.model(mt))
- model.matrix(mt, mf, contrasts) else matrix(, NROW(Y), 0)
- weights <- as.vector(model.weights(mf))
- if (!is.null(weights) && !is.numeric(weights))
- stop("'weights' must be a numeric vector")
- offset <- as.vector(model.offset(mf))
- if (!is.null(weights) && any(weights < 0))
- stop("negative weights not allowed")
- if (!is.null(offset)) {
- if (length(offset) == 1)
- offset <- rep(offset, NROW(Y)) else
- if (length(offset) != NROW(Y))
- stop(gettextf(
- "number of offsets is %d should equal %d (number of observations)",
- length(offset), NROW(Y)), domain = NA)
- }
- mustart <- model.extract(mf, "mustart")
- etastart <- model.extract(mf, "etastart")
- fit <- glm.fit(x = X, y = Y, weights = weights, start = start,
- etastart = etastart, mustart = mustart, offset = offset,
- family = family, control = control, intercept = attr(mt,
- "intercept") > 0)
- if (length(offset) && attr(mt, "intercept") > 0) {
- fit$null.deviance <- glm.fit(x = X[, "(Intercept)", drop = FALSE],
- y = Y, weights = weights, offset = offset, family = family,
- control = control, intercept = TRUE)$deviance
- }
- if (model)
- fit$model <- mf
- fit$na.action <- attr(mf, "na.action")
- if (x)
- fit$x <- X
- if (!y)
- fit$y <- NULL
- fit <- c(fit, list(call = call, formula = formula, terms = mt,
- data = data, offset = offset, control = control, method = method,
- contrasts = attr(X, "contrasts"), xlevels = .getXlevels(mt,
- mf)))
- class(fit) <- c("glm", "lm")
-
- if(smart) {
- fit$smart.prediction <- get.smart.prediction()
- wrapup.smart()
- } else
- fit$smart.prediction <- list(smart.arg=FALSE)
-
- fit
-}
-attr(glm, "smart") <- TRUE
-
diff --git a/R/summary.vglm.q b/R/summary.vglm.q
index 15a2562..bac5fa3 100644
--- a/R/summary.vglm.q
+++ b/R/summary.vglm.q
@@ -194,6 +194,10 @@ vcovvlm <- function(object, dispersion=NULL, untransform=FALSE) {
is.Numeric(so at dispersion)) so at dispersion else 1
answer = d * so at cov.unscaled
+ if(is.logical(OKRC <- object at misc$RegCondOK) && !OKRC)
+ warning(paste("MLE regularity conditions were violated",
+ "at the final iteration of the fitted object"))
+
if(!untransform) return(answer)
if(!is.logical(object at misc$intercept.only))
diff --git a/R/vgam.R b/R/vgam.R
index 9cf6fe0..7a1bb39 100644
--- a/R/vgam.R
+++ b/R/vgam.R
@@ -151,7 +151,7 @@ vgam <- function(formula,
function.name=function.name, ...)
- if(any(fit$nl.df < 0)) {
+ if(is.Numeric(fit$nl.df) && any(fit$nl.df < 0)) {
fit$nl.df[fit$nl.df < 0] = 0
}
@@ -246,7 +246,8 @@ vgam <- function(formula,
if(nonparametric) {
slot(answer, "Bspline") = fit$Bspline
slot(answer, "nl.chisq") = fit$nl.chisq
- slot(answer, "nl.df") = fit$nl.df
+ if(is.Numeric(fit$nl.df))
+ slot(answer, "nl.df") = fit$nl.df
slot(answer, "spar") = fit$spar
slot(answer, "s.xargument") = fit$s.xargument
if(length(fit$var)) {
diff --git a/R/vsmooth.spline.q b/R/vsmooth.spline.q
index 2a16a3c..1e9d270 100644
--- a/R/vsmooth.spline.q
+++ b/R/vsmooth.spline.q
@@ -207,7 +207,9 @@ vsmooth.spline <- function(x, y, w, df=rep(5,M), spar=NULL, # rep(0,M),
ispar <- 1
if(any(spar <= 0) || !is.numeric(spar))
stop("not allowed non-positive or non-numeric smoothing parameters")
- nonlin <- if(is.R()) (spar != Inf) else (!is.inf(spar))
+
+
+ nonlin <- (spar != Inf)
} else {
ispar <- 0
if(!is.numeric(df) || any(df < 2 | df > nef))
@@ -482,7 +484,8 @@ predictvsmooth.spline <- function(object, x, deriv=0, se.fit=FALSE)
if(!length(nlfit at knots))
return(list(x=x, y=pred))
- nonlin <- if(is.R()) (object at spar != Inf) else (!is.inf(object at spar))
+
+ nonlin <- (object at spar != Inf)
conmat <- if(!length(lfit at constraints)) diag(M) else lfit at constraints[[2]]
conmat <- conmat[,nonlin,drop=FALSE] # Of nonlinear functions
diff --git a/data/aml.R b/data/aml.R
new file mode 100644
index 0000000..65e3390
--- /dev/null
+++ b/data/aml.R
@@ -0,0 +1,10 @@
+`aml` <-
+structure(list(time = c(9, 13, 13, 18, 23, 28, 31, 34, 45, 48,
+161, 5, 5, 8, 8, 12, 16, 23, 27, 30, 33, 43, 45), status = c(1,
+1, 0, 1, 1, 0, 1, 1, 0, 1, 0, 1, 1, 1, 1, 1, 0, 1, 1, 1, 1, 1,
+1), x = structure(c(1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L,
+2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L), .Label = c("Maintained",
+"Nonmaintained"), class = "factor")), .Names = c("time", "status",
+"x"), row.names = c("1", "2", "3", "4", "5", "6", "7", "8", "9",
+"10", "11", "12", "13", "14", "15", "16", "17", "18", "19", "20",
+"21", "22", "23"), class = "data.frame")
diff --git a/data/toxop.R b/data/toxop.R
new file mode 100644
index 0000000..f0468a5
--- /dev/null
+++ b/data/toxop.R
@@ -0,0 +1,11 @@
+`toxop` <-
+structure(list(rainfall = c(1735, 1936, 2000, 1973, 1750, 1800,
+1750, 2077, 1920, 1800, 2050, 1830, 1650, 2200, 2000, 1770, 1920,
+1770, 2240, 1620, 1756, 1650, 2250, 1796, 1890, 1871, 2063, 2100,
+1918, 1834, 1780, 1900, 1976, 2292), ssize = c(4, 10, 5, 10,
+2, 5, 8, 19, 6, 10, 24, 1, 30, 22, 1, 11, 1, 54, 9, 18, 12, 1,
+11, 77, 51, 16, 82, 13, 43, 75, 13, 10, 6, 37), cityNo = 1:34,
+ positive = c(2, 3, 1, 3, 2, 3, 2, 7, 3, 8, 7, 0, 15, 4, 0,
+ 6, 0, 33, 4, 5, 2, 0, 8, 41, 24, 7, 46, 9, 23, 53, 8, 3,
+ 1, 23)), .Names = c("rainfall", "ssize", "cityNo", "positive"
+), row.names = c(NA, -34L), class = "data.frame")
diff --git a/man/Links.Rd b/man/Links.Rd
index 8e1579d..36c7587 100644
--- a/man/Links.Rd
+++ b/man/Links.Rd
@@ -74,7 +74,8 @@ TypicalVGAMlinkFunction(theta, earg=list(), inverse=FALSE,
or a character description of the link.
Here are the general details.
- If \code{inverse=FALSE} and \code{deriv=0} (default) then the ordinary link
+ If \code{inverse=FALSE} and \code{deriv=0} (default) then the
+ ordinary link
function \eqn{\eta=g(\theta)}{eta=g(theta)} is returned.
If \code{inverse=FALSE} and \code{deriv=1} then it is
\eqn{d\theta / d\eta}{d theta / d eta}
diff --git a/man/Surv.Rd b/man/Surv.Rd
new file mode 100644
index 0000000..7e8cc20
--- /dev/null
+++ b/man/Surv.Rd
@@ -0,0 +1,137 @@
+\name{Surv}
+\alias{Surv}
+\alias{is.SurvS4}
+\alias{print.SurvS4}
+\alias{Math.SurvS4}
+\alias{Summary.SurvS4}
+\alias{[.SurvS4}
+\alias{format.SurvS4}
+\alias{as.data.frame.SurvS4}
+\alias{as.character.SurvS4}
+\alias{is.na.SurvS4}
+\alias{Ops.SurvS4}
+\title{
+Create a Survival Object
+}
+\description{
+ Create a survival object, usually used as a response variable in a
+ model formula.
+}
+\usage{
+Surv(time, time2, event, type =, origin = 0)
+is.SurvS4(x)
+}
+\arguments{
+ \item{time}{
+ for right censored data, this is the follow up time. For interval
+ data, the first argument is the starting time for the interval.
+ }
+ \item{x}{
+ any R object.
+ }
+ \item{event}{
+ The status indicator, normally 0=alive, 1=dead. Other choices are
+ \code{TRUE}/\code{FALSE} (\code{TRUE} = death) or 1/2 (2=death). For
+ interval censored data, the status indicator is 0=right censored,
+ 1=event at \code{time}, 2=left censored, 3=interval censored.
+ Although unusual, the event indicator can be omitted, in which case
+ all subjects are assumed to have an event.
+ }
+ \item{time2}{
+ ending time of the interval for interval censored or counting
+ process data only. Intervals are assumed to be open on the left and
+ closed on the right, \code{(start, end]}. For counting process
+ data, \code{event} indicates whether an event occurred at the end of
+ the interval.
+ }
+ \item{type}{
+ character string specifying the type of censoring. Possible values
+ are \code{"right"}, \code{"left"}, \code{"counting"},
+ \code{"interval"}, or \code{"interval2"}. The default is
+ \code{"right"} or \code{"counting"} depending on whether the
+ \code{time2} argument is absent or present, respectively.
+ }
+ \item{origin}{
+ for counting process data, the hazard function origin. This is most
+ often used in conjunction with a model containing time dependent
+ strata in order to align the subjects properly when they cross over
+ from one strata to another.}
+}
+\value{
+ An object of class \code{Surv}. There are methods for \code{print},
+ \code{is.na}, and subscripting survival objects. \code{Surv} objects
+ are implemented as a matrix of 2 or 3 columns.
+
+ In the case of \code{is.SurvS4}, a logical value \code{TRUE} if \code{x}
+ inherits from class \code{"SurvS4"}, otherwise an \code{FALSE}.
+}
+\details{
+ Typical usages are
+\preformatted{
+Surv(time, event)
+Surv(time, time2, event, type=, origin=0)
+}
+
+In theory it is possible to represent interval censored data without a
+third column containing the explicit status. Exact, right censored,
+left censored and interval censored observation would be represented as
+intervals of (a,a), (a, infinity), (-infinity,b), and (a,b) respectively;
+each specifying the interval within which the event is known to have occurred.
+
+
+If \code{type = "interval2"} then the representation given above is
+assumed, with NA taking the place of infinity. If `type="interval"
+\code{event} must be given.
+If \code{event} is \code{0}, \code{1}, or \code{2}, the relevant
+information is assumed to be contained in \code{time},
+the value in \code{time2}
+is ignored, and the second column of the result will contain a
+placeholder.
+
+
+Presently, the only methods allowing interval censored data are the
+parametric models computed by \code{\link[survival]{survreg}},
+so the distinction between open and closed intervals
+is unimportant.
+The distinction is important for counting process data and
+the Cox model.
+
+
+The function tries to distinguish between the use of 0/1 and 1/2 coding for
+left and right censored data using \code{if (max(status)==2)}.
+If 1/2 coding is used and all the subjects are censored, it will
+guess wrong. Use 0/1 coding in this case.
+}
+
+
+
+\author{
+ The code and documentation comes from \pkg{survival}.
+ Slight modifications have been made for conversion to S4
+ by Thomas W. Yee.
+}
+\note{
+ The purpose of having \code{Surv} in \pkg{VGAM} is so that the
+ same input can be fed into \code{\link{vglm}} as functions
+ in \pkg{survival} such as \code{\link[survival]{survreg}}.
+ The class name has been changed from
+ \code{"Surv"} to \code{"SurvS4"}.
+
+}
+
+
+
+
+\seealso{
+ \code{\link{SurvS4-class}},
+ \code{\link[survival]{coxph}},
+ \code{\link[survival]{survfit}},
+ \code{\link[survival]{survreg}},
+ \code{\link{aml}}.
+}
+\examples{
+with(aml, Surv(time, status))
+}
+\keyword{survival}
+% Converted by Sd2Rd version 0.3-2.
+% with(heart, Surv(start,stop,event))
diff --git a/man/SurvS4-class.Rd b/man/SurvS4-class.Rd
new file mode 100644
index 0000000..6120f20
--- /dev/null
+++ b/man/SurvS4-class.Rd
@@ -0,0 +1,50 @@
+\name{SurvS4-class}
+\docType{class}
+\alias{SurvS4-class}
+\alias{print,SurvS4-method}
+\alias{show,SurvS4-method}
+
+\title{Class "SurvS4" }
+\description{ S4 version of the Surv class. }
+\section{Objects from the Class}{A virtual Class: No objects may be created from it.}
+\section{Extends}{
+%Class \code{"\linkS4class{Surv}"}, directly.
+Class \code{"Surv"}, directly.
+Class \code{"\linkS4class{matrix}"}, directly.
+Class \code{"\linkS4class{oldClass}"}, by class "Surv", distance 2.
+Class \code{"\linkS4class{structure}"}, by class "matrix", distance 2.
+Class \code{"\linkS4class{array}"}, by class "matrix", distance 2.
+Class \code{"\linkS4class{vector}"}, by class "matrix", distance 3, with explicit coerce.
+Class \code{"\linkS4class{vector}"}, by class "matrix", distance 4, with explicit coerce.
+}
+\section{Methods}{
+ \describe{
+ \item{print}{\code{signature(x = "SurvS4")}: ... }
+ \item{show}{\code{signature(object = "SurvS4")}: ... }
+ }
+}
+\references{
+ See \pkg{survival}.
+}
+\author{
+ Thomas W. Yee.
+}
+\note{
+ The purpose of having \code{\link{Surv}} in \pkg{VGAM} is so that the
+ same input can be fed into \code{\link{vglm}} as functions
+ in \pkg{survival} such as \code{\link[survival]{survreg}}.
+}
+
+\section{Warning }{
+ This code has not been thoroughly tested.
+
+}
+
+\seealso{
+ \code{\link{Surv}}.
+% or \code{\linkS4class{CLASSNAME}} for links to other classes
+}
+\examples{
+showClass("SurvS4")
+}
+\keyword{classes}
diff --git a/man/VGAM-package.Rd b/man/VGAM-package.Rd
new file mode 100644
index 0000000..e8c7ff3
--- /dev/null
+++ b/man/VGAM-package.Rd
@@ -0,0 +1,194 @@
+\name{VGAM-package}
+\alias{VGAM-package}
+\alias{VGAM}
+\docType{package}
+\title{
+Vector Generalized Linear and Additive Models
+}
+\description{
+\pkg{VGAM} provides functions for fitting
+vector generalized linear and additive models (VGLMs and VGAMs),
+and associated models
+(Reduced-Rank VGLMs, Quadratic RR-VGLMs, Reduced-Rank VGAMs).
+This package fits many models and distributions by maximum likelihood
+estimation (MLE) or penalized MLE.
+Also fits constrained ordination models in ecology such as constrained
+quadratic ordination (CQO).
+
+}
+\details{
+
+This package centers on the iteratively reweighted least squares (IRLS)
+algorithm.
+Other key words include Fisher scoring, additive models, penalized
+likelihood, reduced-rank regression and constrained ordination.
+The central modelling functions are
+\code{\link{vglm}},
+\code{\link{vgam}},
+\code{\link{rrvglm}},
+\code{\link{cqo}},
+\code{\link{cao}}.
+For detailed control of fitting,
+each of these has its own control function, e.g.,
+\code{\link{vglm.control}}.
+The package uses S4 (see \code{\link[methods]{methods-package}}).
+
+The classes of GLMs and GAMs are special cases of VGLMs and VGAMs.
+The VGLM/VGAM framework is intended to be very general
+so that it encompasses as many distributions and models as
+possible. VGLMs are limited only by the assumption that the
+regression coefficients enter through a set of linear predictors.
+The VGLM class is very large and encompasses a wide range of
+multivariate response types and models, e.g., it includes
+univariate and multivariate distributions, categorical data analysis,
+time series, survival analysis, generalized estimating equations,
+extreme values,
+correlated binary data, bioassay data and nonlinear least-squares
+problems.
+
+VGAMs are to VGLMs what GAMs are to GLMs.
+Vector smoothing (see \code{\link{vsmooth.spline}}) allows several
+additive predictors to be estimated as a sum of smooth functions of
+the covariates.
+
+For a complete list of this package, use \code{library(help="VGAM")}.
+New \pkg{VGAM} family functions are continually being written and
+added to the package.
+A monograph about VGLM and VGAMs etc. is in the making but unfortunately
+won't be finished for a while.
+
+
+%~~ 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 Stephenson, A. G. (2007)
+Vector generalized linear and additive extreme value models.
+\emph{Extremes}, \bold{10}, 1--19.
+
+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.
+
+Documentation accompanying the \pkg{VGAM} package at
+\url{http://www.stat.auckland.ac.nz/~yee/VGAM}
+contains further information and examples.
+
+}
+
+\keyword{ package }
+\keyword{models}
+\keyword{regression}
+%\seealso{
+%~~ Optional links to other man pages, e.g. ~~
+%~~ \code{\link[<pkg>:<pkg>-package]{<pkg>}} ~~
+%}
+\examples{
+# Example 1
+# Fit the proportional odds model, p.179, in McCullagh and Nelder (1989)
+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
+
+
+# Example 2
+# Zero-inflated Poisson model
+x = runif(n <- 2000)
+phi = logit(-0.5 + 1*x, inverse=TRUE)
+lambda = loge(0.5 + 2*x, inverse=TRUE)
+y = rzipois(n, lambda, phi)
+table(y)
+fit = vglm(y ~ x, zipoisson, trace=TRUE)
+coef(fit, matrix=TRUE) # These should agree with the above values
+
+
+# Example 3
+# Fit a two species GAM simultaneously
+data(hunua)
+fit2 = vgam(cbind(agaaus, kniexc) ~ s(altitude, df=c(2,3)),
+ binomialff(mv=TRUE), hunua)
+coef(fit2, mat=TRUE) # Not really interpretable
+\dontrun{
+plot(fit2, se=TRUE, overlay=TRUE, lcol=1:2, scol=1:2)
+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)
+}
+
+
+# Example 4
+# 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(mfrow=c(1,1), bty="l", mar=c(5,4,4,3)+0.1, xpd=TRUE)
+qtplot(fit, percentiles=c(5,50,90,99), main="Quantiles",
+ xlim=c(15,90), las=1, ylab="BMI", lwd=2, lcol=4)
+
+# 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
+}
+
+
+# Example 5
+# 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 d0ac30c..e256289 100644
--- a/man/acat.Rd
+++ b/man/acat.Rd
@@ -94,7 +94,8 @@ contains further information and examples.
}
\section{Warning }{
- No check is made to verify that the response is ordinal.
+ No check is made to verify that the response is ordinal;
+ see \code{\link[base:factor]{ordered}}.
}
\seealso{
diff --git a/man/alsqreg.Rd b/man/alsqreg.Rd
new file mode 100644
index 0000000..1a68b48
--- /dev/null
+++ b/man/alsqreg.Rd
@@ -0,0 +1,125 @@
+\name{alsqreg}
+\alias{alsqreg}
+%- Also NEED an '\alias' for EACH other topic documented here.
+\title{ Asymmetric Least Squares Quantile Regression }
+\description{
+ Quantile regression using asymmetric least squares error loss.
+
+}
+\usage{
+alsqreg(w=1, method.init=1)
+}
+%- maybe also 'usage' for other objects documented here.
+\arguments{
+ \item{w}{
+ Positive constant controlling the percentile.
+ The larger the value the larger the fitted percentile value
+ (the proportion of points below the ``w-regression plane'').
+ The default value of unity results in the ordinary least squares
+ (OLS) solution.
+
+ }
+ \item{method.init}{
+ Integer, either 1 or 2 or 3. Initialization method.
+ Choose another value if convergence fails.
+
+ }
+}
+\details{
+ This method was proposed by Efron (1991) and full details can
+ be obtained there.
+ Equation numbers below refer to that article.
+ The model is essentially a linear model
+ (see \code{\link[stats]{lm}}), however,
+ the asymmetric squared error loss function for a residual
+ \eqn{r} is \eqn{r^2} if \eqn{r \leq 0}{r <= 0} and
+ \eqn{w r^2}{w*r^2} if \eqn{r > 0}.
+ The solution is the set of regression coefficients that
+ minimize the sum of these over the data set, weighted by the
+ \code{weights} argument (so that it can contain frequencies).
+ Newton-Raphson estimation is used here.
+
+}
+\value{
+ An object of class \code{"vglmff"} (see \code{\link{vglmff-class}}).
+ The object is used by modelling functions such as \code{\link{vglm}},
+ and \code{\link{vgam}}.
+}
+\references{
+ Efron, B. (1991)
+ Regression percentiles using asymmetric squared error loss.
+ \emph{Statistica Sinica},
+ \bold{1}, 93--125.
+
+}
+
+\author{ Thomas W. Yee }
+\note{
+ On fitting, the \code{extra} slot has list components \code{"w"} and
+ \code{"percentile"}. The latter is the percent of observations below
+ the ``w-regression plane'', which is the fitted values.
+
+ One difficulty is finding the \code{w} value giving a specified
+ percentile. One solution is to fit the model within a root finding
+ function such as \code{\link[stats]{uniroot}}; see the example below.
+
+ For \code{alsqreg} objects, methods functions for the generic functions
+ \code{qtplot} and \code{cdf} have not been written yet.
+
+}
+
+\section{Warning }{
+ The \code{loglikelihood} slot currently does not return the
+ log-likelihood but negative the total asymmetric
+ squared error loss (2.5).
+
+}
+\seealso{
+ \code{\link{bminz}},
+ \code{\link{lms.bcn}} and similar variants are alternative
+ methods for quantile regression.
+
+}
+
+\examples{
+# Example 1
+data(bminz)
+o = with(bminz, order(age))
+bminz = bminz[o,] # Sort by age
+fit = vglm(BMI ~ bs(age), fam=alsqreg(w=0.07), data=bminz)
+fit # Note "loglikelihood" is -total asymmetric squared error loss (2.5)
+fit at extra # Gives the w value and the percentile
+coef(fit)
+coef(fit, matrix=TRUE)
+
+\dontrun{
+# Quantile plot
+with(bminz, plot(age, BMI, col="blue", main=
+ paste(round(fit at extra$percentile, dig=1), "percentile curve")))
+with(bminz, lines(age, c(fitted(fit)), col="red"))
+}
+
+
+
+# Example 2
+# Find the w values that give the 25, 50 and 75 percentiles
+findw = function(w, percentile=50) {
+ fit = vglm(BMI ~ bs(age), fam=alsqreg(w=w), data=bminz)
+ fit at extra$percentile - percentile
+}
+\dontrun{
+# Quantile plot
+with(bminz, plot(age, BMI, col="blue", las=1, main=
+ "25, 50 and 75 percentile curves"))
+}
+for(myp in c(25,50,75)) {
+ bestw = uniroot(f=findw, interval=c(1/10^4, 10^4), percentile=myp)
+ fit = vglm(BMI ~ bs(age), fam=alsqreg(w=bestw$root), data=bminz)
+\dontrun{
+ with(bminz, lines(age, c(fitted(fit)), col="red"))
+}
+}
+}
+\keyword{models}
+\keyword{regression}
+
diff --git a/man/aml.Rd b/man/aml.Rd
new file mode 100644
index 0000000..057b1e2
--- /dev/null
+++ b/man/aml.Rd
@@ -0,0 +1,27 @@
+\name{aml}
+\docType{data}
+\alias{aml}
+\alias{leukemia}
+\title{Acute Myelogenous Leukemia Survival Data}
+\description{Survival in patients with Acute Myelogenous Leukemia}
+\usage{
+aml
+leukemia
+}
+\format{
+ \tabular{ll}{
+ time:\tab survival or censoring time\cr
+ status:\tab censoring status\cr
+ x: \tab maintenance chemotherapy given? (factor)\cr
+ }
+}
+\source{
+ Rupert G. Miller (1997),
+ \emph{Survival Analysis}.
+ John Wiley & Sons.
+ ISBN: 0-471-25218-2.
+}
+\note{
+ This data set has been transferred from \pkg{survival}.
+}
+\keyword{datasets}
diff --git a/man/betabinomial.Rd b/man/betabinomial.Rd
index 99fb56d..b06fd92 100644
--- a/man/betabinomial.Rd
+++ b/man/betabinomial.Rd
@@ -9,7 +9,7 @@
}
\usage{
betabinomial(lmu="logit", lrho="logit", emu=list(), erho=list(),
- irho=0.5, zero=2)
+ irho=NULL, method.init=1, zero=2)
}
%- maybe also 'usage' for other objects documented here.
\arguments{
@@ -27,11 +27,18 @@ betabinomial(lmu="logit", lrho="logit", emu=list(), erho=list(),
\item{irho}{
Optional initial value for the correlation parameter.
If given, it must be in \eqn{(0,1)}, and is recyled to the necessary
- length. Assign this argument a value if a convergence failure occurs.
- Setting \code{irho=NULL} means an initial value is obtained internally,
+ length. Assign this argument a value if a convergence failure occurs.
+ Having \code{irho=NULL} means an initial value is obtained internally,
though this can give unsatisfactory results.
}
+ \item{method.init}{
+ An integer with value \code{1} or \code{2} which
+ specifies the initialization method for \eqn{\mu}{mu}.
+ If failure to converge occurs try the other value
+ and/or else specify a value for \code{irho}.
+
+ }
\item{zero}{
An integer specifying which
linear/additive predictor is to be modelled as an intercept only.
@@ -137,8 +144,8 @@ betabinomial(lmu="logit", lrho="logit", emu=list(), erho=list(),
This family function is prone to numerical difficulties
due to the expected information matrices not being positive-definite
or ill-conditioned over some regions of the parameter space.
- If problems occur try setting \code{irho} to some other
- value, or else use the \code{etastart} argument of
+ If problems occur try setting \code{irho} to some numerical
+ value, or else use \code{etastart} argument of
\code{\link{vglm}}, etc.
}
diff --git a/man/binomialff.Rd b/man/binomialff.Rd
index a280344..e455828 100644
--- a/man/binomialff.Rd
+++ b/man/binomialff.Rd
@@ -134,6 +134,8 @@ binomialff(link = "logit", earg = list(),
\code{\link{cqo}},
\code{\link{cao}},
\code{\link{zibinomial}},
+ \code{\link{dexpbinomial}},
+ \code{\link{seq2binomial}},
\code{\link[stats:Binomial]{binomial}}.
}
\section{Warning }{
diff --git a/man/bisa.Rd b/man/bisa.Rd
index 5f7e0ae..264db75 100644
--- a/man/bisa.Rd
+++ b/man/bisa.Rd
@@ -10,8 +10,7 @@
\usage{
bisa(lshape = "loge", lscale = "loge",
eshape = list(), escale = list(),
- ishape = NULL, iscale = 1, method.init = 1,
- fsmax=9001, zero = NULL)
+ ishape = NULL, iscale = 1, method.init = 1, zero = NULL)
}
%- maybe also 'usage' for other objects documented here.
\arguments{
@@ -27,27 +26,20 @@ bisa(lshape = "loge", lscale = "loge",
See \code{earg} in \code{\link{Links}} for general information.
}
- \item{iscale, ishape}{
+ \item{iscale, ishape}{
Initial values for \eqn{a} and \eqn{b}.
A \code{NULL} means an initial value is chosen internally using
\code{method.init}.
}
\item{method.init}{
- An integer with value \code{1} or \code{2} which
+ An integer with value \code{1} or \code{2} or \code{3} which
specifies the initialization method. If failure to converge occurs
try the other value, or else specify a value for
\code{ishape} and/or \code{iscale}.
}
- \item{fsmax}{
- Integer. If the formula is an intercept-only or if the number of
- observations \eqn{n} is less than \code{fsmax} then Fisher scoring is
- used (recommended), else a BFGS quasi-Newton update formula for the
- working weight matrices is used.
-
- }
- \item{zero}{
+ \item{zero}{
An integer-valued vector specifying which
linear/additive predictors are modelled as intercepts only.
The default is none of them.
@@ -74,6 +66,11 @@ bisa(lshape = "loge", lscale = "loge",
By default, \eqn{\eta_1=\log(a)}{eta1=log(a)} and
\eqn{\eta_2=\log(b)}{eta2=log(b)} for this family function.
+ Note that \eqn{a} and \eqn{b} are orthogonal,
+ i.e., the Fisher information matrix is diagonal.
+ This family function implements Fisher scoring, and
+ it is unnecessary to compute any integrals numerically.
+
}
\value{
An object of class \code{"vglmff"} (see \code{\link{vglmff-class}}).
@@ -81,17 +78,22 @@ bisa(lshape = "loge", lscale = "loge",
and \code{\link{vgam}}.
}
-\references{
+\references{
-Birnbaum, Z. W. and Saunders, S. C. (1969).
+Lemonte, A. J. and Cribari-Neto, F. and Vasconcellos, K. L. P. (2007)
+Improved statistical inference for the two-parameter
+Birnbaum-Saunders distribution.
+\emph{Computational Statistics \& Data Analysis}, \bold{51}, 4656--4681.
+
+Birnbaum, Z. W. and Saunders, S. C. (1969)
A new family of life distributions.
\emph{Journal of Applied Probability}, \bold{6}, 319--327.
-Birnbaum, Z. W. and Saunders, S. C. (1969).
+Birnbaum, Z. W. and Saunders, S. C. (1969)
Estimation for a family of life distributions with applications to fatigue.
\emph{Journal of Applied Probability}, \bold{6}, 328--347.
-Engelhardt, M. and Bain, L. J. and Wright, F. T. (1981).
+Engelhardt, M. and Bain, L. J. and Wright, F. T. (1981)
Inferences on the parameters of the Birnbaum-Saunders fatigue
life distribution based on maximum likelihood estimation.
\emph{Technometrics}, \bold{23}, 251--256.
@@ -102,25 +104,11 @@ Johnson, N. L. and Kotz, S. and Balakrishnan, N. (1995)
Volume 2,
New York: Wiley.
-
}
\author{ T. W. Yee }
-\note{
- If the formula is an intercept-only or \eqn{n} is sufficiently small,
- then this family function implements Fisher scoring. This involves
- computing an integral numerically.
- Fisher scoring is generally recommended here provided the integrals
- can be computed successfully and it does not take too long.
-
- For \eqn{n} large and non-intercept-only formulas the BFGS quasi-Newton
- update formula for the working weight matrices is used by default.
- This is more numerically fraught.
- Additionally, the estimated variance-covariance matrix may be inaccurate
- or simply wrong! The standard errors must be therefore treated with
- caution; these are computed in functions such as \code{vcov()} and
- \code{summary()}.
-
-}
+%\note{
+%
+%}
%\section{Warning }{
%}
@@ -130,15 +118,20 @@ New York: Wiley.
}
\examples{
+x = runif(n <- 1000)
+y = rbisa(n, shape=exp(-0.5+x), scale=exp(1.5))
+fit = vglm(y ~ x, bisa(zero=2), trace=TRUE)
+coef(fit, matrix=TRUE)
+
+\dontrun{
y = rbisa(n=1000, shape=exp(-0.5), scale=exp(0.5))
fit = vglm(y ~ 1, bisa, trace=TRUE)
+hist(y, prob=TRUE, ylim=c(0,0.5), col="lightblue")
coef(fit, matrix=TRUE)
mean(y)
fitted(fit)[1:4]
-
-\dontrun{hist(y, prob=TRUE)
x = seq(0, max(y), len=200)
-lines(x, dbisa(x, Coef(fit)[1], Coef(fit)[2]), col="red")
+lines(x, dbisa(x, Coef(fit)[1], Coef(fit)[2]), col="red", lwd=2)
}
}
\keyword{models}
diff --git a/man/cao.Rd b/man/cao.Rd
index 8503e83..393080d 100644
--- a/man/cao.Rd
+++ b/man/cao.Rd
@@ -37,7 +37,7 @@ cao(formula, family, data = list(),
\item{family}{
a function of class \code{"vglmff"} describing what statistical
model is to be fitted.
- See \code{\link{cqo}} for a list of those presently implemented,
+ See \code{\link{cqo}} for a list of those presently implemented.
}
@@ -251,6 +251,10 @@ Constrained additive ordination.
% The code is a little fragile at this stage, so the function might
% hang/lock up in the microsoft Windows version.
+ Currently the dispersion parameter for a
+ \code{\link{gaussianff}} CAO model is estimated slightly differently
+ and may be slightly biassed downwards (usually a little too small).
+
}
\seealso{
diff --git a/man/cexpon.Rd b/man/cexpon.Rd
deleted file mode 100644
index 8b51555..0000000
--- a/man/cexpon.Rd
+++ /dev/null
@@ -1,88 +0,0 @@
-\name{cexpon}
-\alias{cexpon}
-%- Also NEED an '\alias' for EACH other topic documented here.
-\title{ Censored Exponential Distribution }
-\description{
- Maximum likelihood estimation for the exponential distribution with
- left and right censoring.
-}
-\usage{
-cexpon(link = "loge", location = 0)
-}
-%- maybe also 'usage' for other objects documented here.
-\arguments{
- \item{link}{
- Character.
- Parameter link function applied to the positive parameter \eqn{rate}.
- See \code{\link{Links}} for more choices.
-
- }
- \item{location}{
- Numeric of length 1, the known location parameter, \eqn{A}, say.
-
- }
-}
-\details{
- The family function assumes the response \eqn{Y} has density
- \deqn{f(y) = \lambda \exp(-\lambda (y-A))}{%
- f(y) = rate * exp(-rate * (y-A)) }
- for \eqn{y > A}, where \eqn{A} is the known location parameter.
- By default, \eqn{A=0}.
- Then \eqn{E(Y) = A + 1/ \lambda}{E(Y) = A + 1/rate}
- (returned as the fitted values) and
- \eqn{Var(Y) = 1/ \lambda^2}{Var(Y) = 1/rate^2}.
-
- The data may be left-censored so that the true value would be less than
- the observed value; else right-censored so that the true value would be
- greater than the observed value. To indicate which type of censoring,
- input \code{extra = list(leftcensored = vec1, rightcensored = vec2)}
- where \code{vec1} and \code{vec2} are logical vectors the same length
- as the response.
- If the two components of this list are missing then
- all the logical values are taken to be \code{FALSE}.
- The fitted object has these two components stored in the \code{extra}
- slot.
-
-}
-\value{
- An object of class \code{"vglmff"} (see \code{\link{vglmff-class}}).
- The object is used by modelling functions such as \code{\link{vglm}},
- and \code{\link{vgam}}.
-}
-\references{
-Evans, M., Hastings, N. and Peacock, B. (2000)
-\emph{Statistical Distributions},
-New York: Wiley-Interscience, Third edition.
-}
-
-\author{ T. W. Yee }
-\note{
- This function was adapted from \code{\link{exponential}} which should
- be used when there are no censored observations.
-
- The fitted object has a component called \code{"location"} stored in the
- \code{extra} slot which contains the value of the location parameter.
-
-}
-\seealso{
- \code{\link{exponential}}.
-}
-
-\examples{
-n = 100
-lambda = exp(-0.1)
-ystar = rexp(n, rate=lambda)
-L = 2 # Lower censoring point
-U = 3 # Upper censoring point
-y = pmax(L, ystar) # left censoring
-y = pmin(U, y) # right censoring
-\dontrun{hist(y)}
-extra = list(leftcensored = ystar < L, rightcensored = ystar > U)
-fit = vglm(y ~ 1, cexpon, trace=TRUE, extra=extra)
-coef(fit, matrix=TRUE)
-Coef(fit)
-fit at extra
-}
-\keyword{models}
-\keyword{regression}
-
diff --git a/man/cratio.Rd b/man/cratio.Rd
index d51f533..7ea2549 100644
--- a/man/cratio.Rd
+++ b/man/cratio.Rd
@@ -101,7 +101,8 @@ contains further information and examples.
}
\section{Warning }{
- No check is made to verify that the response is ordinal.
+ No check is made to verify that the response is ordinal;
+ see \code{\link[base:factor]{ordered}}.
}
\seealso{
diff --git a/man/cumulative.Rd b/man/cumulative.Rd
index 4e11c9c..ba3b1f3 100644
--- a/man/cumulative.Rd
+++ b/man/cumulative.Rd
@@ -163,7 +163,8 @@ contains further information and examples.
}
\section{Warning }{
- No check is made to verify that the response is ordinal.
+ No check is made to verify that the response is ordinal;
+ see \code{\link[base:factor]{ordered}}.
}
@@ -199,6 +200,12 @@ fit2 = vgam(cbind(normal, mild, severe) ~ s(let, df=2),
\dontrun{
plot(fit2, se=TRUE, overlay=TRUE, lcol=1:2, scol=1:2)
}
+
+# Check the proportional odds assumption with a likelihood ratio test
+(fit3 = vglm(cbind(normal, mild, severe) ~ let,
+ cumulative(parallel=FALSE, reverse=TRUE), pneumo))
+1 - pchisq(2*(logLik(fit3)-logLik(fit)),
+ df=length(coef(fit3))-length(coef(fit)))
}
\keyword{models}
\keyword{regression}
diff --git a/man/dexpbinomial.Rd b/man/dexpbinomial.Rd
new file mode 100644
index 0000000..05c106a
--- /dev/null
+++ b/man/dexpbinomial.Rd
@@ -0,0 +1,187 @@
+\name{dexpbinomial}
+\alias{dexpbinomial}
+%- Also NEED an '\alias' for EACH other topic documented here.
+\title{ Double Exponential Binomial Distribution Family Function }
+\description{
+ Fits a double exponential binomial distribution by
+ maximum likelihood estimation.
+ The two parameters here are the mean and dispersion parameter.
+
+}
+\usage{
+dexpbinomial(lmean="logit", ldispersion="logit",
+ emean=list(), edispersion=list(),
+ idispersion=0.25, zero=2)
+}
+%- maybe also 'usage' for other objects documented here.
+\arguments{
+ \item{lmean, ldispersion}{
+ Link functions applied to the two parameters, called
+ \eqn{\mu}{mu} and \eqn{\theta}{theta} respectively below.
+ See \code{\link{Links}} for more choices.
+ The defaults cause the parameters to be restricted to \eqn{(0,1)}.
+
+ }
+ \item{emean, edispersion}{
+ List. Extra argument for each of the links.
+ See \code{earg} in \code{\link{Links}} for general information.
+
+ }
+ \item{idispersion}{
+ Initial value for the dispersion parameter.
+ If given, it must be in range, and is recyled to the necessary length.
+ Use this argument if convergence failure occurs.
+
+ }
+ \item{zero}{
+ An integer specifying which
+ linear/additive predictor is to be modelled as an intercept only.
+ If assigned, the single value should be either \code{1} or \code{2}.
+ The default is to have a single dispersion parameter value.
+ To model both parameters as functions of the covariates assign
+ \code{zero=NULL}.
+
+ }
+}
+\details{
+ This distribution provides a way for handling overdispersion in
+ a binary response.
+ The double exponential binomial distribution belongs the family of
+ double exponential distributions proposed by Efron (1986).
+ Below, equation numbers refer to that original article.
+ Briefly, the idea is that an ordinary one-parameter exponential family
+ allows the addition of a second parameter \eqn{\theta}{theta}
+ which varies the dispersion
+ of the family without changing the mean.
+ The extended family behaves like the original family with
+ sample size changed from \eqn{n} to \eqn{n\theta}{n*theta}.
+ The extended family is an exponential family in \eqn{\mu}{mu} when
+ \eqn{n} and \eqn{\theta}{theta} are fixed, and
+ an exponential family in \eqn{\theta}{theta} when
+ \eqn{n} and \eqn{\mu}{mu} are fixed.
+ Having \eqn{0 < \theta < 1}{0 < theta < 1} corresponds to overdispersion
+ with respect to the binomial distribution.
+ See Efron (1986) for full details.
+
+ This \pkg{VGAM} family function implements an \emph{approximation}
+ (2.10) to the exact density (2.4). It replaces the normalizing
+ constant by unity since the true value nearly equals 1.
+ The default model fitted is \eqn{\eta_1 = logit(\mu)}{eta1 =logit(mu)}
+ and \eqn{\eta_2 = logit(\theta)}{eta2 = logit(theta)}.
+ This restricts both parameters to lie between 0 and 1, although
+ the dispersion parameter can be modelled over a larger parameter space by
+ assigning the arguments \code{ldispersion} and \code{edispersion}.
+
+ Approximately, the mean (of \eqn{Y}) is \eqn{\mu}{mu}.
+ The \emph{effective sample size} is the dispersion parameter multiplied
+ by the original sample size,
+ i.e., \eqn{n\theta}{n*theta}.
+ This family function uses Fisher scoring, and the two estimates are
+ asymptotically independent because the expected information matrix
+ is diagonal.
+
+}
+\value{
+ An object of class \code{"vglmff"} (see \code{\link{vglmff-class}}).
+ The object is used by modelling functions such as \code{\link{vglm}}.
+
+}
+\references{
+
+ Efron, B. (1986)
+ Double exponential families and their use in generalized linear regression.
+ \emph{Journal of the American Statistical Association},
+ \bold{81}, 709--721.
+
+}
+
+\author{ T. W. Yee }
+\note{
+ This function processes the input in the same way
+ as \code{\link{binomialff}}, however multivariate responses are
+ not allowed (\code{binomialff(mv=FALSE)}).
+
+}
+\section{Warning }{
+ Numerical difficulties can occur; if so, try using \code{idispersion}.
+
+}
+\seealso{
+ \code{\link{binomialff}},
+ \code{\link{toxop}}.
+
+}
+\examples{
+# This example mimics the example in Efron (1986). The results here
+# differ slightly.
+data(toxop)
+
+# Scale the variables
+toxop = transform(toxop,
+ phat = positive / ssize,
+ srainfall = scale(rainfall), # (6.1)
+ sN = scale(ssize)) # (6.2)
+
+# A fit similar (should be identical) to Section 6 of Efron (1986).
+# But does not use poly(), and M=1.25 here, as in (5.3)
+cmlist = list("(Intercept)"=diag(2),
+ "I(srainfall)"=rbind(1,0),
+ "I(srainfall^2)"=rbind(1,0),
+ "I(srainfall^3)"=rbind(1,0),
+ "I(sN)"=rbind(0,1),
+ "I(sN^2)"=rbind(0,1))
+elist = list(min=0, max=1.25)
+fit = vglm(phat ~ I(srainfall) + I(srainfall^2) + I(srainfall^3) +
+ I(sN) + I(sN^2),
+ fam = dexpbinomial(ldisp="elogit", idisp=0.2,
+ edisp=elist, zero=NULL),
+ data=toxop, weight=ssize, trace=TRUE, constraints=cmlist)
+
+# Now look at the results
+coef(fit)
+coef(fit, matrix=TRUE)
+fitted(fit)[1:4,]
+summary(fit)
+vcov(fit)
+sqrt(diag(vcov(fit))) # Standard errors
+
+# Effective sample size (not quite the last column of Table 1)
+predict(fit)[1:4,]
+Dispersion = elogit(predict(fit)[,2], earg=elist, inverse=TRUE)
+c(round(weights(fit, type="prior") * Dispersion, dig=1))
+
+
+# Ordinary logistic regression (gives same results as (6.5))
+ofit = vglm(phat ~ I(srainfall) + I(srainfall^2) + I(srainfall^3),
+ fam = binomialff, data=toxop, weight=ssize, trace=TRUE)
+
+
+# Same as fit but it uses poly(), and can be plotted (cf. Figure 1)
+cmlist2 = list("(Intercept)"=diag(2),
+ "poly(srainfall, 3)"=rbind(1,0),
+ "poly(sN, 2)"=rbind(0,1))
+fit2 = vglm(phat ~ poly(srainfall, 3) + poly(sN, 2),
+ fam = dexpbinomial(ldisp="elogit", idisp=0.2,
+ edisp=list(min=0, max=1.25), zero=NULL),
+ data=toxop, weight=ssize, trace=TRUE, constraints=cmlist2)
+\dontrun{
+par(mfrow=c(1,2))
+plotvgam(fit2, se=TRUE, lcol="blue", scol="red") # Cf. Figure 1
+
+
+# Cf. Figure 1(a)
+par(mfrow=c(1,2))
+o = with(toxop, sort.list(rainfall))
+with(toxop, plot(rainfall[o], fitted(fit2)[o], type="l", col="blue",
+ las=1, ylim=c(0.3, 0.65)))
+with(toxop, points(rainfall[o], fitted(ofit)[o], col="red", type="b",
+ pch=19))
+
+# Cf. Figure 1(b)
+o = with(toxop, sort.list(ssize))
+with(toxop, plot(ssize[o], Dispersion[o], type="l", col="blue", las=1,
+ xlim=c(0, 100)))
+}
+}
+\keyword{models}
+\keyword{regression}
diff --git a/man/enzyme.Rd b/man/enzyme.Rd
index f782a23..d4bb099 100644
--- a/man/enzyme.Rd
+++ b/man/enzyme.Rd
@@ -1,7 +1,7 @@
\name{enzyme}
\alias{enzyme}
\docType{data}
-\title{ Enzyme data}
+\title{ Enzyme Data}
\description{
Enzyme velocity and substrate concentration.
}
diff --git a/man/expexp1.Rd b/man/expexp1.Rd
index eff089c..4ceb407 100644
--- a/man/expexp1.Rd
+++ b/man/expexp1.Rd
@@ -59,7 +59,6 @@ expexp1(lscale = "loge", escale=list(), iscale = NULL, ishape = 1)
}
-}
\author{ T. W. Yee }
\note{
This family function works only for intercept-only models,
diff --git a/man/exponential.Rd b/man/exponential.Rd
index 6186851..c202d9e 100644
--- a/man/exponential.Rd
+++ b/man/exponential.Rd
@@ -66,7 +66,7 @@ New York: Wiley-Interscience, Third edition.
}
\seealso{
- \code{\link{cexpon}},
+% \code{\link{cexpon}},
\code{\link{poissonff}},
\code{\link{freund61}}.
}
diff --git a/man/fitted.vlm.Rd b/man/fitted.vlm.Rd
index b6fae78..2f71a05 100644
--- a/man/fitted.vlm.Rd
+++ b/man/fitted.vlm.Rd
@@ -66,13 +66,7 @@ fit
fitted(fit)
-# Nonparametric logistic regression example 2
-data(hunua)
-fit = vgam(agaaus ~ s(altitude), binomialff, hunua)
-fitted(fit, matrix=FALSE)[1:3]
-
-
-# LMS quantile regression example 3
+# LMS quantile regression example 2
data(bminz)
fit = vgam(BMI ~ s(age, df=c(4,2)),
fam=lms.bcn(zero=1), data=bminz, trace=TRUE)
diff --git a/man/gev.Rd b/man/gev.Rd
index 8be85e9..cca2060 100644
--- a/man/gev.Rd
+++ b/man/gev.Rd
@@ -27,8 +27,8 @@ egev(llocation = "identity", lscale = "loge", lshape = "logoff",
%- maybe also 'usage' for other objects documented here.
\arguments{
\item{llocation, lscale, lshape}{
- Parameter link function for \eqn{\mu}{mu}, \eqn{\sigma}{sigma} and
- \eqn{\xi}{xi}.
+ Parameter link functions for \eqn{\mu}{mu}, \eqn{\sigma}{sigma} and
+ \eqn{\xi}{xi} respectively.
See \code{\link{Links}} for more choices.
}
@@ -172,11 +172,11 @@ egev(llocation = "identity", lscale = "loge", lshape = "logoff",
fraught. If \eqn{1 + \xi (y-\mu)/ \sigma \leq 0}{1 + xi*(y-mu)/sigma <=
0} then some crude evasive action is taken but the estimation process
can still fail. This is particularly the case if \code{\link{vgam}}
- with \code{\link{s}} is used. Then smoothing is best done with
+ with \code{\link{s}} is used; then smoothing is best done with
\code{\link{vglm}} with regression splines (\code{\link[splines]{bs}}
or \code{\link[splines]{ns}}) because \code{\link{vglm}} implements
- half-stepsizing whereas \code{\link{vgam}} doesn't. Half-stepsizing
- helps handle the problem of straying outside the parameter space.
+ half-stepsizing whereas \code{\link{vgam}} doesn't (half-stepsizing
+ helps handle the problem of straying outside the parameter space.)
}
\value{
@@ -185,6 +185,10 @@ egev(llocation = "identity", lscale = "loge", lshape = "logoff",
and \code{\link{vgam}}.
}
\references{
+ Yee, T. W. and Stephenson, A. G. (2007)
+ Vector generalized linear and additive extreme value models.
+ \emph{Extremes}, \bold{10}, 1--19.
+
Tawn, J. A. (1988)
An extreme-value theory model for dependent observations.
\emph{Journal of Hydrology}, \bold{101}, 227--250.
@@ -203,8 +207,9 @@ egev(llocation = "identity", lscale = "loge", lshape = "logoff",
\note{
The \pkg{VGAM} family function \code{gev} can handle a multivariate
- (matrix) response. If so, each row of the matrix is sorted into
- descending order. With a vector or one-column matrix response using
+ (matrix) response. If so, each row of the matrix is sorted into
+ descending order and \code{NA}s are put last.
+ With a vector or one-column matrix response using
\code{egev} will give the same result but be faster and it handles
the \eqn{\xi=0}{xi=0} case.
The function \code{gev} implements Tawn (1988) while
@@ -220,8 +225,8 @@ egev(llocation = "identity", lscale = "loge", lshape = "logoff",
Successful convergence often depends on having a reasonably good initial
value for \eqn{\xi}{xi}. If failure occurs try various values for the
- argument \code{ishape}, and if there are covariates, setting \code{zero=3}
- is advised.
+ argument \code{ishape}, and if there are covariates,
+ having \code{zero=3} is advised.
}
diff --git a/man/gpd.Rd b/man/gpd.Rd
index 7d8f047..c833ddd 100644
--- a/man/gpd.Rd
+++ b/man/gpd.Rd
@@ -181,6 +181,10 @@ gpd(threshold = 0, lscale = "loge", lshape = "logoff",
}
\references{
+ Yee, T. W. and Stephenson, A. G. (2007)
+ Vector generalized linear and additive extreme value models.
+ \emph{Extremes}, \bold{10}, 1--19.
+
Coles, S. (2001)
\emph{An Introduction to Statistical Modeling of Extreme Values}.
London: Springer-Verlag.
diff --git a/man/grc.Rd b/man/grc.Rd
index 469e24d..42b8faf 100644
--- a/man/grc.Rd
+++ b/man/grc.Rd
@@ -15,7 +15,7 @@ grc(y, Rank = 1, Index.corner = 2:(1 + Rank),
\item{y}{
A matrix of counts. Output from \code{table()} is acceptable;
it is converted into a matrix.
- \code{y} must be at least 3 by 3.
+ Note that \code{y} must be at least 3 by 3.
}
\item{Rank}{
An integer in the range
@@ -24,7 +24,7 @@ grc(y, Rank = 1, Index.corner = 2:(1 + Rank),
}
\item{Index.corner}{
- A \code{Rank}-vector of integers.
+ A vector of \code{Rank} integers.
These are used to store the \code{Rank} by \code{Rank}
identity matrix in the
\code{A} matrix; corner constraints are used.
diff --git a/man/gumbel.Rd b/man/gumbel.Rd
index ca7bfe4..fcb9c32 100644
--- a/man/gumbel.Rd
+++ b/man/gumbel.Rd
@@ -116,6 +116,10 @@ egumbel(llocation = "identity", lscale = "loge",
and \code{\link{vgam}}.
}
\references{
+ Yee, T. W. and Stephenson, A. G. (2007)
+ Vector generalized linear and additive extreme value models.
+ \emph{Extremes}, \bold{10}, 1--19.
+
Smith, R. L. (1986)
Extreme value theory based on the \emph{r} largest annual events.
\emph{Journal of Hydrology},
diff --git a/man/hspider.Rd b/man/hspider.Rd
index b55ddbe..65b7704 100644
--- a/man/hspider.Rd
+++ b/man/hspider.Rd
@@ -56,6 +56,7 @@ data(hspider)
str(hspider)
\dontrun{
+# Fit a rank-1 Poisson CQO
set.seed(111) # This leads to the global solution
hspider[,1:6]=scale(hspider[,1:6]) # Standardize the environmental variables
p1 = cqo(cbind(Alopacce, Alopcune, Alopfabr, Arctlute, Arctperi, Auloalbi,
@@ -66,6 +67,20 @@ nos = ncol(p1 at y)
lvplot(p1, y=TRUE, lcol=1:nos, pch=1:nos, pcol=1:nos)
Coef(p1)
summary(p1)
+
+
+
+# Fit a rank-1 binomial CAO
+hsbin = hspider # Binary species data
+hsbin[,-(1:6)] = as.numeric(hsbin[,-(1:6)] > 0)
+set.seed(123)
+ahsb1 = cao(cbind(Alopcune,Arctlute,Auloalbi,Zoraspin) ~
+ WaterCon + ReflLux, family = binomialff(mv=TRUE),
+ df1.nl = 2.2, Bestof=3, data = hsbin)
+par(mfrow=2:1, las=1)
+lvplot(ahsb1, type="predictors", llwd=2, ylab="logit p", lcol=1:9)
+persp(ahsb1, rug=TRUE, col=1:10, lwd=2)
+coef(ahsb1)
}
}
\keyword{datasets}
diff --git a/man/hunua.Rd b/man/hunua.Rd
index 649098a..d6b2a56 100644
--- a/man/hunua.Rd
+++ b/man/hunua.Rd
@@ -1,7 +1,7 @@
\name{hunua}
\alias{hunua}
\non_function{}
-\title{Hunua Ranges data}
+\title{Hunua Ranges Data}
\usage{data(hunua)}
\description{
The \code{hunua} data frame has 392 rows and 18 columns.
@@ -51,14 +51,14 @@
\examples{
# Fit a GAM using vgam() and compare it with the Waitakere Ranges one
data(hunua)
-fit.h = vgam(agaaus ~ s(altitude), binomialff, hunua)
+fit.h = vgam(agaaus ~ s(altitude, df=2), binomialff, hunua)
\dontrun{
plot(fit.h, se=TRUE, lcol="red", scol="red",
main="Red is Hunua, Blue is Waitakere") }
predict(fit.h, hunua, type="response")[1:3]
data(waitakere)
-fit.w = vgam(agaaus ~ s(altitude), binomialff, waitakere)
+fit.w = vgam(agaaus ~ s(altitude, df=2), binomialff, waitakere)
\dontrun{
plot(fit.w, se=TRUE, lcol="blue", scol="blue", add=TRUE) }
predict(fit.w, hunua, type="response")[1:3] # Same as above?
diff --git a/man/laplace.Rd b/man/laplace.Rd
new file mode 100644
index 0000000..dfd02c3
--- /dev/null
+++ b/man/laplace.Rd
@@ -0,0 +1,115 @@
+\name{laplace}
+\alias{laplace}
+%- Also NEED an '\alias' for EACH other topic documented here.
+\title{ Laplace Distribution }
+\description{
+ Maximum likelihood estimation of the 2-parameter Laplace distribution.
+}
+\usage{
+laplace(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.
+\arguments{
+ \item{llocation, lscale}{ Character.
+ Parameter link functions for location parameter \eqn{a} and
+ scale parameter \eqn{b}.
+ 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{ilocation, iscale}{
+ Optional initial values.
+ If given, it must be numeric and values are recycled to the
+ appropriate length.
+ The default is to choose the value internally.
+ }
+ \item{method.init}{
+ Initialization method.
+ Either the value 1 or 2.
+
+ }
+ \item{zero}{
+ An integer-valued vector specifying which
+ linear/additive predictors are modelled as intercepts only.
+ The value (possibly values) must be from the
+ set \{1,2\} corresponding
+ respectively to \eqn{a} and \eqn{b}.
+ By default all linear/additive predictors are modelled as
+ a linear combination of the explanatory variables.
+
+ }
+}
+\details{
+ The Laplace distribution is often known as the
+ \emph{double-exponential} distribution and,
+ for modelling, has heavier tail than the normal distribution.
+ The Laplace density function is
+ \deqn{f(y) = \frac{1}{2b} \exp \left( - \frac{|y-a|}{b}
+ \right) }{%
+ f(y) = (1/(2b)) exp( -|y-a|/b ) }
+ where \eqn{-\infty<y<\infty}{-Inf<y<Inf},
+ \eqn{-\infty<a<\infty}{-Inf<a<Inf} and
+ \eqn{b>0}.
+ Its mean is \eqn{a} and its variance is \eqn{2b^2}.
+
+ For \code{y ~ 1} (where \code{y} is the response) the maximum likelihood
+ estimate (MLE) for the location parameter is the sample median, and
+ the MLE for \eqn{b} is \code{mean(abs(y-location))} (replace
+ location by its MLE if unknown).
+
+}
+\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{
+Kotz, S., Kozubowski, T. J. and Podgorski, K. (2001)
+\emph{The Laplace distribution and generalizations:
+a revisit with applications to communications,
+economics, engineering, and finance},
+Boston: Birkhauser.
+
+}
+\author{ T. W. Yee }
+\section{Warning}{
+ This family function has not been fully tested.
+ The MLE regularity conditions do not hold for this distribution,
+ therefore misleading inferences may result,
+ e.g., in the \code{summary} and \code{vcov} of the object.
+
+}
+\note{
+ This family function uses Fisher scoring.
+ Convergence may be slow for non-intercept-only models;
+ half-stepping is frequently required.
+
+}
+
+\seealso{
+ \code{\link{rlaplace}}.
+}
+
+\examples{
+y = rlaplace(n <- 100, loc=2, scale=exp(1))
+fit = vglm(y ~ 1, laplace, trace=TRUE, crit="l")
+coef(fit, matrix=TRUE)
+Coef(fit)
+median(y)
+
+x = runif(n <- 1001)
+y = rlaplace(n, loc=2, scale=exp(-1+1*x))
+fit = vglm(y ~ x, laplace(iloc=0.2, meth=2, zero=1), trace=TRUE)
+coef(fit, matrix=TRUE)
+}
+\keyword{models}
+\keyword{regression}
+
diff --git a/man/laplaceUC.Rd b/man/laplaceUC.Rd
index 87a7e2b..af5ddd8 100644
--- a/man/laplaceUC.Rd
+++ b/man/laplaceUC.Rd
@@ -22,29 +22,33 @@ rlaplace(n, location=0, scale=1)
\item{x, q}{vector of quantiles.}
\item{p}{vector of probabilities.}
\item{n}{number of observations. Positive integer of length 1.}
- \item{location}{the location parameter \eqn{\mu}{mu}, which
- is the mean. }
- \item{scale}{the scale parameter \eqn{b}. Must consist of
- positive values. }
+ \item{location}{
+ the location parameter \eqn{a}, which is the mean.
+ }
+ \item{scale}{
+ the scale parameter \eqn{b}.
+ Must consist of positive values.
+ }
}
\details{
The Laplace distribution is often known as the double-exponential
distribution and, for modelling, has heavier tail
than the normal distribution.
The Laplace density function is
- \deqn{f(y) = \frac{1}{2b} \exp \left( - \frac{|y-\mu|}{b}
+ \deqn{f(y) = \frac{1}{2b} \exp \left( - \frac{|y-a|}{b}
\right) }{%
- f(y) = (1/(2b)) exp( -|y-mu|/b ) }
+ f(y) = (1/(2b)) exp( -|y-a|/b ) }
where \eqn{-\infty<y<\infty}{-Inf<y<Inf},
- \eqn{-\infty<\mu<\infty}{-Inf<mu<Inf} and
+ \eqn{-\infty<a<\infty}{-Inf<a<Inf} and
\eqn{b>0}.
- The mean is \eqn{\mu}{mu} and the variance is \eqn{2b^2}.
+ The mean is \eqn{a}{a} and the variance is \eqn{2b^2}.
+
+ See \code{\link{laplace}}, the \pkg{VGAM} family function
+ for estimating the two parameters by maximum likelihood estimation,
+ for formulae and details.
+ Apart from \code{n}, all the above arguments may be vectors and
+ are recyled to the appropriate length if necessary.
-% See \code{\link{laplace}}, the \pkg{VGAM} family function
-% for estimating the two parameters by maximum likelihood estimation,
-% for formulae and details.
-% Apart from \code{n}, all the above arguments may be vectors and
-% are recyled to the appropriate length if necessary.
}
\value{
\code{dlaplace} gives the density,
@@ -63,9 +67,9 @@ New York: Wiley-Interscience, Third edition.
% estimates the two parameters by maximum likelihood estimation.
%}
-%\seealso{
-% \code{\link{laplace}}.
-%}
+\seealso{
+ \code{\link{laplace}}.
+}
\examples{
loc = 1; b = 2
y = rlaplace(n=100, loc=loc, scale=b)
diff --git a/man/lms.bcg.Rd b/man/lms.bcg.Rd
index a21178c..08ca629 100644
--- a/man/lms.bcg.Rd
+++ b/man/lms.bcg.Rd
@@ -146,7 +146,8 @@ Green manuscript.)
\code{\link{qtplot.lmscreg}},
\code{\link{deplot.lmscreg}},
\code{\link{cdf.lmscreg}},
-\code{\link{bminz}}.
+\code{\link{bminz}},
+\code{\link{alsqreg}}.
}
\examples{
diff --git a/man/lms.bcn.Rd b/man/lms.bcn.Rd
index f51e175..e04b961 100644
--- a/man/lms.bcn.Rd
+++ b/man/lms.bcn.Rd
@@ -142,7 +142,8 @@ number corresponding to the highest likelihood value.
\code{\link{qtplot.lmscreg}},
\code{\link{deplot.lmscreg}},
\code{\link{cdf.lmscreg}},
-\code{\link{bminz}}.
+\code{\link{bminz}},
+\code{\link{alsqreg}}.
}
\examples{
diff --git a/man/lms.yjn.Rd b/man/lms.yjn.Rd
index 305e457..dbba440 100644
--- a/man/lms.yjn.Rd
+++ b/man/lms.yjn.Rd
@@ -179,11 +179,13 @@ The generic function \code{predict}, when applied to a
\code{\link{qtplot.lmscreg}},
\code{\link{deplot.lmscreg}},
\code{\link{cdf.lmscreg}},
-\code{\link{bminz}}.
+\code{\link{bminz}},
+\code{\link{alsqreg}}.
}
\examples{
data(bminz)
-fit = vgam(BMI ~ s(age, df=c(2,4,2)), fam=lms.yjn, data=bminz, tr=TRUE)
+fit = vgam(BMI ~ s(age, df=4), fam=lms.yjn(zero=c(1,3)),
+ data=bminz, trace=TRUE)
predict(fit)[1:3,]
fitted(fit)[1:3,]
bminz[1:3,]
@@ -210,3 +212,4 @@ a at post$deplot # Contains density function values
\keyword{models}
\keyword{regression}
+%fit = vgam(BMI ~ s(age, df=c(2,4,2)), fam=lms.yjn, data=bminz, tr=TRUE)
diff --git a/man/logit.Rd b/man/logit.Rd
index ac6e06e..5debe5a 100644
--- a/man/logit.Rd
+++ b/man/logit.Rd
@@ -50,6 +50,7 @@ elogit(theta, earg = list(min=0, max=1), inverse = FALSE, deriv = 0,
}
\item{inverse}{
Logical. If \code{TRUE} the inverse function is computed.
+ The inverse logit function is known as the \emph{expit} function.
}
\item{deriv}{
diff --git a/man/loglinb2.Rd b/man/loglinb2.Rd
index f301684..7eaadfd 100644
--- a/man/loglinb2.Rd
+++ b/man/loglinb2.Rd
@@ -45,7 +45,7 @@ loglinb2(exchangeable = FALSE, zero = NULL)
\references{
-Yee, T. W. and Wild, C. J. (2001).
+Yee, T. W. and Wild, C. J. (2001)
Discussion to: ``Smoothing spline ANOVA for multivariate Bernoulli
observations, with application to ophthalmology data (with discussion)''
by Gao, F., Wahba, G., Klein, R., Klein, B.
diff --git a/man/loglinb3.Rd b/man/loglinb3.Rd
index cddd40f..473391c 100644
--- a/man/loglinb3.Rd
+++ b/man/loglinb3.Rd
@@ -50,7 +50,7 @@ loglinb3(exchangeable = FALSE, zero = NULL)
\references{
-Yee, T. W. and Wild, C. J. (2001).
+Yee, T. W. and Wild, C. J. (2001)
Discussion to: ``Smoothing spline ANOVA for multivariate Bernoulli
observations, with application to ophthalmology data (with discussion)''
by Gao, F., Wahba, G., Klein, R., Klein, B.
diff --git a/man/maxwell.Rd b/man/maxwell.Rd
index 6d2f50c..6ad139d 100644
--- a/man/maxwell.Rd
+++ b/man/maxwell.Rd
@@ -34,21 +34,25 @@ maxwell(link = "loge", earg=list())
\eqn{\sqrt{8 / (a \pi)}}{sqrt(8 / (a * pi))}
(returned as the fitted values), and its variance is
\eqn{(3\pi - 8)/(\pi a)}{(3*pi - 8)/(pi*a)}.
+
}
\value{
An object of class \code{"vglmff"} (see \code{\link{vglmff-class}}).
The object is used by modelling functions such as \code{\link{vglm}},
\code{\link{rrvglm}}
and \code{\link{vgam}}.
+
}
\references{
von Seggern, D. H. (1993)
\emph{CRC Standard Curves and Surfaces},
Boca Raton, FL.: CRC Press.
+
}
\author{ T. W. Yee }
\note{
-A related distribution is the Rayleigh distribution.
+ A related distribution is the Rayleigh distribution.
+ Fisher-scoring and Newton-Raphson are the same here.
}
diff --git a/man/nakagami.Rd b/man/nakagami.Rd
index 101cf03..cabffe6 100644
--- a/man/nakagami.Rd
+++ b/man/nakagami.Rd
@@ -61,7 +61,7 @@ nakagami(lshape = "loge", lscale = "loge",
}
\references{
- Nakagami, M. (1960).
+ Nakagami, M. (1960)
The \emph{m}-distribution: a general formula of
intensity distribution of rapid fading,
pp.3--36 in:
diff --git a/man/negbinomial.Rd b/man/negbinomial.Rd
index a2493b2..fa3fc0b 100644
--- a/man/negbinomial.Rd
+++ b/man/negbinomial.Rd
@@ -10,7 +10,8 @@
negbinomial(lmu = "loge", lk = "loge",
emu =list(), ek=list(),
ik = NULL, cutoff = 0.995, Maxiter=5000,
- deviance.arg = FALSE, method.init=1, zero = -2)
+ deviance.arg = FALSE, method.init=1,
+ shrinkage.init=0.95, zero = -2)
}
%- maybe also 'usage' for other objects documented here.
\arguments{
@@ -64,10 +65,19 @@ negbinomial(lmu = "loge", lk = "loge",
}
\item{method.init}{
- An integer with value \code{1}, \code{2} or \code{3} which
+ An integer with value \code{1} or \code{2} which
specifies the initialization method for the \eqn{\mu}{mu} parameter.
- If failure to converge occurs
- try another value (and/or specify a value for \code{ik}).
+ If failure to converge occurs try another value
+ and/or else specify a value for \code{shrinkage.init}
+ and/or else specify a value for \code{ik}.
+
+ }
+ \item{shrinkage.init}{
+ How much shrinkage is used when initializing \eqn{\mu}{mu}.
+ The value must be between 0 and 1 inclusive, and
+ a value of 0 means the individual response values are used,
+ and a value of 1 means the median or mean is used.
+ This argument is used in conjunction with \code{method.init}.
}
\item{zero}{
diff --git a/man/ordpoisson.Rd b/man/ordpoisson.Rd
index f2199cd..4309f4a 100644
--- a/man/ordpoisson.Rd
+++ b/man/ordpoisson.Rd
@@ -114,7 +114,8 @@ ordpoisson(cutpoints, countdata=FALSE, NOS=NULL,
\seealso{
\code{\link{poissonff}},
- \code{\link{polf}}.
+ \code{\link{polf}},
+ \code{\link[base:factor]{ordered}}.
}
\examples{
diff --git a/man/pareto1.Rd b/man/pareto1.Rd
index 38fe355..2e79ec0 100644
--- a/man/pareto1.Rd
+++ b/man/pareto1.Rd
@@ -11,7 +11,8 @@
}
\usage{
pareto1(lshape = "loge", earg=list(), location=NULL)
-tpareto1(lower, upper, lshape = "loge", earg=list(), ishape=NULL)
+tpareto1(lower, upper, lshape = "loge", earg=list(), ishape=NULL,
+ method.init=1)
}
%- maybe also 'usage' for other objects documented here.
\arguments{
@@ -37,6 +38,7 @@ tpareto1(lower, upper, lshape = "loge", earg=list(), ishape=NULL)
Numeric.
Optional initial value for the shape parameter.
A \code{NULL} means a value is obtained internally.
+ If failure to converge occurs try specifying a value, e.g., 1 or 2.
}
\item{location}{
@@ -47,6 +49,12 @@ tpareto1(lower, upper, lshape = "loge", earg=list(), ishape=NULL)
vector.
}
+ \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{ishape}.
+
+ }
}
\details{
A random variable \eqn{Y} has a Pareto distribution if
@@ -95,7 +103,7 @@ tpareto1(lower, upper, lshape = "loge", earg=list(), ishape=NULL)
\emph{Statistical Distributions},
New York: Wiley-Interscience, Third edition.
- Aban, I. B., Meerschaert, M. M. and Panorska, A. K. (2006).
+ Aban, I. B., Meerschaert, M. M. and Panorska, A. K. (2006)
Parameter estimation for the truncated Pareto distribution,
\emph{Journal of the American Statistical Association},
\bold{101}(473),
@@ -173,3 +181,5 @@ c(fit3 at misc$lower, fit3 at misc$upper)
\keyword{models}
\keyword{regression}
+% Package lmomco fits generalized pareto (three parameter) using method of L-moments.
+
diff --git a/man/poissonff.Rd b/man/poissonff.Rd
index 8783fe2..ff3b6c5 100644
--- a/man/poissonff.Rd
+++ b/man/poissonff.Rd
@@ -123,7 +123,8 @@ poissonff(link = "loge", earg=list(), dispersion = 1,
\code{\link{cao}},
\code{\link{binomialff}},
\code{\link{quasibinomialff}},
- \code{\link[stats]{poisson}}.
+ \code{\link[stats]{poisson}},
+ \code{\link{poissonp}}.
}
\examples{
poissonff()
diff --git a/man/poissonp.Rd b/man/poissonp.Rd
new file mode 100644
index 0000000..adf0bd1
--- /dev/null
+++ b/man/poissonp.Rd
@@ -0,0 +1,109 @@
+\name{poissonp}
+\alias{poissonp}
+%- Also NEED an '\alias' for EACH other topic documented here.
+\title{ Poisson-points-on-a-plane/volume Distances Distribution }
+\description{
+ Estimating the density parameter of the distances from a fixed point
+ to the u-th nearest point, in a plane or volume.
+
+}
+\usage{
+poissonp(ostatistic, dimension=2, link="loge", earg=list(),
+ idensity=NULL, method.init=1)
+}
+%- maybe also 'usage' for other objects documented here.
+\arguments{
+ \item{ostatistic}{
+ Order statistic. A single positive integer.
+ For example, the value 5 means the response are the distances of the
+ fifth nearest value to that point (usually over many planes or volumes).
+
+ }
+ \item{dimension}{
+ The value 2 or 3; 2 meaning a plane and 3 meaning a volume.
+
+ }
+ \item{link}{
+ Parameter link function applied to the (positive) density parameter,
+ called \eqn{\lambda}{lambda} below.
+ 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{idensity}{
+ Optional initial value for the parameter.
+ A \code{NULL} value means a value is obtained internally.
+ Use this argument if convergence failure occurs.
+
+ }
+ \item{method.init}{
+ An integer with value \code{1} or \code{2} which
+ specifies the initialization method for \eqn{\lambda}{lambda}.
+ If failure to converge occurs try another value
+ and/or else specify a value for \code{idensity}.
+
+ }
+}
+\details{
+ Suppose the number of points in any region of area \eqn{A} of the
+ plane is a Poisson random variable with mean \eqn{\lambda A}{lambda*A}
+ (i.e., \eqn{\lambda}{lambda} is the \emph{density} of the points).
+ Given a fixed point \eqn{P}, define \eqn{D_1}, \eqn{D_2},\ldots to be
+ the distance to the nearest point to \eqn{P}, second nearest to \eqn{P},
+ etc. This \pkg{VGAM} family function estimates \eqn{\lambda}{lambda}
+ since the probability density function for \eqn{D_u} is easily derived,
+ \eqn{u=1,2,\ldots}{u=1,2,...}. Here, \eqn{u} corresponds to the
+ argument \code{ostatistic}.
+
+ Similarly, suppose the number of points in any volume \eqn{V} is a
+ Poisson random variable with mean
+ \eqn{\lambda V}{lambda*V} where, once again, \eqn{\lambda}{lambda}
+ is the \emph{density} of the points.
+ This \pkg{VGAM} family function estimates \eqn{\lambda}{lambda} by
+ specifying the argument \code{ostatistic} and using
+ \code{dimension=3}.
+
+ The mean of \eqn{D_u} is returned as the fitted values.
+ Newton-Raphson is the same as Fisher-scoring.
+
+}
+\section{Warning}{
+ Convergence may be slow if the initial values are far from the
+ solution. This often corresponds to the situation when the response
+ values are all close to zero, i.e., there is a high density of points.
+
+ Formulae such as the means have not been fully checked.
+
+}
+\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{
+%}
+\author{ T. W. Yee }
+%\note{
+%}
+\seealso{
+ \code{\link{poissonff}}.
+}
+\examples{
+y = rgamma(n <- 10, shape=exp(-1)) # Not good data!
+os = 2
+fit = vglm(y ~ 1, poissonp(os, 2), tra=TRUE, cri="c")
+fit = vglm(y ~ 1, poissonp(os, 3), tra=TRUE, cri="c") # Slow convergence?
+fit = vglm(y ~ 1, poissonp(os, 3, idensi=1), tra=TRUE, cri="c")
+fitted(fit)[1:4]
+mean(y)
+coef(fit, matrix=TRUE)
+Coef(fit)
+}
+\keyword{models}
+\keyword{regression}
+
diff --git a/man/quasibinomialff.Rd b/man/quasibinomialff.Rd
index eef1c95..f28d41a 100644
--- a/man/quasibinomialff.Rd
+++ b/man/quasibinomialff.Rd
@@ -127,10 +127,10 @@ quasibinomialff(link="probit")
data(hunua)
hunua = transform(hunua, a.5 = sqrt(altitude)) # Transformation of altitude
fit1 = vglm(agaaus ~ poly(a.5, 2), quasibinomialff, hunua)
-fit2 = vgam(agaaus ~ s(a.5), quasibinomialff, hunua)
+fit2 = vgam(agaaus ~ s(a.5, df=2), quasibinomialff, hunua)
\dontrun{
-plot(fit2, se=TRUE, llwd=2, lcol="darkgreen", scol="darkgreen",
- xlab="sqrt(altitude)",
+plot(fit2, se=TRUE, llwd=2, lcol="red", scol="red",
+ xlab="sqrt(altitude)", ylim=c(-3,1),
main="GAM and quadratic GLM fitted to species data")
plotvgam(fit1, se=TRUE, lcol="blue", scol="blue", add=TRUE, llwd=2)
}
diff --git a/man/rayleigh.Rd b/man/rayleigh.Rd
index 0cda1a7..1c5797d 100644
--- a/man/rayleigh.Rd
+++ b/man/rayleigh.Rd
@@ -9,7 +9,7 @@
}
\usage{
-rayleigh(link = "loge", earg=list())
+rayleigh(link = "loge", earg=list(), nrfs=1/3+0.01)
crayleigh(link ="loge", earg=list(), expected=FALSE)
}
%- maybe also 'usage' for other objects documented here.
@@ -25,6 +25,14 @@ crayleigh(link ="loge", earg=list(), expected=FALSE)
See \code{earg} in \code{\link{Links}} for general information.
}
+ \item{nrfs}{
+ Numeric, of length one, with value in \eqn{[0,1]}.
+ Weighting factor between Newton-Raphson and Fisher scoring.
+ The value 0 means pure Newton-Raphson, while 1 means pure Fisher scoring.
+ The default value uses a mixture of the two algorithms, and retaining
+ positive-definite working weights.
+
+ }
\item{expected}{
Logical. For censored data only, \code{FALSE}
means the Newton-Raphson algorithm, and \code{TRUE} means Fisher scoring.
@@ -61,17 +69,18 @@ crayleigh(link ="loge", earg=list(), expected=FALSE)
\code{\link{rrvglm}}
and \code{\link{vgam}}.
}
-\references{
+\references{
Evans, M., Hastings, N. and Peacock, B. (2000)
\emph{Statistical Distributions},
New York: Wiley-Interscience, Third edition.
}
\author{ T. W. Yee }
-\note{ A related distribution is the Maxwell distribution.
+\note{
+A related distribution is the Maxwell distribution.
}
\seealso{
- \code{\link{Rayleigh}},
- \code{\link{maxwell}}.
+ \code{\link{Rayleigh}},
+ \code{\link{maxwell}}.
}
\examples{
n = 1000; a = exp(2)
@@ -85,7 +94,9 @@ Coef(fit)
# Censored data
U = runif(n, 5, 15)
y = pmin(U, ystar)
-\dontrun{ par(mfrow=c(1,2)); hist(ystar); hist(y); }
+\dontrun{
+par(mfrow=c(1,2)); hist(ystar); hist(y)
+}
extra = list(rightcensored = ystar > U)
fit = vglm(y ~ 1, crayleigh, trace=TRUE, extra=extra)
table(fit at extra$rightcen)
diff --git a/man/ruge.Rd b/man/ruge.Rd
index 2854a2d..642087d 100644
--- a/man/ruge.Rd
+++ b/man/ruge.Rd
@@ -1,7 +1,7 @@
\name{ruge}
\alias{ruge}
\non_function{}
-\title{Rutherford-Geiger polonium data}
+\title{Rutherford-Geiger Polonium Data}
\usage{data(ruge)}
\description{
Decay counts of polonium recorded by Rutherford and Geiger (1910).
diff --git a/man/s.Rd b/man/s.Rd
index 9a02744..a930beb 100644
--- a/man/s.Rd
+++ b/man/s.Rd
@@ -87,7 +87,7 @@ Vector generalized additive models.
\examples{
# Nonparametric logistic regression
data(hunua)
-fit = vgam(agaaus ~ s(altitude, df=3), binomialff, hunua)
+fit = vgam(agaaus ~ s(altitude, df=2), binomialff, hunua)
\dontrun{
plot(fit, se=TRUE)}
diff --git a/man/seq2binomial.Rd b/man/seq2binomial.Rd
new file mode 100644
index 0000000..6e01c44
--- /dev/null
+++ b/man/seq2binomial.Rd
@@ -0,0 +1,112 @@
+\name{seq2binomial}
+\alias{seq2binomial}
+%- Also NEED an '\alias' for EACH other topic documented here.
+\title{ The Two-stage Sequential Binomial Distribution Family Function }
+\description{
+ Estimation of the probabilities of a
+ two-stage binomial distribution.
+
+}
+\usage{
+seq2binomial(lprob1 = "logit", lprob2 = "logit", eprob1 = list(),
+ eprob2 = list(), iprob1 = NULL, iprob2 = NULL, zero = NULL)
+}
+%- maybe also 'usage' for other objects documented here.
+\arguments{
+ \item{lprob1, lprob2}{
+ Parameter link functions applied to the two probabilities,
+ called \eqn{p} and \eqn{q} below.
+ See \code{\link{Links}} for more choices.
+
+ }
+ \item{eprob1, eprob2}{
+ Lists. Extra arguments for the links.
+ See \code{earg} in \code{\link{Links}} for general information.
+
+ }
+ \item{iprob1, iprob2}{
+ Optional initial value for the first and second probabilities respectively.
+ A \code{NULL} means a value is obtained in the \code{initialize} slot.
+
+ }
+ \item{zero}{
+ An integer-valued vector specifying which
+ linear/additive predictors are modelled as intercepts only.
+ If used, the value must be from the set \{1,2\} which correspond to
+ the first and second probabilities respectively.
+ A \code{NULL} value means none.
+
+ }
+}
+\details{
+ This \pkg{VGAM} family function fits the model described by
+ Crowder and Sweeting (1989) which is described as follows.
+ Each of \eqn{m} spores has a probability \eqn{p} of germinating. Of
+ the \eqn{y_1}{y1} spores that germinate, each has a probability \eqn{q}
+ of bending in a particular direction. Let \eqn{y_2}{y2} be the number that
+ bend in the specified direction. The probability model for this data is
+ \eqn{P(y_1,y_2) =}{P(y1,y2) =}
+ \deqn{
+{m \choose y_1} p^{y_1} (1-p)^{m-y_1}
+{y_1 \choose y_2} q^{y_2} (1-q)^{y_1-y_2}}{%
+{choose(m,y1)} p^{y1} (1-p)^{m-y1}
+{choose(y1,y2)} q^{y2} (1-q)^{y1-y2}}
+ for \eqn{0 < p < 1}, \eqn{0 < q < 1},
+ \eqn{y_1=1,\ldots,m}{y1=1,\ldots,m}
+ and
+ \eqn{y_2=1,\ldots,y_1}{y2=1,\ldots,y1}.
+ Here, \eqn{p} is \code{prob1},
+ \eqn{q} is \code{prob2}.
+
+ Although the Authors refer to this as the \emph{bivariate binomial} model,
+ I have named it the \emph{(two-stage) sequential binomial} model.
+ Fisher scoring is used.
+
+}
+\value{
+ An object of class \code{"vglmff"} (see \code{\link{vglmff-class}}).
+ The object is used by modelling functions such as \code{\link{vglm}}
+ and \code{\link{vgam}}.
+
+}
+\references{
+ Crowder, M. and Sweeting, T. (1989).
+ Bayesian inference for a bivariate binomial distribution.
+ \emph{Biometrika},
+ \bold{76},
+ 599--603.
+
+}
+\author{ Thomas W. Yee }
+\note{
+ The response must be a two-column matrix of sample proportions
+ corresponding to \eqn{y_1}{y1} and \eqn{y_2}{y2}.
+ The \eqn{m} values should be inputted with the \code{weights}
+ argument of \code{\link{vglm}}
+ and \code{\link{vgam}}.
+ The fitted value is a two-column matrix of estimated probabilities
+ \eqn{p} and \eqn{q}.
+
+}
+
+\seealso{
+ \code{\link{binomialff}}.
+
+}
+\examples{
+mvector = round(rnorm(n <- 100, m=10, sd=2))
+x = runif(n)
+prob1 = logit(+2-x, inverse=TRUE)
+prob2 = logit(-2+x, inverse=TRUE)
+successes1 = rbinom(n=n, size=mvector, prob=prob1)
+successes2 = rbinom(n=n, size=successes1, prob=prob2)
+y1 = successes1 / mvector
+y2 = successes2 / successes1
+fit = vglm(cbind(y1,y2) ~ x, seq2binomial, trace=TRUE, weight=mvector)
+coef(fit)
+coef(fit, mat=TRUE)
+fitted(fit)[1:5,]
+}
+\keyword{models}
+\keyword{regression}
+
diff --git a/man/simplex.Rd b/man/simplex.Rd
index e785e28..7b00347 100644
--- a/man/simplex.Rd
+++ b/man/simplex.Rd
@@ -63,10 +63,9 @@ London: Chapman & Hall
\examples{
x = runif(n <- 100)
y = rbeta(n, shape1=3+x, shape2=4-x)
-fit = vglm(y ~ 1, simplex, trace=TRUE, eps=1e-9, cri="c")
+(fit = vglm(y ~ 1, simplex, trace=TRUE, cri="coef"))
coef(fit, matrix=TRUE)
Coef(fit)
-fit
summary(fit)
}
\keyword{models}
diff --git a/man/skewnormal1.Rd b/man/skewnormal1.Rd
index 2f16bae..56614a7 100644
--- a/man/skewnormal1.Rd
+++ b/man/skewnormal1.Rd
@@ -62,12 +62,12 @@ skewnormal1(lshape = "identity", earg = list(), ishape = NULL)
}
\references{
-Azzalini, A. A. (1985).
+Azzalini, A. A. (1985)
A class of distributions which include the normal.
\emph{Scandinavian Journal of Statistics},
\bold{12}, 171--178.
-Azzalini, A. and Capitanio, A. (1999).
+Azzalini, A. and Capitanio, A. (1999)
Statistical applications of the multivariate skew-normal
distribution.
\emph{Journal of the Royal Statistical Society, Series B, Methodological},
diff --git a/man/sratio.Rd b/man/sratio.Rd
index b8ab19b..4231608 100644
--- a/man/sratio.Rd
+++ b/man/sratio.Rd
@@ -101,7 +101,8 @@ contains further information and examples.
equal; those of the intercepts and \code{x3} would be different.
}
\section{Warning }{
- No check is made to verify that the response is ordinal.
+ No check is made to verify that the response is ordinal;
+ see \code{\link[base:factor]{ordered}}.
}
\seealso{
diff --git a/man/tobit.Rd b/man/tobit.Rd
index 6314aed..5f1eb95 100644
--- a/man/tobit.Rd
+++ b/man/tobit.Rd
@@ -85,7 +85,7 @@ tobit(Lower = 0, Upper = Inf, lmu="identity", lsd="loge",
and \code{\link{vgam}}.
}
\references{
-Tobin, J. (1958).
+Tobin, J. (1958)
Estimation of relationships for limited dependent variables.
\emph{Econometrica} \bold{26}, 24--36.
}
diff --git a/man/toxop.Rd b/man/toxop.Rd
new file mode 100644
index 0000000..5ed0e7a
--- /dev/null
+++ b/man/toxop.Rd
@@ -0,0 +1,50 @@
+\name{toxop}
+\alias{toxop}
+\docType{data}
+\title{ Toxoplasmosis Data }
+\description{
+ Toxoplasmosis data in 34 cities in El Salvador.
+}
+\usage{data(toxop)}
+\format{
+ A data frame with 34 observations on the following 4 variables.
+ \describe{
+ \item{\code{rainfall}}{a numeric vector; the amount of rainfall in each city.}
+ \item{\code{ssize}}{a numeric vector; sample size.}
+ \item{\code{cityNo}}{a numeric vector; the city number.}
+ \item{\code{positive}}{a numeric vector; the number of subjects testing positive
+ for the disease. }
+ }
+}
+\details{
+ See the references for details.
+}
+\source{
+ See the references for details.
+}
+
+\seealso{
+ \code{\link{dexpbinomial}}.
+}
+
+\references{
+ Efron, B. (1978)
+ Regression and ANOVA With zero-one data: measures of
+ residual variation.
+ \emph{Journal of the American Statistical Association},
+ \bold{73}, 113--121.
+
+ Efron, B. (1986)
+ Double exponential families and their use in generalized linear regression.
+ \emph{Journal of the American Statistical Association},
+ \bold{81}, 709--721.
+
+}
+\examples{
+data(toxop)
+\dontrun{
+with(toxop, plot(rainfall, positive/ssize, col="blue"))
+plot(toxop, col="blue")
+}
+}
+\keyword{datasets}
diff --git a/man/tparetoUC.Rd b/man/tparetoUC.Rd
index b25d3ec..f050b7e 100644
--- a/man/tparetoUC.Rd
+++ b/man/tparetoUC.Rd
@@ -33,7 +33,7 @@ rtpareto(n, lower, upper, shape)
\code{rtpareto} generates random deviates.
}
\references{
- Aban, I. B., Meerschaert, M. M. and Panorska, A. K. (2006).
+ Aban, I. B., Meerschaert, M. M. and Panorska, A. K. (2006)
Parameter estimation for the truncated Pareto distribution,
\emph{Journal of the American Statistical Association},
\bold{101}(473),
diff --git a/man/triangle.Rd b/man/triangle.Rd
new file mode 100644
index 0000000..4a6d496
--- /dev/null
+++ b/man/triangle.Rd
@@ -0,0 +1,83 @@
+\name{triangle}
+\alias{triangle}
+%- Also NEED an '\alias' for EACH other topic documented here.
+\title{Triangle Distribution Family Function }
+\description{
+ Estimating the parameter of the triangle distribution by maximum
+ likelihood estimation.
+
+}
+\usage{
+triangle(lower=0, upper=1, link="elogit",
+ earg=if(link=="elogit") list(min = lower, max = upper) else
+ list(), itheta=NULL)
+}
+%- maybe also 'usage' for other objects documented here.
+\arguments{
+ \item{lower, upper}{lower and upper limits of the distribution.
+ Must be finite.
+ Called \eqn{A} and \eqn{B} respectively below.
+ }
+
+ \item{link}{
+ Parameter link function applied to the parameter \eqn{\theta}{theta},
+ which lies in \eqn{(A,B)}.
+ See \code{\link{Links}} for more choices.
+ The default constrains the estimate to lie in the interval.
+
+ }
+ \item{earg}{
+ List. Extra argument for the link.
+ See \code{earg} in \code{\link{Links}} for general information.
+
+ }
+ \item{itheta}{
+ Optional initial value for the parameter.
+ The default is to compute the value internally.
+
+ }
+}
+\details{
+ The triangle distribution
+ has a probability density function that consists of two lines
+ joined at \eqn{\theta}{theta}. The lines intersect the
+ \eqn{y=0} axis at \eqn{A} and \eqn{B}.
+ Here, Fisher scoring is used.
+
+ On fitting, the \code{extra} slot has components called \code{lower}
+ and \code{upper} which contains the values of the above arguments
+ (recycled to the right length).
+ The fitted values are the mean of the distribution, which is
+ a little messy to write.
+
+}
+\value{
+ An object of class \code{"vglmff"} (see \code{\link{vglmff-class}}).
+ The object is used by modelling functions such as \code{\link{vglm}}
+ and \code{\link{vgam}}.
+}
+%\references{
+%}
+\author{ T. W. Yee }
+\note{
+ The response must contain values in \eqn{(A,B)}.
+ For most data sets (especially small ones) it is very common for
+ half-stepping to occur.
+
+}
+\seealso{
+ \code{\link{Triangle}}.
+}
+\examples{
+y = rtriangle(n <- 3000, theta=3/4)
+fit = vglm(y ~ 1, triangle(link="identity"), trace=TRUE)
+coef(fit, matrix=TRUE)
+Coef(fit)
+fit at extra$lower[1:5]
+
+fitted(fit)[1:5]
+mean(y)
+}
+\keyword{models}
+\keyword{regression}
+
diff --git a/man/triangleUC.Rd b/man/triangleUC.Rd
new file mode 100644
index 0000000..d6b6721
--- /dev/null
+++ b/man/triangleUC.Rd
@@ -0,0 +1,71 @@
+\name{Triangle}
+\alias{Triangle}
+\alias{dtriangle}
+\alias{ptriangle}
+\alias{qtriangle}
+\alias{rtriangle}
+\title{The Triangle Distribution}
+\description{
+ Density, distribution function, quantile function and random
+ generation for the Triangle distribution with parameter
+ \code{theta}.
+}
+\usage{
+dtriangle(x, theta, lower=0, upper=1)
+ptriangle(q, theta, lower=0, upper=1)
+qtriangle(p, theta, lower=0, upper=1)
+rtriangle(n, theta, lower=0, upper=1)
+}
+\arguments{
+ \item{x, q}{vector of quantiles.}
+ \item{p}{vector of probabilities.}
+ \item{n}{number of observations.
+ Must be a positive integer of length 1.}
+ \item{theta}{the theta parameter which lies between \code{lower}
+ and \code{upper}. }
+ \item{lower, upper}{lower and upper limits of the distribution.
+ Must be finite.
+ }
+}
+\value{
+ \code{dtriangle} gives the density,
+ \code{ptriangle} gives the distribution function,
+ \code{qtriangle} gives the quantile function, and
+ \code{rtriangle} generates random deviates.
+}
+%\references{
+%
+%}
+\author{ T. W. Yee }
+\details{
+ See \code{\link{triangle}}, the \pkg{VGAM} family function
+ for estimating the parameter \eqn{\theta}{theta} by
+ maximum likelihood estimation.
+
+}
+%\note{
+%
+%}
+\seealso{
+ \code{\link{triangle}}.
+}
+\examples{
+\dontrun{
+x = seq(-0.1, 1.1, by=0.01)
+theta = 0.75
+plot(x, dtriangle(x, theta=theta), type="l", col="blue", las=1,
+ main="Blue is density, red is cumulative distribution function",
+ sub="Purple lines are the 10,20,...,90 percentiles",
+ ylim=c(0,2), ylab="")
+abline(h=0, col="blue", lty=2)
+lines(x, ptriangle(x, theta=theta), col="red")
+probs = seq(0.1, 0.9, by=0.1)
+Q = qtriangle(probs, theta=theta)
+lines(Q, dtriangle(Q, theta=theta), col="purple", lty=3, type="h")
+ptriangle(Q, theta=theta) - probs # Should be all zero
+abline(h=probs, col="purple", lty=3)
+}
+}
+\keyword{distribution}
+
+
diff --git a/man/vgam-class.Rd b/man/vgam-class.Rd
index ce3bcf6..63cc683 100644
--- a/man/vgam-class.Rd
+++ b/man/vgam-class.Rd
@@ -198,7 +198,7 @@ Useful for extreme value data models.}
\item{summary}{\code{signature(object = "vglm")}:
a more detailed summary of the object. }
}
-}
+
\references{
Yee, T. W. and Wild, C. J. (1996)
Vector generalized additive models.
diff --git a/man/vgam.Rd b/man/vgam.Rd
index 6103466..169a02c 100644
--- a/man/vgam.Rd
+++ b/man/vgam.Rd
@@ -265,13 +265,14 @@ vgam(cbind(normal,mild,severe) ~ s(let), cumulative(par=TRUE), pneumo)
# Nonparametric logistic regression
data(hunua)
-fit = vgam(agaaus ~ s(altitude), binomialff, hunua)
+fit = vgam(agaaus ~ s(altitude, df=2), binomialff, hunua)
\dontrun{
plot(fit, se=TRUE)
}
# Fit two species simultaneously
-fit2 = vgam(cbind(agaaus, kniexc) ~ s(altitude), binomialff(mv=TRUE), hunua)
+fit2 = vgam(cbind(agaaus, kniexc) ~ s(altitude, df=c(2,3)),
+ binomialff(mv=TRUE), hunua)
coef(fit2, mat=TRUE) # Not really interpretable
\dontrun{
plot(fit2, se=TRUE, overlay=TRUE, lcol=1:2, scol=1:2)
diff --git a/man/waitakere.Rd b/man/waitakere.Rd
index 68ae1bb..7750ae2 100644
--- a/man/waitakere.Rd
+++ b/man/waitakere.Rd
@@ -1,7 +1,7 @@
\name{waitakere}
\alias{waitakere}
\non_function{}
-\title{Waitakere Ranges data}
+\title{Waitakere Ranges Data}
\usage{data(waitakere)}
\description{
The \code{waitakere} data frame has 579 rows and 18 columns.
@@ -50,7 +50,7 @@
}
\examples{
data(waitakere)
-fit = vgam(agaaus ~ s(altitude), binomialff, waitakere)
+fit = vgam(agaaus ~ s(altitude, df=2), binomialff, waitakere)
\dontrun{
plot(fit, se=TRUE, lcol="red", scol="blue") }
predict(fit, waitakere, type="response")[1:3]
diff --git a/man/weibull.Rd b/man/weibull.Rd
index d3cbc1f..0310caa 100644
--- a/man/weibull.Rd
+++ b/man/weibull.Rd
@@ -4,14 +4,14 @@
\title{ Weibull Distribution Family Function }
\description{
Maximum likelihood estimation of the 2-parameter Weibull distribution.
- Allows for Type-I right censored data.
+ No observations should be censored.
}
\usage{
-weibull(lshape = "logoff", lscale = "loge",
- eshape=if(lshape == "logoff") list(offset=-2) else list(),
- escale=list(),
- ishape = NULL, iscale = NULL, imethod=1, zero = 2)
+weibull(lshape = "loge", lscale = "loge",
+ eshape = list(), escale = list(),
+ ishape = NULL, iscale = NULL,
+ nrfs = 1, imethod=1, zero = 2)
}
%- maybe also 'usage' for other objects documented here.
\arguments{
@@ -30,6 +30,16 @@ weibull(lshape = "logoff", lscale = "loge",
Parameter link functions applied to the
\item{ishape, iscale}{
Optional initial values for the shape and scale parameters.
+
+ }
+ \item{nrfs}{
+ Currently this argument is ignored.
+ Numeric, of length one, with value in \eqn{[0,1]}.
+ Weighting factor between Newton-Raphson and Fisher scoring.
+ The value 0 means pure Newton-Raphson, while 1 means pure Fisher scoring.
+ The default value uses a mixture of the two algorithms, and retaining
+ positive-definite working weights.
+
}
\item{imethod}{
Initialization method used if there are censored observations.
@@ -60,14 +70,17 @@ weibull(lshape = "logoff", lscale = "loge",
\eqn{E(Y^k) = b^k \, \Gamma(1+ k/a)}{E(Y^k) = b^k * gamma(1+ k/a)}.
The hazard function is \eqn{a t^{a-1} / b^a}{a * t^(a-1) / b^a}.
- This \pkg{VGAM} family function handles Type-I right censored data as
- well as complete data.
+ This \pkg{VGAM} family function currently does not handle
+ censored data.
Fisher scoring is used to estimate the two parameters.
- The Fisher information matrices used here are only valid
- if \eqn{a>2}; these are where the regularity conditions for maximum
- likelihood estimation are satisfied.
- For this reason, the default link function for the shape parameter is
- a log-link with an offset value of \eqn{-2}.
+ Although the Fisher information matrices used here are valid
+ in all regions of the parameter space,
+ the regularity conditions for maximum
+ likelihood estimation are satisfied only if \eqn{a>2}
+ (according to Kleiber and Kotz (2003)).
+ If this is violated then a warning message is issued.
+ One can enforce \eqn{a>2} by choosing \code{lshape = "logoff"}
+ and \code{eshape=list(offset=-2)}.
}
\value{
@@ -98,10 +111,6 @@ Weibull and GE distributions,
Successful convergence depends on having reasonably good initial
values. If the initial values chosen by this function are not good,
make use the two initial value arguments.
- For censored data, numerical integration is used to compute the
- expected working weight matrices; this may fail if the data is
- censored `too much' and/or may be quite slow.
- See the example below on how to input censored data.
The Weibull distribution is often an alternative to the lognormal
distribution. The inverse Weibull distribution, which is that of
@@ -110,9 +119,14 @@ Weibull and GE distributions,
}
\section{Warning}{
- If the shape parameter is less than two then numerical problems may
- occur during the fitting and/or misleading inference may result in
- the \code{summary} of the object.
+ This function is under development to handle other censoring situations.
+ The version of this function which will handle censored data will be
+ called \code{cenweibull()}. It is currently being written and will use
+ \code{\link{Surv}} as input.
+ It should be released in later versions of \pkg{VGAM}.
+
+ If the shape parameter is less than two then misleading inference may
+ result, e.g., in the \code{summary} and \code{vcov} of the object.
}
@@ -125,25 +139,11 @@ Weibull and GE distributions,
\examples{
# Complete data
x = runif(n <- 1000)
-y = rweibull(n, shape=2+exp(1+x), scale = exp(-0.5))
-fit = vglm(y ~ x, weibull, tra=TRUE)
+y = rweibull(n, shape=exp(1+x), scale = exp(-0.5))
+fit = vglm(y ~ x, weibull, trace=TRUE)
coef(fit, mat=TRUE)
-Coef(fit)
-
-# Type-I right censored data
-cutpt = 0.6 # Making this too small results in numerical problems
-rcensored = y > cutpt
-cy = ifelse(rcensored, cutpt, y)
-table(rcensored)
-\dontrun{
-par(mfrow=1:2)
-hist(y, xlim=range(y))
-hist(cy, xlim=range(y), main="Censored y")
-}
-cfit = vglm(cy ~ x, weibull, trace=TRUE, crit="l",
- extra=list(rightcensored=rcensored))
-coef(cfit, mat=TRUE)
-summary(cfit)
+vcov(fit)
+summary(fit)
}
\keyword{models}
\keyword{regression}
diff --git a/man/zetaff.Rd b/man/zetaff.Rd
index 29d242c..a1bedca 100644
--- a/man/zetaff.Rd
+++ b/man/zetaff.Rd
@@ -63,7 +63,7 @@ ranging from values near 0 to values about 10 or more.
\references{
pp.465--471, Chapter 11 of
-Johnson NL, Kotz S, and Kemp AW (1993)
+Johnson N. L., Kotz S., and Kemp A. W. (1993)
\emph{Univariate Discrete Distributions},
2nd ed.
New York: Wiley.
diff --git a/man/zipf.Rd b/man/zipf.Rd
index bea1196..bde1e13 100644
--- a/man/zipf.Rd
+++ b/man/zipf.Rd
@@ -64,7 +64,7 @@ zipf(N=NULL, link="loge", earg=list(), init.s=NULL)
\references{
pp.465--471, Chapter 11 of
-Johnson NL, Kotz S, and Kemp AW (1993)
+Johnson N. L., Kotz S., and Kemp A. W. (1993)
\emph{Univariate Discrete Distributions},
2nd ed.
New York: Wiley.
diff --git a/man/zipoisson.Rd b/man/zipoisson.Rd
index 7df1974..21966e8 100644
--- a/man/zipoisson.Rd
+++ b/man/zipoisson.Rd
@@ -3,12 +3,14 @@
%- Also NEED an '\alias' for EACH other topic documented here.
\title{ Zero-Inflated Poisson Distribution Family Function }
\description{
- Fits a zero-inflated Poisson distribution.
+ Fits a zero-inflated Poisson distribution using full maximum likelihood
+ estimation.
+
}
\usage{
zipoisson(lphi="logit", llambda = "loge",
ephi=list(), elambda =list(),
- iphi = NULL, zero = NULL)
+ iphi = NULL, method.init=1, shrinkage.init=0.8, zero = NULL)
}
%- maybe also 'usage' for other objects documented here.
\arguments{
@@ -33,6 +35,22 @@ zipoisson(lphi="logit", llambda = "loge",
between 0 and 1. The default is to compute an initial value internally.
}
+ \item{method.init}{
+ An integer with value \code{1} or \code{2} which
+ specifies the initialization method for \eqn{\lambda}{lambda}.
+ If failure to converge occurs try another value
+ and/or else specify a value for \code{shrinkage.init}
+ and/or else specify a value for \code{iphi}.
+
+ }
+ \item{shrinkage.init}{
+ How much shrinkage is used when initializing \eqn{\lambda}{lambda}.
+ The value must be between 0 and 1 inclusive, and
+ a value of 0 means the individual response values are used,
+ and a value of 1 means the median or mean is used.
+ This argument is used in conjunction with \code{method.init}.
+
+ }
\item{zero}{
An integer specifying which linear/additive predictor is modelled as
intercepts only. If given, the value must be either 1 or 2, and the
@@ -83,7 +101,7 @@ zipoisson(lphi="logit", llambda = "loge",
This family function is now recommended above \code{\link{yip88}}.
The zero-\emph{deflated} Poisson distribution cannot be handled with
- this family function. It can be handled with the zero-altered Poisson
+ this family function. It can be handled with the zero-altered Poisson
distribution; see \code{\link{zapoisson}}.
}
@@ -91,7 +109,10 @@ zipoisson(lphi="logit", llambda = "loge",
\section{Warning }{
Numerical problems can occur.
Half-stepping is not uncommon.
- If failure to converge occurs, try using \code{iphi} and/or
+ If failure to converge occurs, try using combinations of
+ \code{method.init},
+ \code{shrinkage.init},
+ \code{iphi}, and/or
\code{zero=1} if there are explanatory variables.
}
@@ -115,7 +136,7 @@ coef(fit, matrix=TRUE) # These should agree with the above values
# Another example: data from McKendrick (1926).
y = 0:4 # Number of cholera cases per household in an Indian village
w = c(168, 32, 16, 6, 1) # Frequencies; there are 223=sum(w) households
-fit = vglm(y ~ 1, zipoisson(iphi=0.3), wei=w, trace=TRUE)
+fit = vglm(y ~ 1, zipoisson, wei=w, trace=TRUE)
coef(fit, matrix=TRUE)
cbind(actual=w, fitted=
dzipois(y, lambda=Coef(fit)[2], phi=Coef(fit)[1]) * sum(w))
diff --git a/src/muxr.c b/src/muxr.c
index 57eec56..2f50c92 100644
--- a/src/muxr.c
+++ b/src/muxr.c
@@ -131,6 +131,13 @@ void mux5(double *cc, double *x,
printf("Error: can only handle matrix.arg == 1\n");
exit(-1);
*/
+
+/*
+26/9/07:
+The following line was added only to avoid a warning message from the compiler
+*/
+ pd = pd2 = wk;
+
}
for(i = 0; i < *n; i++)
diff --git a/src/vcall2.f b/src/vcall2.f
index 22e52cc..6e009b6 100644
--- a/src/vcall2.f
+++ b/src/vcall2.f
@@ -1,10 +1,23 @@
subroutine vcall2(onemor,w,y,eta,beta,u)
logical onemor
double precision w(1), y(1), eta(1), beta(1), u(1)
+ onemor = .true.
+ w(1) = 1.0d0
+ y(1) = 1.0d0
+ eta(1) = 1.0d0
+ beta(1) = 1.0d0
+ u(1) = 1.0d0
return
end
subroutine vcall1(onemor,y,eta,beta,u,xbig,cpxbig)
logical onemor, cpxbig
double precision y(1), eta(1), beta(1), u(1), xbig(1)
+ onemor = .true.
+ y(1) = 1.0d0
+ eta(1) = 1.0d0
+ beta(1) = 1.0d0
+ u(1) = 1.0d0
+ xbig(1) = 1.0d0
+ cpxbig = .true.
return
end
diff --git a/src/vmux.f b/src/vmux.f
index bb223e5..7df8880 100644
--- a/src/vmux.f
+++ b/src/vmux.f
@@ -507,7 +507,7 @@
23149 continue
return
end
- subroutine mbessi0(vectob, nfiumb4, xt3fko, d0, d1, d2, gqxvz8,
+ subroutine mbessi0(yg1jzv, nfiumb4, xt3fko, d0, d1, d2, gqxvz8,
&kqoy6w)
implicit logical (a-z)
integer nfiumb4, xt3fko, gqxvz8, pga6nus
--
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